From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 8 Nov 2017 23:47:26 +0100 Subject: Use a better project structure --- client/LICENSE | 674 +++++++++++++++++++++++++++++++++++++++ client/Setup.hs | 2 + client/client.cabal | 24 ++ client/src/Component/Button.hs | 53 +++ client/src/Component/Input.hs | 34 ++ client/src/Icon.hs | 44 +++ client/src/Main.hs | 40 +++ client/src/View/App.hs | 44 +++ client/src/View/Header.hs | 86 +++++ client/src/View/Payment.hs | 33 ++ client/src/View/Payment/Table.hs | 90 ++++++ client/src/View/SignIn.hs | 86 +++++ 12 files changed, 1210 insertions(+) create mode 100644 client/LICENSE create mode 100644 client/Setup.hs create mode 100644 client/client.cabal create mode 100644 client/src/Component/Button.hs create mode 100644 client/src/Component/Input.hs create mode 100644 client/src/Icon.hs create mode 100644 client/src/Main.hs create mode 100644 client/src/View/App.hs create mode 100644 client/src/View/Header.hs create mode 100644 client/src/View/Payment.hs create mode 100644 client/src/View/Payment/Table.hs create mode 100644 client/src/View/SignIn.hs (limited to 'client') diff --git a/client/LICENSE b/client/LICENSE new file mode 100644 index 0000000..45644ff --- /dev/null +++ b/client/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a 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. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/client/Setup.hs b/client/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/client/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/client/client.cabal b/client/client.cabal new file mode 100644 index 0000000..7807d37 --- /dev/null +++ b/client/client.cabal @@ -0,0 +1,24 @@ +name: client +version: 0.0.1 +license: GPL-3 +license-file: LICENSE +author: Joris Guyonvarch +maintainer: joris@guyonvarch.me +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable client + main-is: Main.hs + ghc-options: -Wall -Werror + build-depends: aeson + , base >=4.9 && <4.11 + , bytestring + , common + , containers + , ghcjs-dom-jsffi + , reflex-dom + , text + , time + hs-source-dirs: src + default-language: Haskell2010 diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs new file mode 100644 index 0000000..f21798c --- /dev/null +++ b/client/src/Component/Button.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Component.Button + ( ButtonIn(..) + , buttonInDefault + , ButtonOut(..) + , button + ) where + +import qualified Data.Map as M +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R + +import qualified Icon + +data ButtonIn t m = ButtonIn + { _buttonIn_class :: Text + , _buttonIn_content :: m () + , _buttonIn_waiting :: Event t Bool + } + +buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m +buttonInDefault = ButtonIn + { _buttonIn_class = "" + , _buttonIn_content = R.blank + , _buttonIn_waiting = R.never + } + +data ButtonOut t = ButtonOut + { _buttonOut_clic :: Event t () + } + +button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) +button buttonIn = do + attr <- R.holdDyn + (M.fromList [("type", "button"), ("class", _buttonIn_class buttonIn)]) + (fmap + (\w -> M.fromList $ + [ ("type", "button") ] + <> if w + then [("class", T.concat [ _buttonIn_class buttonIn, " waiting" ])] + else [("class", _buttonIn_class buttonIn)]) + (_buttonIn_waiting buttonIn)) + (e, _) <- R.elDynAttr' "button" attr $ do + Icon.loading + R.divClass "content" $ _buttonIn_content buttonIn + return $ ButtonOut + { _buttonOut_clic = R.domEvent R.Click e + } diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs new file mode 100644 index 0000000..7111630 --- /dev/null +++ b/client/src/Component/Input.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Component.Input + ( InputIn(..) + , InputOut(..) + , input + ) where + +import Data.Text (Text) +import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:)) +import qualified Reflex.Dom as R + +data InputIn t a b = InputIn + { _inputIn_reset :: Event t a + , _inputIn_placeHolder :: Text + } + +data InputOut t = InputOut + { _inputOut_value :: Dynamic t Text + , _inputOut_enter :: Event t () + } + +input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) +input inputIn = do + let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn) + let value = fmap (const "") (_inputIn_reset inputIn) + textInput <- R.textInput $ R.def & R.attributes .~ placeHolder + & R.setValue .~ value + let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + return $ InputOut + { _inputOut_value = R._textInput_value textInput + , _inputOut_enter = enter + } diff --git a/client/src/Icon.hs b/client/src/Icon.hs new file mode 100644 index 0000000..7223def --- /dev/null +++ b/client/src/Icon.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Icon + ( loading + , signOut + , clone + , edit + , delete + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +loading :: forall t m. MonadWidget t m => m () +loading = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ + svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank + +signOut :: forall t m. MonadWidget t m => m () +signOut = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank + +clone :: forall t m. MonadWidget t m => m () +clone = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank + +edit :: forall t m. MonadWidget t m => m () +edit = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank + +delete :: forall t m. MonadWidget t m => m () +delete = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank + +svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a +svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/client/src/Main.hs b/client/src/Main.hs new file mode 100644 index 0000000..1f167d4 --- /dev/null +++ b/client/src/Main.hs @@ -0,0 +1,40 @@ +module Main + ( main + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LB +import Data.JSString.Text (textFromJSString) +import qualified Data.Text.Encoding as T +import qualified GHCJS.DOM as Dom +import qualified GHCJS.DOM.NonElementParentNode as Dom +import GHCJS.DOM.Types (JSM, Element, JSString) +import Prelude hiding (init, error) + +import Common.Model (InitResult(InitEmpty)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key + +import qualified View.App as App + +main :: JSM () +main = do + initResult <- readInit + App.widget initResult + +readInit :: JSM InitResult +readInit = do + document <- Dom.currentDocumentUnchecked + initNode <- Dom.getElementById document "init" + case initNode of + Just node -> do + text <- textFromJSString <$> js_getInnerText node + return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of + Just init -> init + Nothing -> initParseError + _ -> + return initParseError + where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) + +foreign import javascript unsafe "$1[\"innerText\"]" + js_getInnerText :: Element -> IO JSString diff --git a/client/src/View/App.hs b/client/src/View/App.hs new file mode 100644 index 0000000..1466811 --- /dev/null +++ b/client/src/View/App.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.App + ( widget + ) where + +import qualified Reflex.Dom as R +import Prelude hiding (init, error) + +import Common.Model (InitResult(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key + +import View.Header (HeaderIn(..)) +import View.Payment (PaymentIn(..)) +import qualified View.Header as Header +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn + +widget :: InitResult -> IO () +widget initResult = + R.mainWidget $ do + headerOut <- Header.view $ HeaderIn + { _headerIn_initResult = initResult + } + + let signOut = Header._headerOut_signOut headerOut + + initialContent = case initResult of + InitSuccess initSuccess -> do + _ <- Payment.widget $ PaymentIn + { _paymentIn_init = initSuccess + } + return () + InitEmpty result -> + SignIn.view result + + signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess) + + _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) + + R.blank diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs new file mode 100644 index 0000000..705e054 --- /dev/null +++ b/client/src/View/Header.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Header + ( view + , HeaderIn(..) + , HeaderOut(..) + ) where + +import qualified Data.Map as M +import Data.Time (NominalDiffTime) +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R +import Prelude hiding (init, error) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult(..), Init(..), User(..)) +import qualified Common.Model as CM + +import Component.Button (ButtonIn(..)) +import qualified Component.Button as Component +import qualified Icon + +data HeaderIn = HeaderIn + { _headerIn_initResult :: InitResult + } + +data HeaderOut t = HeaderOut + { _headerOut_signOut :: Event t () + } + +view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t) +view headerIn = + R.el "header" $ do + + R.divClass "title" $ + R.text $ Message.get Key.App_Title + + signOut <- nameSignOut $ _headerIn_initResult headerIn + + return $ HeaderOut + { _headerOut_signOut = signOut + } + +nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) +nameSignOut initResult = case initResult of + (InitSuccess init) -> do + rec + attr <- R.holdDyn + (M.singleton "class" "nameSignOut") + (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) + + signOut <- R.elDynAttr "nameSignOut" attr $ do + case CM.findUser (_init_currentUser init) (_init_users init) of + Just user -> R.divClass "name" $ R.text (_user_name user) + Nothing -> R.blank + signOutButton + + return signOut + _ -> + return R.never + +signOutButton :: forall t m. MonadWidget t m => m (Event t ()) +signOutButton = do + rec + signOut <- Component.button $ ButtonIn + { Component._buttonIn_class = "signOut item" + , Component._buttonIn_content = Icon.signOut + , Component._buttonIn_waiting = waiting + } + let signOutClic = Component._buttonOut_clic signOut + waiting = R.leftmost + [ fmap (const True) signOutClic + , fmap (const False) signOutSuccess + ] + signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime) + + return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess + + where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool) + askSignOut signOut = + fmap getResult <$> R.performRequestAsync xhrRequest + where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut + getResult = (== 200) . R._xhrResponse_status diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs new file mode 100644 index 0000000..e80790b --- /dev/null +++ b/client/src/View/Payment.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Payment + ( widget + , PaymentIn(..) + , PaymentOut(..) + ) where + +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init) + +import View.Payment.Table (TableIn(..)) +import qualified View.Payment.Table as Table + +data PaymentIn = PaymentIn + { _paymentIn_init :: Init + } + +data PaymentOut = PaymentOut + { + } + +widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut +widget paymentIn = do + R.divClass "payment" $ do + _ <- Table.widget $ TableIn + { _tableIn_init = _paymentIn_init paymentIn + } + return $ PaymentOut {} diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs new file mode 100644 index 0000000..f3eb9a7 --- /dev/null +++ b/client/src/View/Payment/Table.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Payment.Table + ( widget + , TableIn(..) + , TableOut(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.List as L +import qualified Data.Map as M +import Prelude hiding (init) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..)) +import qualified Common.Model as CM +import qualified Common.Util.Text as T +import qualified Common.View.Format as Format + +import qualified Icon + +data TableIn = TableIn + { _tableIn_init :: Init + } + +data TableOut = TableOut + { + } + +widget :: forall t m. MonadWidget t m => TableIn -> m TableOut +widget tableIn = do + R.divClass "table" $ + R.divClass "lines" $ do + R.divClass "header" $ do + R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name + R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost + R.divClass "cell user" $ R.text $ Message.get Key.Payment_User + R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category + R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date + R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank + let init = _tableIn_init tableIn + payments = _init_payments init + mapM_ + (paymentRow init) + (take 8 . reverse . L.sortOn _payment_date $ payments) + return $ TableOut {} + +paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m () +paymentRow init payment = + R.divClass "row" $ do + R.divClass "cell name" . R.text $ _payment_name payment + R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment + R.divClass "cell user" $ + case CM.findUser (_payment_user payment) (_init_users init) of + Just user -> R.text (_user_name user) + _ -> R.blank + R.divClass "cell category" $ + case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of + Just category -> + R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $ + R.text $ _category_name category + _ -> + R.blank + R.divClass "cell date" $ do + R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment) + R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment) + R.divClass "cell button" . R.el "button" $ Icon.clone + R.divClass "cell button" $ + if _payment_user payment == (_init_currentUser init) + then R.el "button" $ Icon.edit + else R.blank + R.divClass "cell button" $ + if _payment_user payment == (_init_currentUser init) + then R.el "button" $ Icon.delete + else R.blank + +findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category +findCategory categories paymentCategories paymentName = do + paymentCategory <- L.find + ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name) + paymentCategories + L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs new file mode 100644 index 0000000..e164ee7 --- /dev/null +++ b/client/src/View/SignIn.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.SignIn + ( view + ) where + +import qualified Data.Either as Either +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) +import Prelude hiding (error) +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (SignIn(SignIn)) + +import Component.Input (InputIn(..), InputOut(..)) +import Component.Button (ButtonIn(..), ButtonOut(..)) +import qualified Component.Button as Component +import qualified Component.Input as Component + +view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () +view result = + R.divClass "signIn" $ do + rec + input <- Component.input $ InputIn + { _inputIn_reset = R.ffilter Either.isRight signInResult + , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder + } + + let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button + + dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $ + [ fmap (const True) userWantsEmailValidation + , fmap (const False) signInResult + ] + + uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail + + let validatedEmail = R.tagPromptlyDyn + (_inputOut_value input) + (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail) + + let waiting = R.leftmost + [ fmap (const True) validatedEmail + , fmap (const False) signInResult + ] + + button <- Component.button $ ButtonIn + { _buttonIn_class = "" + , _buttonIn_content = R.text (Message.get Key.SignIn_Button) + , _buttonIn_waiting = waiting + } + + signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime) + + showSignInResult result signInResult + +askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text)) +askSignIn email = + fmap getResult <$> R.performRequestAsync xhrRequest + where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email + getResult response = + case R._xhrResponse_responseText response of + Just key -> + if R._xhrResponse_status response == 200 then Right key else Left key + _ -> Left "NoKey" + +showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m () +showSignInResult result signInResult = do + _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult + R.blank + + where showInitResult (Left error) = showError error + showInitResult (Right (Just success)) = showSuccess success + showInitResult (Right Nothing) = R.blank + + showResult (Left error) = showError error + showResult (Right success) = showSuccess success + + showError = R.divClass "error" . R.text + showSuccess = R.divClass "success" . R.text -- cgit v1.2.3 From 213cf7ede058b781fc957de2cd9f6a5988c08004 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 12 Nov 2017 22:58:23 +0100 Subject: Add mocked pages --- client/client.cabal | 12 ++++++++- client/src/Icon.hs | 58 ++++++++++++++++++++++++++++------------ client/src/Main.hs | 15 +++++------ client/src/View/Payment.hs | 7 ++++- client/src/View/Payment/Pages.hs | 42 +++++++++++++++++++++++++++++ 5 files changed, 107 insertions(+), 27 deletions(-) create mode 100644 client/src/View/Payment/Pages.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 7807d37..9d3e873 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -16,9 +16,19 @@ executable client , bytestring , common , containers - , ghcjs-dom-jsffi + , jsaddle-dom , reflex-dom , text , time hs-source-dirs: src default-language: Haskell2010 + other-modules: Component.Button + , Component.Input + , Icon + , Main + , View.App + , View.Header + , View.Payment + , View.Payment.Pages + , View.Payment.Table + , View.SignIn diff --git a/client/src/Icon.hs b/client/src/Icon.hs index 7223def..6b2749a 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -2,11 +2,15 @@ {-# LANGUAGE OverloadedStrings #-} module Icon - ( loading - , signOut - , clone - , edit + ( clone , delete + , edit + , loading + , doubleLeft + , doubleLeftBar + , doubleRight + , doubleRightBar + , signOut ) where import Data.Map (Map) @@ -15,30 +19,50 @@ import Data.Text (Text) import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -loading :: forall t m. MonadWidget t m => m () -loading = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ - svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank - -signOut :: forall t m. MonadWidget t m => m () -signOut = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank - clone :: forall t m. MonadWidget t m => m () clone = svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank +delete :: forall t m. MonadWidget t m => m () +delete = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank + +doubleLeft :: forall t m. MonadWidget t m => m () +doubleLeft = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1683 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-8-9-13-19v710q0 26-13 32t-32-13l-710-710q-19-19-19-45t19-45l710-710q19-19 32-13t13 32v710q5-11 13-19z")]) $ R.blank + +doubleLeftBar :: forall t m. MonadWidget t m => m () +doubleLeftBar = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1747 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-9-9-13-19v710q0 26-13 32t-32-13l-710-710q-9-9-13-19v678q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-1408q0-26 19-45t45-19h128q26 0 45 19t19 45v678q4-11 13-19l710-710q19-19 32-13t13 32v710q4-11 13-19z")]) $ R.blank + +doubleRight :: forall t m. MonadWidget t m => m () +doubleRight = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M109 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q19 19 19 45t-19 45l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank + +doubleRightBar :: forall t m. MonadWidget t m => m () +doubleRightBar = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M45 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q8 8 13 19v-678q0-26 19-45t45-19h128q26 0 45 19t19 45v1408q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-678q-5 10-13 19l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank + edit :: forall t m. MonadWidget t m => m () edit = svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank -delete :: forall t m. MonadWidget t m => m () -delete = +loading :: forall t m. MonadWidget t m => m () +loading = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ + svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank + +signOut :: forall t m. MonadWidget t m => m () +signOut = svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank + svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/client/src/Main.hs b/client/src/Main.hs index 1f167d4..14f0fee 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -4,11 +4,13 @@ module Main import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as LB -import Data.JSString.Text (textFromJSString) +import qualified Data.JSString.Text as Dom import qualified Data.Text.Encoding as T -import qualified GHCJS.DOM as Dom -import qualified GHCJS.DOM.NonElementParentNode as Dom -import GHCJS.DOM.Types (JSM, Element, JSString) +import qualified JSDOM as Dom +import qualified JSDOM.Generated.HTMLElement as Dom +import qualified JSDOM.Generated.NonElementParentNode as Dom +import JSDOM.Types (JSM, HTMLElement(..)) +import qualified JSDOM.Types as Dom import Prelude hiding (init, error) import Common.Model (InitResult(InitEmpty)) @@ -28,13 +30,10 @@ readInit = do initNode <- Dom.getElementById document "init" case initNode of Just node -> do - text <- textFromJSString <$> js_getInnerText node + text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node) return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of Just init -> init Nothing -> initParseError _ -> return initParseError where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) - -foreign import javascript unsafe "$1[\"innerText\"]" - js_getInnerText :: Element -> IO JSString diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index e80790b..d1430c9 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -11,8 +11,10 @@ module View.Payment import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init) +import Common.Model (Init(..)) +import View.Payment.Pages (PagesIn(..)) +import qualified View.Payment.Pages as Pages import View.Payment.Table (TableIn(..)) import qualified View.Payment.Table as Table @@ -30,4 +32,7 @@ widget paymentIn = do _ <- Table.widget $ TableIn { _tableIn_init = _paymentIn_init paymentIn } + _ <- Pages.widget $ PagesIn + { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn + } return $ PaymentOut {} diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs new file mode 100644 index 0000000..f9a2b4e --- /dev/null +++ b/client/src/View/Payment/Pages.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Payment.Pages + ( widget + , PagesIn(..) + , PagesOut(..) + ) where + +import qualified Data.Text as T +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Payment(..)) + +import qualified Icon + +data PagesIn = PagesIn + { _pagesIn_payments :: [Payment] + } + +data PagesOut = PagesOut + { + } + +widget :: forall t m. MonadWidget t m => PagesIn -> m PagesOut +widget _ = do + R.divClass "pages" $ do + page Icon.doubleLeftBar + page Icon.doubleLeft + page (R.text . T.pack . show $ (1 :: Integer)) + page (R.text . T.pack . show $ (2 :: Integer)) + page (R.text . T.pack . show $ (3 :: Integer)) + page (R.text . T.pack . show $ (4 :: Integer)) + page (R.text . T.pack . show $ (5 :: Integer)) + page Icon.doubleRight + page Icon.doubleRightBar + return $ PagesOut {} + +page :: forall t m. MonadWidget t m => m () -> m () +page content = R.elClass "button" "page" $ content -- cgit v1.2.3 From 5a63f7be9375e3ab888e4232dd7ef72c2f1ffae1 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 13 Nov 2017 23:56:40 +0100 Subject: Setup stylish-haskell --- client/Setup.hs | 2 +- client/client.cabal | 73 +++++++++++++++------------- client/src/Component.hs | 4 ++ client/src/Component/Button.hs | 17 +++---- client/src/Component/Input.hs | 9 ++-- client/src/Icon.hs | 11 ++--- client/src/Main.hs | 28 +++++------ client/src/View/App.hs | 23 +++++---- client/src/View/Header.hs | 27 +++++------ client/src/View/Payment.hs | 29 +++++------ client/src/View/Payment/Pages.hs | 57 +++++++++++++--------- client/src/View/Payment/Table.hs | 102 ++++++++++++++++++++++----------------- client/src/View/SignIn.hs | 36 +++++++------- 13 files changed, 224 insertions(+), 194 deletions(-) create mode 100644 client/src/Component.hs (limited to 'client') diff --git a/client/Setup.hs b/client/Setup.hs index 9a994af..4467109 100644 --- a/client/Setup.hs +++ b/client/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/client/client.cabal b/client/client.cabal index 9d3e873..ac74d9c 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -1,34 +1,41 @@ -name: client -version: 0.0.1 -license: GPL-3 -license-file: LICENSE -author: Joris Guyonvarch -maintainer: joris@guyonvarch.me -category: Web -build-type: Simple -cabal-version: >=1.10 +Name: client +Version: 0.0.1 +License: GPL-3 +License-file: LICENSE +Author: Joris Guyonvarch +Maintainer: joris@guyonvarch.me +Category: Web +Build-type: Simple +Cabal-version: >=1.10 -executable client - main-is: Main.hs - ghc-options: -Wall -Werror - build-depends: aeson - , base >=4.9 && <4.11 - , bytestring - , common - , containers - , jsaddle-dom - , reflex-dom - , text - , time - hs-source-dirs: src - default-language: Haskell2010 - other-modules: Component.Button - , Component.Input - , Icon - , Main - , View.App - , View.Header - , View.Payment - , View.Payment.Pages - , View.Payment.Table - , View.SignIn +Executable client + Main-Is: Main.hs + Ghc-options: -Wall -Werror + Hs-source-dirs: src + Default-language: Haskell2010 + Extensions: + ExistentialQuantification + MultiParamTypeClasses + + Build-depends: + aeson + , base >=4.9 && <4.11 + , bytestring + , common + , containers + , jsaddle-dom + , reflex-dom + , text + , time + + other-modules: + Component.Button + Component.Input + Icon + Main + View.App + View.Header + View.Payment + View.Payment.Pages + View.Payment.Table + View.SignIn diff --git a/client/src/Component.hs b/client/src/Component.hs new file mode 100644 index 0000000..4c9541b --- /dev/null +++ b/client/src/Component.hs @@ -0,0 +1,4 @@ +module Component (module X) where + +import Component.Button as X +import Component.Input as X diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index f21798c..9499045 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Component.Button ( ButtonIn(..) @@ -8,17 +7,17 @@ module Component.Button , button ) where -import qualified Data.Map as M -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R import qualified Icon data ButtonIn t m = ButtonIn - { _buttonIn_class :: Text + { _buttonIn_class :: Text , _buttonIn_content :: m () , _buttonIn_waiting :: Event t Bool } diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 7111630..c3864b4 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Component.Input ( InputIn(..) @@ -7,12 +6,12 @@ module Component.Input , input ) where -import Data.Text (Text) -import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:)) +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~), (=:)) import qualified Reflex.Dom as R data InputIn t a b = InputIn - { _inputIn_reset :: Event t a + { _inputIn_reset :: Event t a , _inputIn_placeHolder :: Text } diff --git a/client/src/Icon.hs b/client/src/Icon.hs index 6b2749a..cd5a0b4 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Icon ( clone @@ -13,10 +12,10 @@ module Icon , signOut ) where -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import Reflex.Dom (MonadWidget) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R clone :: forall t m. MonadWidget t m => m () diff --git a/client/src/Main.hs b/client/src/Main.hs index 14f0fee..cbc881c 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -2,22 +2,22 @@ module Main ( main ) where -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as LB -import qualified Data.JSString.Text as Dom -import qualified Data.Text.Encoding as T -import qualified JSDOM as Dom -import qualified JSDOM.Generated.HTMLElement as Dom +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LB +import qualified Data.JSString.Text as Dom +import qualified Data.Text.Encoding as T +import qualified JSDOM as Dom +import qualified JSDOM.Generated.HTMLElement as Dom import qualified JSDOM.Generated.NonElementParentNode as Dom -import JSDOM.Types (JSM, HTMLElement(..)) -import qualified JSDOM.Types as Dom -import Prelude hiding (init, error) +import JSDOM.Types (HTMLElement (..), JSM) +import qualified JSDOM.Types as Dom +import Prelude hiding (error, init) -import Common.Model (InitResult(InitEmpty)) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult (InitEmpty)) -import qualified View.App as App +import qualified View.App as App main :: JSM () main = do @@ -33,7 +33,7 @@ readInit = do text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node) return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of Just init -> init - Nothing -> initParseError + Nothing -> initParseError _ -> return initParseError where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 1466811..442fa3e 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -1,23 +1,22 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.App ( widget ) where -import qualified Reflex.Dom as R -import Prelude hiding (init, error) +import Prelude hiding (error, init) +import qualified Reflex.Dom as R -import Common.Model (InitResult(..)) -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key +import Common.Model (InitResult (..)) -import View.Header (HeaderIn(..)) -import View.Payment (PaymentIn(..)) -import qualified View.Header as Header -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn +import View.Header (HeaderIn (..)) +import qualified View.Header as Header +import View.Payment (PaymentIn (..)) +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 705e054..711ba80 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Header ( view @@ -8,19 +7,19 @@ module View.Header , HeaderOut(..) ) where -import qualified Data.Map as M -import Data.Time (NominalDiffTime) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R -import Prelude hiding (init, error) +import qualified Data.Map as M +import Data.Time (NominalDiffTime) +import Prelude hiding (error, init) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), Init(..), User(..)) -import qualified Common.Model as CM +import Common.Model (Init (..), InitResult (..), User (..)) +import qualified Common.Model as CM -import Component.Button (ButtonIn(..)) -import qualified Component.Button as Component +import Component.Button (ButtonIn (..)) +import qualified Component.Button as Component import qualified Icon data HeaderIn = HeaderIn @@ -55,7 +54,7 @@ nameSignOut initResult = case initResult of signOut <- R.elDynAttr "nameSignOut" attr $ do case CM.findUser (_init_currentUser init) (_init_users init) of Just user -> R.divClass "name" $ R.text (_user_name user) - Nothing -> R.blank + Nothing -> R.blank signOutButton return signOut diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index d1430c9..f70c8cd 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment ( widget @@ -8,14 +7,14 @@ module View.Payment , PaymentOut(..) ) where -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Init(..)) +import Common.Model (Init (..)) -import View.Payment.Pages (PagesIn(..)) +import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn(..)) +import View.Payment.Table (TableIn (..)) import qualified View.Payment.Table as Table data PaymentIn = PaymentIn @@ -29,10 +28,12 @@ data PaymentOut = PaymentOut widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut widget paymentIn = do R.divClass "payment" $ do - _ <- Table.widget $ TableIn - { _tableIn_init = _paymentIn_init paymentIn - } - _ <- Pages.widget $ PagesIn - { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn - } + rec + _ <- Table.widget $ TableIn + { _tableIn_init = _paymentIn_init paymentIn + , _tableIn_currentPage = _pagesOut_currentPage pagesOut + } + pagesOut <- Pages.widget $ PagesIn + { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn + } return $ PaymentOut {} diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index f9a2b4e..cf3e115 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment.Pages ( widget @@ -8,35 +7,45 @@ module View.Payment.Pages , PagesOut(..) ) where -import qualified Data.Text as T -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Event, Dynamic, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Payment(..)) +import Common.Model (Payment (..)) +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component import qualified Icon data PagesIn = PagesIn { _pagesIn_payments :: [Payment] } -data PagesOut = PagesOut - { +data PagesOut t = PagesOut + { _pagesOut_currentPage :: Dynamic t Int } -widget :: forall t m. MonadWidget t m => PagesIn -> m PagesOut +widget :: forall t m. MonadWidget t m => PagesIn -> m (PagesOut t) widget _ = do - R.divClass "pages" $ do - page Icon.doubleLeftBar - page Icon.doubleLeft - page (R.text . T.pack . show $ (1 :: Integer)) - page (R.text . T.pack . show $ (2 :: Integer)) - page (R.text . T.pack . show $ (3 :: Integer)) - page (R.text . T.pack . show $ (4 :: Integer)) - page (R.text . T.pack . show $ (5 :: Integer)) - page Icon.doubleRight - page Icon.doubleRightBar - return $ PagesOut {} - -page :: forall t m. MonadWidget t m => m () -> m () -page content = R.elClass "button" "page" $ content + currentPage <- R.divClass "pages" $ do + a <- page 1 Icon.doubleLeftBar + b <- page 1 Icon.doubleLeft + c <- page 1 (R.text . T.pack . show $ (1 :: Integer)) + d <- page 2 (R.text . T.pack . show $ (2 :: Integer)) + e <- page 3 (R.text . T.pack . show $ (3 :: Integer)) + f <- page 4 (R.text . T.pack . show $ (4 :: Integer)) + g <- page 5 (R.text . T.pack . show $ (5 :: Integer)) + h <- page 5 Icon.doubleRight + i <- page 5 Icon.doubleRightBar + R.holdDyn 1 $ R.leftmost [ a, b, c, d, e, f, g, h, i ] + return $ PagesOut + { _pagesOut_currentPage = currentPage + } + +page :: forall t m. MonadWidget t m => Int -> m () -> m (Event t Int) +page n content = + ((fmap (const n)) . _buttonOut_clic) <$> (Component.button $ ButtonIn + { _buttonIn_class = "page" + , _buttonIn_content = content + , _buttonIn_waiting = R.never + }) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index f3eb9a7..734511d 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment.Table ( widget @@ -8,34 +7,40 @@ module View.Payment.Table , TableOut(..) ) where -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.List as L -import qualified Data.Map as M -import Prelude hiding (init) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.List as L +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (MonadWidget, Dynamic) +import qualified Reflex.Dom as R -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..)) -import qualified Common.Model as CM -import qualified Common.Util.Text as T +import Common.Model (Category (..), Init (..), Payment (..), + PaymentCategory (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Util.Text as T import qualified Common.View.Format as Format import qualified Icon -data TableIn = TableIn +data TableIn t = TableIn { _tableIn_init :: Init + , _tableIn_currentPage :: Dynamic t Int } data TableOut = TableOut { } -widget :: forall t m. MonadWidget t m => TableIn -> m TableOut +visiblePayments :: Int +visiblePayments = 8 + +widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut widget tableIn = do - R.divClass "table" $ + R.dynText (fmap (T.pack . show) . _tableIn_currentPage $ tableIn) + _ <- R.divClass "table" $ R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name @@ -48,39 +53,50 @@ widget tableIn = do R.divClass "cell" $ R.blank let init = _tableIn_init tableIn payments = _init_payments init - mapM_ - (paymentRow init) - (take 8 . reverse . L.sortOn _payment_date $ payments) + paymentRange = fmap + (\p -> take visiblePayments . drop ((p - 1) * visiblePayments) . reverse . L.sortOn _payment_date $ payments) + (_tableIn_currentPage tableIn) + R.simpleList paymentRange (paymentRow init) return $ TableOut {} -paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m () +paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () paymentRow init payment = R.divClass "row" $ do - R.divClass "cell name" . R.text $ _payment_name payment - R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment + R.divClass "cell name" . R.dynText . fmap _payment_name $ payment + R.divClass "cell cost" . R.dynText . fmap (Format.price (_init_currency init) . _payment_cost) $ payment + + let user = flip fmap payment $ \p -> CM.findUser (_payment_user p) (_init_users init) R.divClass "cell user" $ - case CM.findUser (_payment_user payment) (_init_users init) of - Just user -> R.text (_user_name user) - _ -> R.blank - R.divClass "cell category" $ - case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of - Just category -> - R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $ - R.text $ _category_name category - _ -> - R.blank + R.dynText $ flip fmap user $ \mbUser -> case mbUser of + Just u -> _user_name u + _ -> "" + + let category = flip fmap payment $ \p -> findCategory + (_init_categories init) + (_init_paymentCategories init) + (_payment_name p) + R.divClass "cell category" $ do + let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of + Just c -> M.fromList + [ ("class", "tag") + , ("style", T.concat [ "background-color: ", _category_color c ]) + ] + Nothing -> M.singleton "display" "none" + R.elDynAttr "span" attrs $ + R.dynText $ flip fmap category $ \mbCategory -> case mbCategory of + Just c -> _category_name c + _ -> "" + R.divClass "cell date" $ do - R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment) - R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment) + R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment + R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment R.divClass "cell button" . R.el "button" $ Icon.clone - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.edit - else R.blank - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.delete - else R.blank + let modifyAttrs = flip fmap payment $ \p -> + M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")] + R.elDynAttr "div" modifyAttrs $ + R.el "button" $ Icon.edit + R.elDynAttr "div" modifyAttrs $ + R.el "button" $ Icon.delete findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index e164ee7..70c6b1f 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,27 +1,25 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.SignIn ( view ) where -import qualified Data.Either as Either -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time (NominalDiffTime) -import Prelude hiding (error) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R +import qualified Data.Either as Either +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) +import Prelude hiding (error) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (SignIn(SignIn)) +import Common.Model (SignIn (SignIn)) -import Component.Input (InputIn(..), InputOut(..)) -import Component.Button (ButtonIn(..), ButtonOut(..)) -import qualified Component.Button as Component -import qualified Component.Input as Component +import Component (ButtonIn (..), ButtonOut (..), + InputIn (..), InputOut (..)) +import qualified Component as Component view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () view result = @@ -75,11 +73,11 @@ showSignInResult result signInResult = do _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult R.blank - where showInitResult (Left error) = showError error + where showInitResult (Left error) = showError error showInitResult (Right (Just success)) = showSuccess success - showInitResult (Right Nothing) = R.blank + showInitResult (Right Nothing) = R.blank - showResult (Left error) = showError error + showResult (Left error) = showError error showResult (Right success) = showSuccess success showError = R.divClass "error" . R.text -- cgit v1.2.3 From 42e94a45e26f40edc3ad71b1e77a4bf47c13fd3d Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 15 Nov 2017 23:50:44 +0100 Subject: Add dynamic pages --- client/src/Component/Button.hs | 40 +++++++++++--------- client/src/View/Header.hs | 2 +- client/src/View/Payment/Constants.hs | 6 +++ client/src/View/Payment/Pages.hs | 71 +++++++++++++++++++++++------------- client/src/View/Payment/Table.hs | 50 +++++++++++++------------ client/src/View/SignIn.hs | 2 +- 6 files changed, 103 insertions(+), 68 deletions(-) create mode 100644 client/src/View/Payment/Constants.hs (limited to 'client') diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 9499045..c31cdc6 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -7,24 +7,23 @@ module Component.Button , button ) where -import qualified Data.Map as M -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R import qualified Icon data ButtonIn t m = ButtonIn - { _buttonIn_class :: Text + { _buttonIn_class :: Dynamic t Text , _buttonIn_content :: m () , _buttonIn_waiting :: Event t Bool } buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m buttonInDefault = ButtonIn - { _buttonIn_class = "" + { _buttonIn_class = R.constDyn "" , _buttonIn_content = R.blank , _buttonIn_waiting = R.never } @@ -35,18 +34,25 @@ data ButtonOut t = ButtonOut button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) button buttonIn = do - attr <- R.holdDyn - (M.fromList [("type", "button"), ("class", _buttonIn_class buttonIn)]) - (fmap - (\w -> M.fromList $ - [ ("type", "button") ] - <> if w - then [("class", T.concat [ _buttonIn_class buttonIn, " waiting" ])] - else [("class", _buttonIn_class buttonIn)]) - (_buttonIn_waiting buttonIn)) + dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn + + let attr = do + buttonClass <- _buttonIn_class buttonIn + waiting <- dynWaiting + return $ if waiting + then M.fromList [("type", "button"), ("class", T.intercalate " " [ buttonClass, "waiting" ])] + else M.fromList [("type", "button"), ("class", buttonClass)] + (e, _) <- R.elDynAttr' "button" attr $ do Icon.loading R.divClass "content" $ _buttonIn_content buttonIn + return $ ButtonOut { _buttonOut_clic = R.domEvent R.Click e } + +-- mergeAttr :: Map Text Text -> Map Text Text -> Map Text Text +-- mergeAttr = M.unionWithKey $ \k a b -> +-- if k == "class" +-- then T.intercalate " " [ a, b ] +-- else b diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 711ba80..7afd9bd 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -65,7 +65,7 @@ signOutButton :: forall t m. MonadWidget t m => m (Event t ()) signOutButton = do rec signOut <- Component.button $ ButtonIn - { Component._buttonIn_class = "signOut item" + { Component._buttonIn_class = R.constDyn "signOut item" , Component._buttonIn_content = Icon.signOut , Component._buttonIn_waiting = waiting } diff --git a/client/src/View/Payment/Constants.hs b/client/src/View/Payment/Constants.hs new file mode 100644 index 0000000..ac2320a --- /dev/null +++ b/client/src/View/Payment/Constants.hs @@ -0,0 +1,6 @@ +module View.Payment.Constants + ( paymentsPerPage + ) where + +paymentsPerPage :: Int +paymentsPerPage = 8 diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index cf3e115..f96cb8e 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -7,15 +7,17 @@ module View.Payment.Pages , PagesOut(..) ) where -import qualified Data.Text as T -import Reflex.Dom (Event, Dynamic, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Payment (..)) +import Common.Model (Payment (..)) + +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component import qualified Icon +import qualified View.Payment.Constants as Constants data PagesIn = PagesIn { _pagesIn_payments :: [Payment] @@ -26,26 +28,43 @@ data PagesOut t = PagesOut } widget :: forall t m. MonadWidget t m => PagesIn -> m (PagesOut t) -widget _ = do - currentPage <- R.divClass "pages" $ do - a <- page 1 Icon.doubleLeftBar - b <- page 1 Icon.doubleLeft - c <- page 1 (R.text . T.pack . show $ (1 :: Integer)) - d <- page 2 (R.text . T.pack . show $ (2 :: Integer)) - e <- page 3 (R.text . T.pack . show $ (3 :: Integer)) - f <- page 4 (R.text . T.pack . show $ (4 :: Integer)) - g <- page 5 (R.text . T.pack . show $ (5 :: Integer)) - h <- page 5 Icon.doubleRight - i <- page 5 Icon.doubleRightBar - R.holdDyn 1 $ R.leftmost [ a, b, c, d, e, f, g, h, i ] - return $ PagesOut - { _pagesOut_currentPage = currentPage - } - -page :: forall t m. MonadWidget t m => Int -> m () -> m (Event t Int) -page n content = - ((fmap (const n)) . _buttonOut_clic) <$> (Component.button $ ButtonIn - { _buttonIn_class = "page" +widget pagesIn = do + R.divClass "pages" $ do + rec + currentPage <- R.holdDyn 1 . R.leftmost $ [ firstPageClic, previousPageClic, pageClic, nextPageClic, lastPageClic ] + + firstPageClic <- pageButton (R.constDyn 0) (R.constDyn 1) Icon.doubleLeftBar + + previousPageClic <- pageButton (R.constDyn 0) (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft + + pageClic <- pageEvent <$> (R.simpleList (fmap (range maxPage) currentPage) $ \p -> + pageButton currentPage p (R.dynText $ fmap (T.pack . show) p)) + + nextPageClic <- pageButton (R.constDyn 0) (fmap (\x -> min (x + 1) maxPage) currentPage) Icon.doubleRight + + lastPageClic <- pageButton (R.constDyn 0) (R.constDyn maxPage) Icon.doubleRightBar + + return $ PagesOut + { _pagesOut_currentPage = currentPage + } + + where maxPage = ceiling $ (toRational . length . _pagesIn_payments $ pagesIn) / toRational Constants.paymentsPerPage + pageEvent = R.switchPromptlyDyn . fmap R.leftmost + +range :: Int -> Int -> [Int] +range maxPage currentPage = [start..end] + where sidePages = 2 + start = max 1 (currentPage - sidePages) + end = min maxPage (start + sidePages * 2) + +pageButton :: forall t m. MonadWidget t m => Dynamic t Int -> Dynamic t Int -> m () -> m (Event t Int) +pageButton currentPage page content = do + clic <- _buttonOut_clic <$> (Component.button $ ButtonIn + { _buttonIn_class = do + cp <- currentPage + p <- page + if cp == p then "page current" else "page" , _buttonIn_content = content , _buttonIn_waiting = R.never }) + return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 734511d..5c0b709 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -7,26 +7,27 @@ module View.Payment.Table , TableOut(..) ) where -import qualified Data.List as L -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (MonadWidget, Dynamic) -import qualified Reflex.Dom as R +import qualified Data.List as L +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Util.Text as T -import qualified Common.View.Format as Format +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Category (..), Init (..), Payment (..), + PaymentCategory (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Util.Text as T +import qualified Common.View.Format as Format import qualified Icon +import qualified View.Payment.Constants as Constants data TableIn t = TableIn - { _tableIn_init :: Init + { _tableIn_init :: Init , _tableIn_currentPage :: Dynamic t Int } @@ -34,12 +35,8 @@ data TableOut = TableOut { } -visiblePayments :: Int -visiblePayments = 8 - widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut widget tableIn = do - R.dynText (fmap (T.pack . show) . _tableIn_currentPage $ tableIn) _ <- R.divClass "table" $ R.divClass "lines" $ do R.divClass "header" $ do @@ -52,13 +49,20 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank let init = _tableIn_init tableIn + currentPage = _tableIn_currentPage tableIn payments = _init_payments init - paymentRange = fmap - (\p -> take visiblePayments . drop ((p - 1) * visiblePayments) . reverse . L.sortOn _payment_date $ payments) - (_tableIn_currentPage tableIn) + paymentRange = fmap (getPaymentRange payments) currentPage R.simpleList paymentRange (paymentRow init) return $ TableOut {} +getPaymentRange :: [Payment] -> Int -> [Payment] +getPaymentRange payments currentPage = + take Constants.paymentsPerPage + . drop ((currentPage - 1) * Constants.paymentsPerPage) + . reverse + . L.sortOn _payment_date + $ payments + paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () paymentRow init payment = R.divClass "row" $ do @@ -69,7 +73,7 @@ paymentRow init payment = R.divClass "cell user" $ R.dynText $ flip fmap user $ \mbUser -> case mbUser of Just u -> _user_name u - _ -> "" + _ -> "" let category = flip fmap payment $ \p -> findCategory (_init_categories init) diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 70c6b1f..1f5b900 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -49,7 +49,7 @@ view result = ] button <- Component.button $ ButtonIn - { _buttonIn_class = "" + { _buttonIn_class = R.constDyn "" , _buttonIn_content = R.text (Message.get Key.SignIn_Button) , _buttonIn_waiting = waiting } -- cgit v1.2.3 From 7194cddb28656c721342c2ef604f9f9fb0692960 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 00:20:25 +0100 Subject: Show payment count and partition - Also fixes exceedingPayer in back by using only punctual payments --- client/client.cabal | 9 +++-- client/src/Component/Button.hs | 2 -- client/src/Component/Input.hs | 2 -- client/src/Icon.hs | 2 -- client/src/Main.hs | 9 ++--- client/src/Util/List.hs | 13 +++++++ client/src/View/App.hs | 24 ++++++------- client/src/View/Header.hs | 26 ++++++-------- client/src/View/Payment.hs | 22 ++++++------ client/src/View/Payment/Constants.hs | 2 +- client/src/View/Payment/Header.hs | 70 ++++++++++++++++++++++++++++++++++++ client/src/View/Payment/Pages.hs | 8 ++--- client/src/View/Payment/Table.hs | 28 +++++++-------- client/src/View/SignIn.hs | 32 ++++++++--------- 14 files changed, 159 insertions(+), 90 deletions(-) create mode 100644 client/src/Util/List.hs create mode 100644 client/src/View/Payment/Header.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index ac74d9c..fdf764e 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -13,9 +13,12 @@ Executable client Ghc-options: -Wall -Werror Hs-source-dirs: src Default-language: Haskell2010 - Extensions: + + Default-extensions: ExistentialQuantification MultiParamTypeClasses + OverloadedStrings + RecursiveDo Build-depends: aeson @@ -32,10 +35,12 @@ Executable client Component.Button Component.Input Icon - Main + Util.List View.App View.Header View.Payment + View.Payment.Constants + View.Payment.Header View.Payment.Pages View.Payment.Table View.SignIn diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index c31cdc6..09c93cd 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Component.Button ( ButtonIn(..) , buttonInDefault diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index c3864b4..1923463 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Component.Input ( InputIn(..) , InputOut(..) diff --git a/client/src/Icon.hs b/client/src/Icon.hs index cd5a0b4..fbf5388 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Icon ( clone , delete diff --git a/client/src/Main.hs b/client/src/Main.hs index cbc881c..d55eefe 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -13,9 +13,8 @@ import JSDOM.Types (HTMLElement (..), JSM) import qualified JSDOM.Types as Dom import Prelude hiding (error, init) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (InitResult (InitEmpty)) +import qualified Common.Msg as Msg import qualified View.App as App @@ -27,7 +26,8 @@ main = do readInit :: JSM InitResult readInit = do document <- Dom.currentDocumentUnchecked - initNode <- Dom.getElementById document "init" + initNode <- Dom.getElementById document ("init" :: Dom.JSString) + case initNode of Just node -> do text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node) @@ -36,4 +36,5 @@ readInit = do Nothing -> initParseError _ -> return initParseError - where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) + + where initParseError = InitEmpty (Left $ Msg.get Msg.SignIn_ParseError) diff --git a/client/src/Util/List.hs b/client/src/Util/List.hs new file mode 100644 index 0000000..4e22ba8 --- /dev/null +++ b/client/src/Util/List.hs @@ -0,0 +1,13 @@ +module Util.List + ( groupBy + ) where + +import Control.Arrow ((&&&)) +import Data.Function (on) +import qualified Data.List as L + +groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])] +groupBy f = + map (f . head &&& id) + . L.groupBy ((==) `on` f) + . L.sortBy (compare `on` f) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 442fa3e..64ca303 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -1,22 +1,18 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.App ( widget ) where -import Prelude hiding (error, init) -import qualified Reflex.Dom as R +import Prelude hiding (error, init) +import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (InitResult (..)) +import Common.Model (InitResult (..)) +import qualified Common.Msg as Msg -import View.Header (HeaderIn (..)) -import qualified View.Header as Header -import View.Payment (PaymentIn (..)) -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn +import View.Header (HeaderIn (..)) +import qualified View.Header as Header +import View.Payment (PaymentIn (..)) +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = @@ -36,7 +32,7 @@ widget initResult = InitEmpty result -> SignIn.view result - signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess) + signOutContent = SignIn.view (Right . Just $ Msg.get Msg.SignIn_DisconnectSuccess) _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 7afd9bd..4c74383 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -1,25 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.Header ( view , HeaderIn(..) , HeaderOut(..) ) where -import qualified Data.Map as M -import Data.Time (NominalDiffTime) -import Prelude hiding (error, init) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Time (NominalDiffTime) +import Prelude hiding (error, init) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Init (..), InitResult (..), User (..)) -import qualified Common.Model as CM +import Common.Model (Init (..), InitResult (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg -import Component.Button (ButtonIn (..)) -import qualified Component.Button as Component +import Component.Button (ButtonIn (..)) +import qualified Component.Button as Component import qualified Icon data HeaderIn = HeaderIn @@ -35,7 +31,7 @@ view headerIn = R.el "header" $ do R.divClass "title" $ - R.text $ Message.get Key.App_Title + R.text $ Msg.get Msg.App_Title signOut <- nameSignOut $ _headerIn_initResult headerIn diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f70c8cd..934f720 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -1,21 +1,20 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.Payment ( widget , PaymentIn(..) , PaymentOut(..) ) where -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Init (..)) +import Common.Model (Init (..)) -import View.Payment.Pages (PagesIn (..), PagesOut (..)) -import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn (..)) -import qualified View.Payment.Table as Table +import View.Payment.Header (HeaderIn (..)) +import qualified View.Payment.Header as Header +import View.Payment.Pages (PagesIn (..), PagesOut (..)) +import qualified View.Payment.Pages as Pages +import View.Payment.Table (TableIn (..)) +import qualified View.Payment.Table as Table data PaymentIn = PaymentIn { _paymentIn_init :: Init @@ -29,6 +28,9 @@ widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut widget paymentIn = do R.divClass "payment" $ do rec + _ <- Header.widget $ HeaderIn + { _headerIn_init = _paymentIn_init $ paymentIn + } _ <- Table.widget $ TableIn { _tableIn_init = _paymentIn_init paymentIn , _tableIn_currentPage = _pagesOut_currentPage pagesOut diff --git a/client/src/View/Payment/Constants.hs b/client/src/View/Payment/Constants.hs index ac2320a..028e328 100644 --- a/client/src/View/Payment/Constants.hs +++ b/client/src/View/Payment/Constants.hs @@ -3,4 +3,4 @@ module View.Payment.Constants ) where paymentsPerPage :: Int -paymentsPerPage = 8 +paymentsPerPage = 7 diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs new file mode 100644 index 0000000..67b4eb4 --- /dev/null +++ b/client/src/View/Payment/Header.hs @@ -0,0 +1,70 @@ +module View.Payment.Header + ( widget + , HeaderIn(..) + , HeaderOut(..) + ) where + +import qualified Data.List as L hiding (groupBy) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Frequency (..), Init (..), + Payment (..), User (..), UserId) +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Util.List as L + +data HeaderIn t = HeaderIn + { _headerIn_init :: Init + } + +data HeaderOut = HeaderOut + { + } + +widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut +widget headerIn = + R.divClass "header" $ do + infos payments users currency + return $ HeaderOut {} + where init = _headerIn_init headerIn + payments = _init_payments init + users = _init_users init + currency = _init_currency init + +infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m () +infos payments users currency = + R.divClass "infos" $ do + R.elClass "span" "total" $ do + R.text . Msg.get $ Msg.Payment_Worth + (T.intercalate " " + [ (Format.number paymentCount) + , if paymentCount > 1 + then Msg.get Msg.Payment_Many + else Msg.get Msg.Payment_One + ]) + (Format.price currency total) + R.elClass "span" "partition" . R.text $ + T.intercalate ", " + . map (\(userId, userTotal) -> + Msg.get $ Msg.Payment_By + (fromMaybe "" . fmap _user_name . L.find ((==) userId . _user_id) $ users) + (Format.price currency userTotal) + ) + $ totalByUser + + where punctualPayments = filter ((==) Punctual . _payment_frequency) payments + paymentCount = length punctualPayments + total = sum . map _payment_cost $ punctualPayments + + totalByUser :: [(UserId, Int)] + totalByUser = + L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) + . map (\(u, xs) -> (u, sum . map snd $ xs)) + . L.groupBy fst + . map (\p -> (_payment_user p, _payment_cost p)) + $ punctualPayments diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index f96cb8e..81555ab 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.Payment.Pages ( widget , PagesIn(..) @@ -11,7 +8,7 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Payment (..)) +import Common.Model (Frequency (..), Payment (..)) import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component @@ -48,7 +45,8 @@ widget pagesIn = do { _pagesOut_currentPage = currentPage } - where maxPage = ceiling $ (toRational . length . _pagesIn_payments $ pagesIn) / toRational Constants.paymentsPerPage + where paymentCount = length . filter ((==) Punctual . _payment_frequency) . _pagesIn_payments $ pagesIn + maxPage = ceiling $ toRational paymentCount / toRational Constants.paymentsPerPage pageEvent = R.switchPromptlyDyn . fmap R.leftmost range :: Int -> Int -> [Int] diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 5c0b709..d8093a5 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.Payment.Table ( widget , TableIn(..) @@ -15,11 +12,11 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Category (..), Init (..), Payment (..), +import Common.Model (Category (..), Frequency (..), + Init (..), Payment (..), PaymentCategory (..), User (..)) import qualified Common.Model as CM +import qualified Common.Msg as Msg import qualified Common.Util.Text as T import qualified Common.View.Format as Format @@ -40,11 +37,11 @@ widget tableIn = do _ <- R.divClass "table" $ R.divClass "lines" $ do R.divClass "header" $ do - R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name - R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost - R.divClass "cell user" $ R.text $ Message.get Key.Payment_User - R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category - R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date + R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name + R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost + R.divClass "cell user" $ R.text $ Msg.get Msg.Payment_User + R.divClass "cell category" $ R.text $ Msg.get Msg.Payment_Category + R.divClass "cell date" $ R.text $ Msg.get Msg.Payment_Date R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank @@ -58,10 +55,11 @@ widget tableIn = do getPaymentRange :: [Payment] -> Int -> [Payment] getPaymentRange payments currentPage = take Constants.paymentsPerPage - . drop ((currentPage - 1) * Constants.paymentsPerPage) - . reverse - . L.sortOn _payment_date - $ payments + . drop ((currentPage - 1) * Constants.paymentsPerPage) + . reverse + . L.sortOn _payment_date + . filter ((==) Punctual . _payment_frequency) + $ payments paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () paymentRow init payment = diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 1f5b900..69596d8 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,25 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.SignIn ( view ) where -import qualified Data.Either as Either -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time (NominalDiffTime) -import Prelude hiding (error) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Either as Either +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) +import Prelude hiding (error) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (SignIn (SignIn)) +import Common.Model (SignIn (SignIn)) +import qualified Common.Msg as Msg -import Component (ButtonIn (..), ButtonOut (..), - InputIn (..), InputOut (..)) -import qualified Component as Component +import Component (ButtonIn (..), ButtonOut (..), InputIn (..), + InputOut (..)) +import qualified Component as Component view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () view result = @@ -27,7 +23,7 @@ view result = rec input <- Component.input $ InputIn { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder + , _inputIn_placeHolder = Msg.get Msg.SignIn_EmailPlaceholder } let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button @@ -50,7 +46,7 @@ view result = button <- Component.button $ ButtonIn { _buttonIn_class = R.constDyn "" - , _buttonIn_content = R.text (Message.get Key.SignIn_Button) + , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button) , _buttonIn_waiting = waiting } -- cgit v1.2.3 From bab2c30addf8aaed85675e2b7f7b15c97c426f74 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 15:00:07 +0100 Subject: Add exceeding payer block --- client/src/Component/Button.hs | 6 ---- client/src/Icon.hs | 4 +-- client/src/View/Payment.hs | 8 +++-- client/src/View/Payment/Header.hs | 66 ++++++++++++++++++++++++++++----------- 4 files changed, 55 insertions(+), 29 deletions(-) (limited to 'client') diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 09c93cd..754b903 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -48,9 +48,3 @@ button buttonIn = do return $ ButtonOut { _buttonOut_clic = R.domEvent R.Click e } - --- mergeAttr :: Map Text Text -> Map Text Text -> Map Text Text --- mergeAttr = M.unionWithKey $ \k a b -> --- if k == "class" --- then T.intercalate " " [ a, b ] --- else b diff --git a/client/src/Icon.hs b/client/src/Icon.hs index fbf5388..e04e2a8 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -58,8 +58,8 @@ loading = signOut :: forall t m. MonadWidget t m => m () signOut = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank + svgAttr "svg" (M.fromList [ ("width", "30"), ("height", "30"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1664 896q0 156-61 298t-164 245-245 164-298 61-298-61-245-164-164-245-61-298q0-182 80.5-343t226.5-270q43-32 95.5-25t83.5 50q32 42 24.5 94.5t-49.5 84.5q-98 74-151.5 181t-53.5 228q0 104 40.5 198.5t109.5 163.5 163.5 109.5 198.5 40.5 198.5-40.5 163.5-109.5 109.5-163.5 40.5-198.5q0-121-53.5-228t-151.5-181q-42-32-49.5-84.5t24.5-94.5q31-43 84-50t95 25q146 109 226.5 270t80.5 343zm-640-768v640q0 52-38 90t-90 38-90-38-38-90v-640q0-52 38-90t90-38 90 38 38 90z")]) $ R.blank svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 934f720..15892c4 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -4,6 +4,7 @@ module View.Payment , PaymentOut(..) ) where +import Prelude hiding (init) import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R @@ -29,13 +30,14 @@ widget paymentIn = do R.divClass "payment" $ do rec _ <- Header.widget $ HeaderIn - { _headerIn_init = _paymentIn_init $ paymentIn + { _headerIn_init = init } _ <- Table.widget $ TableIn - { _tableIn_init = _paymentIn_init paymentIn + { _tableIn_init = init , _tableIn_currentPage = _pagesOut_currentPage pagesOut } pagesOut <- Pages.widget $ PagesIn - { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn + { _pagesIn_payments = _init_payments init } return $ PaymentOut {} + where init = _paymentIn_init paymentIn diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 67b4eb4..3f2adc3 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -4,22 +4,29 @@ module View.Payment.Header , HeaderOut(..) ) where -import qualified Data.List as L hiding (groupBy) -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import Control.Monad (forM_) +import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L hiding (groupBy) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Time as Time +import Prelude hiding (init) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Currency, Frequency (..), Init (..), - Payment (..), User (..), UserId) -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format +import Common.Model (Currency, ExceedingPayer (..), + Frequency (..), Income (..), Init (..), + Payment (..), User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format -import qualified Util.List as L +import Component (ButtonIn (..)) +import qualified Component as Component +import qualified Util.List as L data HeaderIn t = HeaderIn - { _headerIn_init :: Init + { _headerIn_init :: Init } data HeaderOut = HeaderOut @@ -29,13 +36,37 @@ data HeaderOut = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut widget headerIn = R.divClass "header" $ do + payerAndAdd incomes payments users currency infos payments users currency return $ HeaderOut {} where init = _headerIn_init headerIn - payments = _init_payments init + incomes = _init_incomes init + payments = filter ((==) Punctual . _payment_frequency) (_init_payments init) users = _init_users init currency = _init_currency init +payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m () +payerAndAdd incomes payments users currency = do + time <- liftIO Time.getCurrentTime + R.divClass "payerAndAdd" $ do + R.divClass "exceedingPayers" $ + forM_ + (CM.getExceedingPayers time users incomes payments) + (\p -> + R.elClass "span" "exceedingPayer" $ do + R.elClass "span" "userName" $ + R.text . fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId p) users + R.elClass "span" "amount" $ do + R.text "+ " + R.text . Format.price currency $ _exceedingPayer_amount p + ) + _ <- Component.button $ ButtonIn + { _buttonIn_class = R.constDyn "addPayment" + , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add + , _buttonIn_waiting = R.never + } + return () + infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m () infos payments users currency = R.divClass "infos" $ do @@ -52,14 +83,13 @@ infos payments users currency = T.intercalate ", " . map (\(userId, userTotal) -> Msg.get $ Msg.Payment_By - (fromMaybe "" . fmap _user_name . L.find ((==) userId . _user_id) $ users) + (fromMaybe "" . fmap _user_name $ CM.findUser userId users) (Format.price currency userTotal) ) $ totalByUser - where punctualPayments = filter ((==) Punctual . _payment_frequency) payments - paymentCount = length punctualPayments - total = sum . map _payment_cost $ punctualPayments + where paymentCount = length payments + total = sum . map _payment_cost $ payments totalByUser :: [(UserId, Int)] totalByUser = @@ -67,4 +97,4 @@ infos payments users currency = . map (\(u, xs) -> (u, sum . map snd $ xs)) . L.groupBy fst . map (\p -> (_payment_user p, _payment_cost p)) - $ punctualPayments + $ payments -- cgit v1.2.3 From 49426740e8e0c59040f4f3721a658f225572582b Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 28 Nov 2017 09:11:19 +0100 Subject: Add search for payments --- client/src/Component/Input.hs | 57 ++++++++++++++++++++++++++++----------- client/src/Icon.hs | 6 +++++ client/src/View/Payment.hs | 26 +++++++++++++----- client/src/View/Payment/Header.hs | 25 ++++++++++++----- client/src/View/Payment/Pages.hs | 37 ++++++++++++++----------- client/src/View/Payment/Table.hs | 9 +++---- client/src/View/SignIn.hs | 2 +- 7 files changed, 112 insertions(+), 50 deletions(-) (limited to 'client') diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 1923463..7eec7d0 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -4,13 +4,19 @@ module Component.Input , input ) where -import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~), (=:)) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~)) +import qualified Reflex.Dom as R + +import Component.Button (ButtonIn (..), ButtonOut (..)) +import qualified Component.Button as Button +import qualified Icon data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_placeHolder :: Text + { _inputIn_reset :: Event t a + , _inputIn_label :: Text } data InputOut t = InputOut @@ -19,13 +25,34 @@ data InputOut t = InputOut } input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) -input inputIn = do - let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn) - let value = fmap (const "") (_inputIn_reset inputIn) - textInput <- R.textInput $ R.def & R.attributes .~ placeHolder - & R.setValue .~ value - let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput - return $ InputOut - { _inputOut_value = R._textInput_value textInput - , _inputOut_enter = enter - } +input inputIn = + R.divClass "textInput" $ do + rec + let resetValue = R.leftmost + [ fmap (const "") (_inputIn_reset inputIn) + , fmap (const "") (_buttonOut_clic reset) + ] + + attributes = R.ffor value (\v -> + if T.null v then M.empty else M.singleton "class" "filled") + + value = R._textInput_value textInput + + textInput <- R.textInput $ R.def + & R.attributes .~ attributes + & R.setValue .~ resetValue + + R.el "label" $ R.text (_inputIn_label inputIn) + + reset <- Button.button $ ButtonIn + { _buttonIn_class = R.constDyn "" + , _buttonIn_content = Icon.cross + , _buttonIn_waiting = R.never + } + + let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + + return $ InputOut + { _inputOut_value = value + , _inputOut_enter = enter + } diff --git a/client/src/Icon.hs b/client/src/Icon.hs index e04e2a8..555d928 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -1,5 +1,6 @@ module Icon ( clone + , cross , delete , edit , loading @@ -21,6 +22,11 @@ clone = svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank +cross :: forall t m. MonadWidget t m => m () +cross = + svgAttr "svg" (M.fromList [ ("width", "15"), ("height", "15"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1490 1322q0 40-28 68l-136 136q-28 28-68 28t-68-28l-294-294-294 294q-28 28-68 28t-68-28l-136-136q-28-28-28-68t28-68l294-294-294-294q-28-28-28-68t28-68l136-136q28-28 68-28t68 28l294 294 294-294q28-28 68-28t68 28l136 136q28 28 28 68t-28 68l-294 294 294 294q28 28 28 68z")]) $ R.blank + delete :: forall t m. MonadWidget t m => m () delete = svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 15892c4..8aa4d38 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -8,9 +8,10 @@ import Prelude hiding (init) import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init (..)) +import Common.Model (Frequency (..), Init (..), Payment (..)) +import Common.Util.Text as T -import View.Payment.Header (HeaderIn (..)) +import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages @@ -29,15 +30,26 @@ widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut widget paymentIn = do R.divClass "payment" $ do rec - _ <- Header.widget $ HeaderIn + let init = _paymentIn_init paymentIn + + filterPayment s p = search s (_payment_name p) && (_payment_frequency p == Punctual) + + payments = fmap + (\s -> filter (filterPayment s) (_init_payments init)) + (_headerOut_search header) + + header <- Header.widget $ HeaderIn { _headerIn_init = init } + _ <- Table.widget $ TableIn { _tableIn_init = init - , _tableIn_currentPage = _pagesOut_currentPage pagesOut + , _tableIn_currentPage = _pagesOut_currentPage pages + , _tableIn_payments = payments } - pagesOut <- Pages.widget $ PagesIn - { _pagesIn_payments = _init_payments init + + pages <- Pages.widget $ PagesIn + { _pagesIn_payments = payments } + return $ PaymentOut {} - where init = _paymentIn_init paymentIn diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 3f2adc3..f64f11d 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -8,10 +8,11 @@ import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) import qualified Data.List as L hiding (groupBy) import Data.Maybe (fromMaybe) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time as Time import Prelude hiding (init) -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Currency, ExceedingPayer (..), @@ -21,7 +22,8 @@ import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import Component (ButtonIn (..)) +import Component (ButtonIn (..), InputIn (..), + InputOut (..)) import qualified Component as Component import qualified Util.List as L @@ -29,16 +31,19 @@ data HeaderIn t = HeaderIn { _headerIn_init :: Init } -data HeaderOut = HeaderOut - { +data HeaderOut t = HeaderOut + { _headerOut_search :: Dynamic t Text } -widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut +widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do payerAndAdd incomes payments users currency + search <- searchLine infos payments users currency - return $ HeaderOut {} + return $ HeaderOut + { _headerOut_search = search + } where init = _headerIn_init headerIn incomes = _init_incomes init payments = filter ((==) Punctual . _payment_frequency) (_init_payments init) @@ -98,3 +103,11 @@ infos payments users currency = . L.groupBy fst . map (\p -> (_payment_user p, _payment_cost p)) $ payments + +searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text) +searchLine = + R.divClass "searchLine" $ + _inputOut_value <$> (Component.input $ InputIn + { _inputIn_reset = R.never + , _inputIn_label = Msg.get Msg.Search_Name + }) diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index 81555ab..dfd92c0 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Frequency (..), Payment (..)) +import Common.Model (Payment (..)) import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component @@ -16,52 +16,57 @@ import qualified Component as Component import qualified Icon import qualified View.Payment.Constants as Constants -data PagesIn = PagesIn - { _pagesIn_payments :: [Payment] +data PagesIn t = PagesIn + { _pagesIn_payments :: Dynamic t [Payment] } data PagesOut t = PagesOut { _pagesOut_currentPage :: Dynamic t Int } -widget :: forall t m. MonadWidget t m => PagesIn -> m (PagesOut t) +widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) widget pagesIn = do R.divClass "pages" $ do rec currentPage <- R.holdDyn 1 . R.leftmost $ [ firstPageClic, previousPageClic, pageClic, nextPageClic, lastPageClic ] - firstPageClic <- pageButton (R.constDyn 0) (R.constDyn 1) Icon.doubleLeftBar + firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar - previousPageClic <- pageButton (R.constDyn 0) (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft + previousPageClic <- pageButton noCurrentPage (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft - pageClic <- pageEvent <$> (R.simpleList (fmap (range maxPage) currentPage) $ \p -> - pageButton currentPage p (R.dynText $ fmap (T.pack . show) p)) + pageClic <- pageEvent <$> (R.simpleList (range <$> currentPage <*> maxPage) $ \p -> + pageButton (Just <$> currentPage) p (R.dynText $ fmap (T.pack . show) p)) - nextPageClic <- pageButton (R.constDyn 0) (fmap (\x -> min (x + 1) maxPage) currentPage) Icon.doubleRight + nextPageClic <- pageButton noCurrentPage ((\c m -> min (c + 1) m) <$> currentPage <*> maxPage) Icon.doubleRight - lastPageClic <- pageButton (R.constDyn 0) (R.constDyn maxPage) Icon.doubleRightBar + lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar return $ PagesOut { _pagesOut_currentPage = currentPage } - where paymentCount = length . filter ((==) Punctual . _payment_frequency) . _pagesIn_payments $ pagesIn - maxPage = ceiling $ toRational paymentCount / toRational Constants.paymentsPerPage + where maxPage = + R.ffor (_pagesIn_payments pagesIn) (\payments -> + ceiling $ toRational (length payments) / toRational Constants.paymentsPerPage + ) + pageEvent = R.switchPromptlyDyn . fmap R.leftmost + noCurrentPage = R.constDyn Nothing + range :: Int -> Int -> [Int] -range maxPage currentPage = [start..end] +range currentPage maxPage = [start..end] where sidePages = 2 - start = max 1 (currentPage - sidePages) + start = max 1 (min (currentPage - sidePages) (maxPage - sidePages * 2)) end = min maxPage (start + sidePages * 2) -pageButton :: forall t m. MonadWidget t m => Dynamic t Int -> Dynamic t Int -> m () -> m (Event t Int) +pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int) pageButton currentPage page content = do clic <- _buttonOut_clic <$> (Component.button $ ButtonIn { _buttonIn_class = do cp <- currentPage p <- page - if cp == p then "page current" else "page" + if cp == Just p then "page current" else "page" , _buttonIn_content = content , _buttonIn_waiting = R.never }) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index d8093a5..0c3b769 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -12,8 +12,7 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Category (..), Frequency (..), - Init (..), Payment (..), +import Common.Model (Category (..), Init (..), Payment (..), PaymentCategory (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg @@ -26,6 +25,7 @@ import qualified View.Payment.Constants as Constants data TableIn t = TableIn { _tableIn_init :: Init , _tableIn_currentPage :: Dynamic t Int + , _tableIn_payments :: Dynamic t [Payment] } data TableOut = TableOut @@ -47,8 +47,8 @@ widget tableIn = do R.divClass "cell" $ R.blank let init = _tableIn_init tableIn currentPage = _tableIn_currentPage tableIn - payments = _init_payments init - paymentRange = fmap (getPaymentRange payments) currentPage + payments = _tableIn_payments tableIn + paymentRange = getPaymentRange <$> payments <*> currentPage R.simpleList paymentRange (paymentRow init) return $ TableOut {} @@ -58,7 +58,6 @@ getPaymentRange payments currentPage = . drop ((currentPage - 1) * Constants.paymentsPerPage) . reverse . L.sortOn _payment_date - . filter ((==) Punctual . _payment_frequency) $ payments paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 69596d8..be6b152 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -23,7 +23,7 @@ view result = rec input <- Component.input $ InputIn { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_placeHolder = Msg.get Msg.SignIn_EmailPlaceholder + , _inputIn_label = Msg.get Msg.SignIn_EmailLabel } let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button -- cgit v1.2.3 From a4acc2e84158fa822f88a1d0bdddb470708b5809 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 3 Jan 2018 17:31:20 +0100 Subject: Modify weelky report and payment search interface - Add payment balance in weekly report - Show a message and hide pages when the search results in no results - Go to page 1 when the search is updated / erased --- client/client.cabal | 1 - client/src/Component/Input.hs | 2 +- client/src/Icon.hs | 8 ++--- client/src/Util/Dom.hs | 19 ++++++++++++ client/src/View/Payment.hs | 7 ++++- client/src/View/Payment/Constants.hs | 6 ---- client/src/View/Payment/Pages.hs | 51 +++++++++++++++++++------------ client/src/View/Payment/Table.hs | 59 +++++++++++++++++++++--------------- client/src/View/SignIn.hs | 4 +-- 9 files changed, 98 insertions(+), 59 deletions(-) create mode 100644 client/src/Util/Dom.hs delete mode 100644 client/src/View/Payment/Constants.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index fdf764e..02a7549 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -39,7 +39,6 @@ Executable client View.App View.Header View.Payment - View.Payment.Constants View.Payment.Header View.Payment.Pages View.Payment.Table diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 7eec7d0..24aac22 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -45,7 +45,7 @@ input inputIn = R.el "label" $ R.text (_inputIn_label inputIn) reset <- Button.button $ ButtonIn - { _buttonIn_class = R.constDyn "" + { _buttonIn_class = R.constDyn "reset" , _buttonIn_content = Icon.cross , _buttonIn_waiting = R.never } diff --git a/client/src/Icon.hs b/client/src/Icon.hs index 555d928..dae5e7f 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -29,8 +29,8 @@ cross = delete :: forall t m. MonadWidget t m => m () delete = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank + svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M704 1376v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm-544-992h448l-48-117q-7-9-17-11h-317q-10 2-17 11zm928 32v64q0 14-9 23t-23 9h-96v948q0 83-47 143.5t-113 60.5h-832q-66 0-113-58.5t-47-141.5v-952h-96q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h309l70-167q15-37 54-63t79-26h320q40 0 79 26t54 63l70 167h309q14 0 23 9t9 23z")]) $ R.blank doubleLeft :: forall t m. MonadWidget t m => m () doubleLeft = @@ -54,8 +54,8 @@ doubleRightBar = edit :: forall t m. MonadWidget t m => m () edit = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank + svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M491 1536l91-91-235-235-91 91v107h128v128h107zm523-928q0-22-22-22-10 0-17 7l-542 542q-7 7-7 17 0 22 22 22 10 0 17-7l542-542q7-7 7-17zm-54-192l416 416-832 832h-416v-416zm683 96q0 53-37 90l-166 166-416-416 166-165q36-38 90-38 53 0 91 38l235 234q37 39 37 91z")]) $ R.blank loading :: forall t m. MonadWidget t m => m () loading = diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs new file mode 100644 index 0000000..f3e9c88 --- /dev/null +++ b/client/src/Util/Dom.hs @@ -0,0 +1,19 @@ +module Util.Dom + ( divVisibleIf + , divClassVisibleIf + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a +divVisibleIf cond content = divClassVisibleIf cond "" content + +divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a +divClassVisibleIf cond className content = + R.elDynAttr + "div" + (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond) + content diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 8aa4d38..f4aaf5c 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -38,6 +38,8 @@ widget paymentIn = do (\s -> filter (filterPayment s) (_init_payments init)) (_headerOut_search header) + paymentsPerPage = 7 + header <- Header.widget $ HeaderIn { _headerIn_init = init } @@ -46,10 +48,13 @@ widget paymentIn = do { _tableIn_init = init , _tableIn_currentPage = _pagesOut_currentPage pages , _tableIn_payments = payments + , _tableIn_perPage = paymentsPerPage } pages <- Pages.widget $ PagesIn - { _pagesIn_payments = payments + { _pagesIn_total = length <$> payments + , _pagesIn_perPage = paymentsPerPage + , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_search header } return $ PaymentOut {} diff --git a/client/src/View/Payment/Constants.hs b/client/src/View/Payment/Constants.hs deleted file mode 100644 index 028e328..0000000 --- a/client/src/View/Payment/Constants.hs +++ /dev/null @@ -1,6 +0,0 @@ -module View.Payment.Constants - ( paymentsPerPage - ) where - -paymentsPerPage :: Int -paymentsPerPage = 7 diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index dfd92c0..55ceb9f 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -4,20 +4,20 @@ module View.Payment.Pages , PagesOut(..) ) where -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Payment (..)) - -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component import qualified Icon -import qualified View.Payment.Constants as Constants +import qualified Util.Dom as Dom data PagesIn t = PagesIn - { _pagesIn_payments :: Dynamic t [Payment] + { _pagesIn_total :: Dynamic t Int + , _pagesIn_perPage :: Int + , _pagesIn_reset :: Event t () } data PagesOut t = PagesOut @@ -26,9 +26,29 @@ data PagesOut t = PagesOut widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) widget pagesIn = do + currentPage <- Dom.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset + + return $ PagesOut + { _pagesOut_currentPage = currentPage + } + + where + total = _pagesIn_total pagesIn + perPage = _pagesIn_perPage pagesIn + reset = _pagesIn_reset pagesIn + +pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) +pageButtons total perPage reset = do R.divClass "pages" $ do rec - currentPage <- R.holdDyn 1 . R.leftmost $ [ firstPageClic, previousPageClic, pageClic, nextPageClic, lastPageClic ] + currentPage <- R.holdDyn 1 . R.leftmost $ + [ firstPageClic + , previousPageClic + , pageClic + , nextPageClic + , lastPageClic + , (const 1) <$> reset + ] firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar @@ -41,17 +61,10 @@ widget pagesIn = do lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar - return $ PagesOut - { _pagesOut_currentPage = currentPage - } - - where maxPage = - R.ffor (_pagesIn_payments pagesIn) (\payments -> - ceiling $ toRational (length payments) / toRational Constants.paymentsPerPage - ) + return currentPage + where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) pageEvent = R.switchPromptlyDyn . fmap R.leftmost - noCurrentPage = R.constDyn Nothing range :: Int -> Int -> [Int] diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 0c3b769..a49be5c 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -4,28 +4,29 @@ module View.Payment.Table , TableOut(..) ) where -import qualified Data.List as L -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.Util.Text as T -import qualified Common.View.Format as Format +import qualified Data.List as L +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Init (..), Payment (..), + PaymentCategory (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.Util.Text as T +import qualified Common.View.Format as Format import qualified Icon -import qualified View.Payment.Constants as Constants +import qualified Util.Dom as Dom data TableIn t = TableIn { _tableIn_init :: Init , _tableIn_currentPage :: Dynamic t Int , _tableIn_payments :: Dynamic t [Payment] + , _tableIn_perPage :: Int } data TableOut = TableOut @@ -34,7 +35,8 @@ data TableOut = TableOut widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut widget tableIn = do - _ <- R.divClass "table" $ + R.divClass "table" $ do + R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name @@ -45,17 +47,24 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - let init = _tableIn_init tableIn - currentPage = _tableIn_currentPage tableIn - payments = _tableIn_payments tableIn - paymentRange = getPaymentRange <$> payments <*> currentPage - R.simpleList paymentRange (paymentRow init) + _ <- R.simpleList paymentRange (paymentRow init) + return () + + Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ + R.text $ Msg.get Msg.Payment_Empty + return $ TableOut {} -getPaymentRange :: [Payment] -> Int -> [Payment] -getPaymentRange payments currentPage = - take Constants.paymentsPerPage - . drop ((currentPage - 1) * Constants.paymentsPerPage) + where + init = _tableIn_init tableIn + currentPage = _tableIn_currentPage tableIn + payments = _tableIn_payments tableIn + paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage + +getPaymentRange :: Int -> [Payment] -> Int -> [Payment] +getPaymentRange perPage payments currentPage = + take perPage + . drop ((currentPage - 1) * perPage) . reverse . L.sortOn _payment_date $ payments diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index be6b152..89be737 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -45,7 +45,7 @@ view result = ] button <- Component.button $ ButtonIn - { _buttonIn_class = R.constDyn "" + { _buttonIn_class = R.constDyn "validate" , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button) , _buttonIn_waiting = waiting } @@ -57,7 +57,7 @@ view result = askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text)) askSignIn email = fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email + where xhrRequest = fmap (R.postJson "/askSignIn" . SignIn) email getResult response = case R._xhrResponse_responseText response of Just key -> -- cgit v1.2.3 From ab17b6339d16970c3845ec4f153bfeed89eae728 Mon Sep 17 00:00:00 2001 From: Joris Date: Fri, 5 Jan 2018 14:45:47 +0100 Subject: Add modal component --- client/client.cabal | 1 + client/src/Component.hs | 1 + client/src/Component/Button.hs | 4 +- client/src/Component/Modal.hs | 38 +++++++++++ client/src/View/Payment.hs | 18 ++---- client/src/View/Payment/Header.hs | 130 +++++++++++++++++++++++--------------- 6 files changed, 127 insertions(+), 65 deletions(-) create mode 100644 client/src/Component/Modal.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 02a7549..1064e7d 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -34,6 +34,7 @@ Executable client other-modules: Component.Button Component.Input + Component.Modal Icon Util.List View.App diff --git a/client/src/Component.hs b/client/src/Component.hs index 4c9541b..dea384e 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -2,3 +2,4 @@ module Component (module X) where import Component.Button as X import Component.Input as X +import Component.Modal as X diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 754b903..3ee9561 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -1,8 +1,8 @@ module Component.Button ( ButtonIn(..) - , buttonInDefault , ButtonOut(..) , button + , buttonInDefault ) where import qualified Data.Map as M @@ -19,7 +19,7 @@ data ButtonIn t m = ButtonIn , _buttonIn_waiting :: Event t Bool } -buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m +buttonInDefault :: forall t m. (MonadWidget t m) => ButtonIn t m buttonInDefault = ButtonIn { _buttonIn_class = R.constDyn "" , _buttonIn_content = R.blank diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs new file mode 100644 index 0000000..bfb5e02 --- /dev/null +++ b/client/src/Component/Modal.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Component.Modal + ( ModalIn(..) + , ModalOut(..) + , modal + ) where + +import qualified Data.Map as M +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +data ModalIn t m = ModalIn + { _modalIn_show :: Event t () + , _modalIn_content :: m () + } + +data ModalOut = ModalOut {} + +modal :: forall t m. MonadWidget t m => ModalIn t m -> m ModalOut +modal modalIn = do + rec + showModal <- R.holdDyn False $ R.leftmost + [ True <$ _modalIn_show modalIn + , False <$ curtainClick + ] + + let attr = flip fmap showModal (\s -> M.fromList $ + [ ("style", if s then "display:block" else "display:none") + , ("class", "modal") + ]) + + curtainClick <- R.elDynAttr "div" attr $ do + (curtain, _) <- R.elAttr' "div" (M.singleton "class" "curtain") $ R.blank + R.divClass "content" $ _modalIn_content modalIn + return $ R.domEvent R.Click curtain + + return $ ModalOut {} diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f4aaf5c..42da8fb 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -8,8 +8,7 @@ import Prelude hiding (init) import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Frequency (..), Init (..), Payment (..)) -import Common.Util.Text as T +import Common.Model (Init (..)) import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header @@ -31,13 +30,6 @@ widget paymentIn = do R.divClass "payment" $ do rec let init = _paymentIn_init paymentIn - - filterPayment s p = search s (_payment_name p) && (_payment_frequency p == Punctual) - - payments = fmap - (\s -> filter (filterPayment s) (_init_payments init)) - (_headerOut_search header) - paymentsPerPage = 7 header <- Header.widget $ HeaderIn @@ -47,14 +39,14 @@ widget paymentIn = do _ <- Table.widget $ TableIn { _tableIn_init = init , _tableIn_currentPage = _pagesOut_currentPage pages - , _tableIn_payments = payments + , _tableIn_payments = _headerOut_searchPayments header , _tableIn_perPage = paymentsPerPage } pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> payments + { _pagesIn_total = length <$> _headerOut_searchPayments header , _pagesIn_perPage = paymentsPerPage - , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_search header + , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_searchName header } - return $ PaymentOut {} + pure $ PaymentOut {} diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index f64f11d..a694136 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -7,23 +7,26 @@ module View.Payment.Header import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) import qualified Data.List as L hiding (groupBy) +import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time as Time import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget) +import Reflex.Dom (Dynamic, MonadWidget, Reflex) import qualified Reflex.Dom as R import Common.Model (Currency, ExceedingPayer (..), Frequency (..), Income (..), Init (..), - Payment (..), User (..), UserId) + Payment (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg +import qualified Common.Util.Text as T import qualified Common.View.Format as Format -import Component (ButtonIn (..), InputIn (..), - InputOut (..)) +import Component (ButtonIn (..), ButtonOut (..), + InputIn (..), InputOut (..), + ModalIn (..)) import qualified Component as Component import qualified Util.List as L @@ -32,23 +35,37 @@ data HeaderIn t = HeaderIn } data HeaderOut t = HeaderOut - { _headerOut_search :: Dynamic t Text + { _headerOut_searchName :: Dynamic t Text + , _headerOut_searchPayments :: Dynamic t [Payment] } widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - payerAndAdd incomes payments users currency - search <- searchLine - infos payments users currency + payerAndAdd incomes punctualPayments users currency + (searchName, searchFrequency) <- searchLine + let searchPayments = getSearchPayments searchName searchFrequency payments + infos searchPayments users currency return $ HeaderOut - { _headerOut_search = search + { _headerOut_searchName = searchName + , _headerOut_searchPayments = searchPayments } - where init = _headerIn_init headerIn - incomes = _init_incomes init - payments = filter ((==) Punctual . _payment_frequency) (_init_payments init) - users = _init_users init - currency = _init_currency init + where + init = _headerIn_init headerIn + incomes = _init_incomes init + payments = _init_payments init + punctualPayments = filter ((==) Punctual . _payment_frequency) payments + users = _init_users init + currency = _init_currency init + +getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment] +getSearchPayments name frequency payments = do + n <- name + f <- frequency + pure $ flip filter payments (\p -> + ( T.search n (_payment_name p) + && (_payment_frequency p == f) + )) payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m () payerAndAdd incomes payments users currency = do @@ -65,49 +82,62 @@ payerAndAdd incomes payments users currency = do R.text "+ " R.text . Format.price currency $ _exceedingPayer_amount p ) - _ <- Component.button $ ButtonIn + addPayment <- _buttonOut_clic <$> (Component.button $ ButtonIn { _buttonIn_class = R.constDyn "addPayment" , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add , _buttonIn_waiting = R.never + }) + _ <- Component.modal $ ModalIn + { _modalIn_show = addPayment + , _modalIn_content = R.el "h1" $ R.text "Ajouter un paiement" } return () -infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m () +searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency) +searchLine = do + R.divClass "searchLine" $ do + searchName <- _inputOut_value <$> (Component.input $ InputIn + { _inputIn_reset = R.never + , _inputIn_label = Msg.get Msg.Search_Name + }) + + let frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + searchFrequency <- R._dropdown_value <$> + R.dropdown Punctual (R.constDyn frequencies) R.def + + return (searchName, searchFrequency) + +infos :: forall t m. MonadWidget t m => Dynamic t [Payment] -> [User] -> Currency -> m () infos payments users currency = R.divClass "infos" $ do - R.elClass "span" "total" $ do - R.text . Msg.get $ Msg.Payment_Worth - (T.intercalate " " - [ (Format.number paymentCount) - , if paymentCount > 1 - then Msg.get Msg.Payment_Many - else Msg.get Msg.Payment_One - ]) - (Format.price currency total) - R.elClass "span" "partition" . R.text $ - T.intercalate ", " - . map (\(userId, userTotal) -> - Msg.get $ Msg.Payment_By - (fromMaybe "" . fmap _user_name $ CM.findUser userId users) - (Format.price currency userTotal) - ) - $ totalByUser - where paymentCount = length payments - total = sum . map _payment_cost $ payments - - totalByUser :: [(UserId, Int)] - totalByUser = - L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) - . map (\(u, xs) -> (u, sum . map snd $ xs)) - . L.groupBy fst - . map (\p -> (_payment_user p, _payment_cost p)) - $ payments + R.elClass "span" "total" $ do + R.dynText $ do + ps <- payments + let paymentCount = length ps + total = sum . map _payment_cost $ ps + pure . Msg.get $ Msg.Payment_Worth + (T.intercalate " " + [ (Format.number paymentCount) + , if paymentCount > 1 + then Msg.get Msg.Payment_Many + else Msg.get Msg.Payment_One + ]) + (Format.price currency total) -searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text) -searchLine = - R.divClass "searchLine" $ - _inputOut_value <$> (Component.input $ InputIn - { _inputIn_reset = R.never - , _inputIn_label = Msg.get Msg.Search_Name - }) + R.elClass "span" "partition" . R.dynText $ do + ps <- payments + let totalByUser = + L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) + . map (\(u, xs) -> (u, sum . map snd $ xs)) + . L.groupBy fst + . map (\p -> (_payment_user p, _payment_cost p)) + $ ps + pure . T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) -> + Msg.get $ Msg.Payment_By + (fromMaybe "" . fmap _user_name $ CM.findUser userId users) + (Format.price currency userTotal) -- cgit v1.2.3 From 33b85b7f12798f5762d940ed5c30f775cdd7b751 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 28 Jan 2018 12:13:09 +0100 Subject: WIP --- client/client.cabal | 7 +++ client/src/Component.hs | 2 + client/src/Component/Button.hs | 41 ++++++++++----- client/src/Component/Form.hs | 12 +++++ client/src/Component/Input.hs | 27 +++++++--- client/src/Component/Modal.hs | 24 +++++---- client/src/Component/Select.hs | 32 ++++++++++++ client/src/Main.hs | 4 +- client/src/Util/Ajax.hs | 20 ++++++++ client/src/Util/WaitFor.hs | 18 +++++++ client/src/View/App.hs | 8 +-- client/src/View/Header.hs | 13 +++-- client/src/View/Payment/Add.hs | 104 ++++++++++++++++++++++++++++++++++++++ client/src/View/Payment/Delete.hs | 51 +++++++++++++++++++ client/src/View/Payment/Header.hs | 33 +++++++----- client/src/View/Payment/Pages.hs | 2 + client/src/View/Payment/Table.hs | 48 +++++++++++------- client/src/View/SignIn.hs | 98 +++++++++++++++-------------------- 18 files changed, 417 insertions(+), 127 deletions(-) create mode 100644 client/src/Component/Form.hs create mode 100644 client/src/Component/Select.hs create mode 100644 client/src/Util/Ajax.hs create mode 100644 client/src/Util/WaitFor.hs create mode 100644 client/src/View/Payment/Add.hs create mode 100644 client/src/View/Payment/Delete.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 1064e7d..0aec05f 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -33,13 +33,20 @@ Executable client other-modules: Component.Button + Component.Form Component.Input Component.Modal + Component.Select Icon + Util.Ajax + Util.Dom Util.List + Util.WaitFor View.App View.Header View.Payment + View.Payment.Add + View.Payment.Delete View.Payment.Header View.Payment.Pages View.Payment.Table diff --git a/client/src/Component.hs b/client/src/Component.hs index dea384e..7b87a75 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -1,5 +1,7 @@ module Component (module X) where import Component.Button as X +import Component.Form as X import Component.Input as X import Component.Modal as X +import Component.Select as X diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 3ee9561..bf604f1 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -2,10 +2,11 @@ module Component.Button ( ButtonIn(..) , ButtonOut(..) , button - , buttonInDefault + , defaultButtonIn ) where import qualified Data.Map as M +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) @@ -14,22 +15,36 @@ import qualified Reflex.Dom as R import qualified Icon data ButtonIn t m = ButtonIn - { _buttonIn_class :: Dynamic t Text - , _buttonIn_content :: m () - , _buttonIn_waiting :: Event t Bool + { _buttonIn_class :: Dynamic t Text + , _buttonIn_content :: m () + , _buttonIn_waiting :: Event t Bool + , _buttonIn_tabIndex :: Maybe Int + , _buttonIn_submit :: Bool } -buttonInDefault :: forall t m. (MonadWidget t m) => ButtonIn t m -buttonInDefault = ButtonIn - { _buttonIn_class = R.constDyn "" - , _buttonIn_content = R.blank - , _buttonIn_waiting = R.never +defaultButtonIn :: MonadWidget t m => m () -> ButtonIn t m +defaultButtonIn content = ButtonIn + { _buttonIn_class = R.constDyn "" + , _buttonIn_content = content + , _buttonIn_waiting = R.never + , _buttonIn_tabIndex = Nothing + , _buttonIn_submit = False } +-- defaultButtonIn :: MonadWidget t m => ButtonIn t m +-- defaultButtonIn = ButtonIn +-- { _buttonIn_class = R.constDyn "" +-- , _buttonIn_content = R.blank +-- , _buttonIn_waiting = R.never +-- , _buttonIn_tabIndex = Nothing +-- , _buttonIn_submit = False +-- } + data ButtonOut t = ButtonOut { _buttonOut_clic :: Event t () } + button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) button buttonIn = do dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn @@ -37,9 +52,11 @@ button buttonIn = do let attr = do buttonClass <- _buttonIn_class buttonIn waiting <- dynWaiting - return $ if waiting - then M.fromList [("type", "button"), ("class", T.intercalate " " [ buttonClass, "waiting" ])] - else M.fromList [("type", "button"), ("class", buttonClass)] + return . M.fromList . catMaybes $ + [ Just ("type", if _buttonIn_submit buttonIn then "submit" else "button") + , (\i -> ("tabindex", T.pack . show $ i)) <$> _buttonIn_tabIndex buttonIn + , Just ("class", T.intercalate " " [ buttonClass, if waiting then "waiting" else "" ]) + ] (e, _) <- R.elDynAttr' "button" attr $ do Icon.loading diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs new file mode 100644 index 0000000..0a89c6e --- /dev/null +++ b/client/src/Component/Form.hs @@ -0,0 +1,12 @@ +module Component.Form + ( form + ) where + +import qualified Data.Map as M +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +form :: forall t m a. (MonadWidget t m) => m a -> m a +form content = + R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $ + content diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 24aac22..92f8ec9 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -2,12 +2,14 @@ module Component.Input ( InputIn(..) , InputOut(..) , input + , defaultInputIn ) where import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~)) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex, (&), + (.~)) import qualified Reflex.Dom as R import Component.Button (ButtonIn (..), ButtonOut (..)) @@ -15,8 +17,16 @@ import qualified Component.Button as Button import qualified Icon data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_label :: Text + { _inputIn_reset :: Event t a + , _inputIn_label :: Text + , _inputIn_initialValue :: Text + } + +defaultInputIn :: (Reflex t) => InputIn t a b +defaultInputIn = InputIn + { _inputIn_reset = R.never + , _inputIn_label = "" + , _inputIn_initialValue = "" } data InputOut t = InputOut @@ -41,14 +51,15 @@ input inputIn = textInput <- R.textInput $ R.def & R.attributes .~ attributes & R.setValue .~ resetValue + & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) R.el "label" $ R.text (_inputIn_label inputIn) - reset <- Button.button $ ButtonIn - { _buttonIn_class = R.constDyn "reset" - , _buttonIn_content = Icon.cross - , _buttonIn_waiting = R.never - } + reset <- Button.button $ + (Button.defaultButtonIn Icon.cross) + { _buttonIn_class = R.constDyn "reset" + , _buttonIn_tabIndex = Just (-1) + } let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index bfb5e02..1d70c90 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -10,18 +10,22 @@ import qualified Data.Map as M import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R -data ModalIn t m = ModalIn +data ModalIn t m a = ModalIn { _modalIn_show :: Event t () - , _modalIn_content :: m () + , _modalIn_hide :: Event t () + , _modalIn_content :: m a } -data ModalOut = ModalOut {} +data ModalOut a = ModalOut + { _modalOut_content :: a + } -modal :: forall t m. MonadWidget t m => ModalIn t m -> m ModalOut +modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut a) modal modalIn = do rec showModal <- R.holdDyn False $ R.leftmost [ True <$ _modalIn_show modalIn + , False <$ _modalIn_hide modalIn , False <$ curtainClick ] @@ -30,9 +34,11 @@ modal modalIn = do , ("class", "modal") ]) - curtainClick <- R.elDynAttr "div" attr $ do - (curtain, _) <- R.elAttr' "div" (M.singleton "class" "curtain") $ R.blank - R.divClass "content" $ _modalIn_content modalIn - return $ R.domEvent R.Click curtain + (curtainClick, content) <- R.elDynAttr "div" attr $ do + (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank + cont <- R.divClass "modalContent" $ _modalIn_content modalIn + return (R.domEvent R.Click curtain, cont) - return $ ModalOut {} + return $ ModalOut + { _modalOut_content = content + } diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs new file mode 100644 index 0000000..876548e --- /dev/null +++ b/client/src/Component/Select.hs @@ -0,0 +1,32 @@ +module Component.Select + ( SelectIn(..) + , SelectOut(..) + , select + ) where + +import Data.Map (Map) +import Data.Text (Text) +import Reflex.Dom (Dynamic, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +data (Reflex t) => SelectIn t a = SelectIn + { _selectIn_label :: Text + , _selectIn_initialValue :: a + , _selectIn_values :: Dynamic t (Map a Text) + } + +data SelectOut t a = SelectOut + { _selectOut_value :: Dynamic t a + } + +select :: forall t m a. (Ord a) => MonadWidget t m => SelectIn t a -> m (SelectOut t a) +select selectIn = + R.divClass "selectInput" $ do + R.el "label" $ R.text (_selectIn_label selectIn) + + value <- R._dropdown_value <$> + R.dropdown (_selectIn_initialValue selectIn) (_selectIn_values selectIn) R.def + + return SelectOut + { _selectOut_value = value + } diff --git a/client/src/Main.hs b/client/src/Main.hs index d55eefe..6c048c6 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -13,7 +13,7 @@ import JSDOM.Types (HTMLElement (..), JSM) import qualified JSDOM.Types as Dom import Prelude hiding (error, init) -import Common.Model (InitResult (InitEmpty)) +import Common.Model (InitResult (InitError)) import qualified Common.Msg as Msg import qualified View.App as App @@ -37,4 +37,4 @@ readInit = do _ -> return initParseError - where initParseError = InitEmpty (Left $ Msg.get Msg.SignIn_ParseError) + where initParseError = InitError $ Msg.get Msg.SignIn_ParseError diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs new file mode 100644 index 0000000..1e8e4c7 --- /dev/null +++ b/client/src/Util/Ajax.hs @@ -0,0 +1,20 @@ +module Util.Ajax + ( post + ) where + +import Data.Aeson (ToJSON) +import Data.Text (Text) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +post :: forall t m a. (MonadWidget t m, ToJSON a) => Text -> Event t a -> m (Event t (Either Text Text)) +post url input = + fmap getResult <$> R.performRequestAsync xhrRequest + where xhrRequest = R.postJson url <$> input + getResult response = + case R._xhrResponse_responseText response of + Just responseText -> + if R._xhrResponse_status response == 200 + then Right responseText + else Left responseText + _ -> Left "NoKey" diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs new file mode 100644 index 0000000..0175c95 --- /dev/null +++ b/client/src/Util/WaitFor.hs @@ -0,0 +1,18 @@ +module Util.WaitFor + ( waitFor + ) where + +import Data.Time (NominalDiffTime) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +waitFor + :: forall t m a b. MonadWidget t m + => (Event t a -> m (Event t b)) + -> Event t () + -> Dynamic t a + -> m (Event t b, Event t Bool) +waitFor op start input = do + result <- op (R.tagPromptlyDyn input start) >>= R.debounce (0.5 :: NominalDiffTime) + let waiting = R.leftmost [ const True <$> start , const False <$> result ] + return (result, waiting) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 64ca303..9aa6c57 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -29,10 +29,12 @@ widget initResult = { _paymentIn_init = initSuccess } return () - InitEmpty result -> - SignIn.view result + InitEmpty -> + SignIn.view SignIn.EmptyMessage + InitError error -> + SignIn.view (SignIn.ErrorMessage error) - signOutContent = SignIn.view (Right . Just $ Msg.get Msg.SignIn_DisconnectSuccess) + signOutContent = SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess) _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 4c74383..8f1fb78 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -13,9 +13,8 @@ import qualified Reflex.Dom as R import Common.Model (Init (..), InitResult (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg - +import qualified Component as Component import Component.Button (ButtonIn (..)) -import qualified Component.Button as Component import qualified Icon data HeaderIn = HeaderIn @@ -60,11 +59,11 @@ nameSignOut initResult = case initResult of signOutButton :: forall t m. MonadWidget t m => m (Event t ()) signOutButton = do rec - signOut <- Component.button $ ButtonIn - { Component._buttonIn_class = R.constDyn "signOut item" - , Component._buttonIn_content = Icon.signOut - , Component._buttonIn_waiting = waiting - } + signOut <- Component.button $ + (Component.defaultButtonIn Icon.signOut) + { _buttonIn_class = R.constDyn "signOut item" + , _buttonIn_waiting = waiting + } let signOutClic = Component._buttonOut_clic signOut waiting = R.leftmost [ fmap (const True) signOutClic diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs new file mode 100644 index 0000000..2eaec0f --- /dev/null +++ b/client/src/View/Payment/Add.hs @@ -0,0 +1,104 @@ +module View.Payment.Add + ( view + , AddIn(..) + , AddOut(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import qualified Data.Time.Clock as Time +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R +import qualified Text.Read as T + +import Common.Model (Category (..), CreatePayment (..), + Frequency (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as Time +import qualified Common.View.Format as Format +import Component (ButtonIn (..), InputIn (..), + InputOut (..), SelectIn (..), + SelectOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.WaitFor as Util + +data AddIn = AddIn + { _addIn_categories :: [Category] + } + +data AddOut t = AddOut + { _addOut_cancel :: Event t () + } + +view :: forall t m. MonadWidget t m => AddIn -> m (AddOut t) +view addIn = do + R.divClass "add" $ do + R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add + + R.divClass "addContent" $ do + name <- _inputOut_value <$> (Component.input $ + Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) + + cost <- _inputOut_value <$> (Component.input $ + Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) + + currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + + date <- _inputOut_value <$> (Component.input $ + Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Cost + , _inputIn_initialValue = Format.shortDay currentDay + }) + + frequency <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Frequency + , _selectIn_initialValue = Punctual + , _selectIn_values = R.constDyn frequencies + }) + + category <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Category + , _selectIn_initialValue = 0 + , _selectIn_values = R.constDyn categories + }) + + let payment = CreatePayment + <$> name + <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost + <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date + <*> category + <*> frequency + + cancel <- R.divClass "buttons" $ do + rec + validate <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { _buttonIn_class = R.constDyn "confirm" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + }) + + (_, waiting) <- Util.waitFor + (Ajax.post "/payment") + validate + payment + + Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + return AddOut + { _addOut_cancel = cancel + } + + where + frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + categories = M.fromList . flip map (_addIn_categories addIn) $ \c -> + (_category_id c, _category_name c) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs new file mode 100644 index 0000000..a1be16d --- /dev/null +++ b/client/src/View/Payment/Delete.hs @@ -0,0 +1,51 @@ +module View.Payment.Delete + ( view + , DeleteIn(..) + , DeleteOut(..) + ) where + +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Msg as Msg +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component +-- import qualified Util.Ajax as Ajax +-- import qualified Util.WaitFor as Util + +data DeleteIn = DeleteIn + {} + +data DeleteOut t = DeleteOut + { _deleteOut_cancel :: Event t () + } + +view :: forall t m. MonadWidget t m => DeleteIn -> m (DeleteOut t) +view _ = + R.divClass "delete" $ do + R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm + + R.divClass "deleteContent" $ do + + cancel <- R.divClass "buttons" $ do + rec + _ <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { _buttonIn_class = R.constDyn "confirm" + , _buttonIn_submit = True + }) + + -- (_, waiting) <- Util.waitFor + -- (Ajax.post "/payment") + -- validate + -- payment + + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + return cancel + + return DeleteOut + { _deleteOut_cancel = cancel + } diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index a694136..d01dec6 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -16,9 +16,10 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Currency, ExceedingPayer (..), - Frequency (..), Income (..), Init (..), - Payment (..), User (..)) +import Common.Model (Category, Currency, + ExceedingPayer (..), Frequency (..), + Income (..), Init (..), Payment (..), + User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.Util.Text as T @@ -26,9 +27,11 @@ import qualified Common.View.Format as Format import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..), - ModalIn (..)) + ModalIn (..), ModalOut (..)) import qualified Component as Component import qualified Util.List as L +import View.Payment.Add (AddIn (..), AddOut (..)) +import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn { _headerIn_init :: Init @@ -42,7 +45,7 @@ data HeaderOut t = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - payerAndAdd incomes punctualPayments users currency + payerAndAdd incomes punctualPayments users categories currency (searchName, searchFrequency) <- searchLine let searchPayments = getSearchPayments searchName searchFrequency payments infos searchPayments users currency @@ -56,6 +59,7 @@ widget headerIn = payments = _init_payments init punctualPayments = filter ((==) Punctual . _payment_frequency) payments users = _init_users init + categories = _init_categories init currency = _init_currency init getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment] @@ -63,12 +67,12 @@ getSearchPayments name frequency payments = do n <- name f <- frequency pure $ flip filter payments (\p -> - ( T.search n (_payment_name p) + ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) && (_payment_frequency p == f) )) -payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m () -payerAndAdd incomes payments users currency = do +payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> [Category] -> Currency -> m () +payerAndAdd incomes payments users categories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do R.divClass "exceedingPayers" $ @@ -86,11 +90,15 @@ payerAndAdd incomes payments users currency = do { _buttonIn_class = R.constDyn "addPayment" , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add , _buttonIn_waiting = R.never + , _buttonIn_tabIndex = Nothing + , _buttonIn_submit = False }) - _ <- Component.modal $ ModalIn - { _modalIn_show = addPayment - , _modalIn_content = R.el "h1" $ R.text "Ajouter un paiement" - } + rec + modalOut <- Component.modal $ ModalIn + { _modalIn_show = addPayment + , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut + , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories } + } return () searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency) @@ -99,6 +107,7 @@ searchLine = do searchName <- _inputOut_value <$> (Component.input $ InputIn { _inputIn_reset = R.never , _inputIn_label = Msg.get Msg.Search_Name + , _inputIn_initialValue = "" }) let frequencies = M.fromList diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index 55ceb9f..d14b640 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -82,5 +82,7 @@ pageButton currentPage page content = do if cp == Just p then "page current" else "page" , _buttonIn_content = content , _buttonIn_waiting = R.never + , _buttonIn_tabIndex = Nothing + , _buttonIn_submit = False }) return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index a49be5c..23d7225 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -4,23 +4,28 @@ module View.Payment.Table , TableOut(..) ) where -import qualified Data.List as L -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.Util.Text as T -import qualified Common.View.Format as Format +import qualified Data.List as L +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Init (..), Payment (..), + PaymentCategory (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.Util.Text as T +import qualified Common.View.Format as Format +import Component (ButtonIn (..), ButtonOut (..), + ModalIn (..), ModalOut (..)) +import qualified Component as Component +import View.Payment.Delete (DeleteIn (..), DeleteOut (..)) +import qualified View.Payment.Delete as Delete import qualified Icon -import qualified Util.Dom as Dom +import qualified Util.Dom as Dom data TableIn t = TableIn { _tableIn_init :: Init @@ -105,8 +110,17 @@ paymentRow init payment = M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")] R.elDynAttr "div" modifyAttrs $ R.el "button" $ Icon.edit - R.elDynAttr "div" modifyAttrs $ - R.el "button" $ Icon.delete + deletePayment <- R.elDynAttr "div" modifyAttrs $ + _buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn Icon.delete) + { _buttonIn_class = R.constDyn "deletePayment" }) + rec + modalOut <- Component.modal $ ModalIn + { _modalIn_show = deletePayment + , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut + , _modalIn_content = Delete.view (DeleteIn {}) + } + return () findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 89be737..912aea2 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,11 +1,10 @@ module View.SignIn - ( view + ( SignInMessage (..) + , view ) where import qualified Data.Either as Either -import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Time (NominalDiffTime) import Prelude hiding (error) import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R @@ -16,62 +15,47 @@ import qualified Common.Msg as Msg import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..)) import qualified Component as Component - -view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () -view result = - R.divClass "signIn" $ do - rec - input <- Component.input $ InputIn - { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_label = Msg.get Msg.SignIn_EmailLabel - } - - let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button - - dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $ - [ fmap (const True) userWantsEmailValidation - , fmap (const False) signInResult - ] - - uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail - - let validatedEmail = R.tagPromptlyDyn - (_inputOut_value input) - (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail) - - let waiting = R.leftmost - [ fmap (const True) validatedEmail - , fmap (const False) signInResult - ] - - button <- Component.button $ ButtonIn - { _buttonIn_class = R.constDyn "validate" - , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button) - , _buttonIn_waiting = waiting - } - - signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime) - - showSignInResult result signInResult - -askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text)) -askSignIn email = - fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (R.postJson "/askSignIn" . SignIn) email - getResult response = - case R._xhrResponse_responseText response of - Just key -> - if R._xhrResponse_status response == 200 then Right key else Left key - _ -> Left "NoKey" - -showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m () -showSignInResult result signInResult = do - _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult +import qualified Util.Ajax as Ajax +import qualified Util.WaitFor as Util + +data SignInMessage = + SuccessMessage Text + | ErrorMessage Text + | EmptyMessage + +view :: forall t m. MonadWidget t m => SignInMessage -> m () +view signInMessage = + R.divClass "signIn" $ + Component.form $ do + rec + input <- Component.input $ InputIn + { _inputIn_reset = R.ffilter Either.isRight signInResult + , _inputIn_label = Msg.get Msg.SignIn_EmailLabel + , _inputIn_initialValue = "" + } + + button <- Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button)) + { _buttonIn_class = R.constDyn "validate" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + } + + (signInResult, waiting) <- Util.waitFor + (\email -> Ajax.post "/askSignIn" (SignIn <$> email)) + (_buttonOut_clic button) + (_inputOut_value input) + + showSignInResult signInMessage signInResult + +showSignInResult :: forall t m. MonadWidget t m => SignInMessage -> Event t (Either Text Text) -> m () +showSignInResult signInMessage signInResult = do + _ <- R.widgetHold (showInitResult signInMessage) $ R.ffor signInResult showResult R.blank - where showInitResult (Left error) = showError error - showInitResult (Right (Just success)) = showSuccess success - showInitResult (Right Nothing) = R.blank + where showInitResult (SuccessMessage success) = showSuccess success + showInitResult (ErrorMessage error) = showError error + showInitResult EmptyMessage = R.blank showResult (Left error) = showError error showResult (Right success) = showSuccess success -- cgit v1.2.3 From df83b634006c699cfa1e921bf74ce951a906a62f Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Jun 2018 22:02:00 +0200 Subject: Use date input type --- client/src/Component/Button.hs | 10 ---------- client/src/Component/Input.hs | 38 +++++++++++++++++++++++++------------- client/src/View/Payment/Add.hs | 8 +++++--- client/src/View/Payment/Header.hs | 6 ++---- client/src/View/SignIn.hs | 2 ++ 5 files changed, 34 insertions(+), 30 deletions(-) (limited to 'client') diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index bf604f1..46c0afa 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -31,20 +31,10 @@ defaultButtonIn content = ButtonIn , _buttonIn_submit = False } --- defaultButtonIn :: MonadWidget t m => ButtonIn t m --- defaultButtonIn = ButtonIn --- { _buttonIn_class = R.constDyn "" --- , _buttonIn_content = R.blank --- , _buttonIn_waiting = R.never --- , _buttonIn_tabIndex = Nothing --- , _buttonIn_submit = False --- } - data ButtonOut t = ButtonOut { _buttonOut_clic :: Event t () } - button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) button buttonIn = do dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 92f8ec9..c1eb4e8 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -17,16 +17,20 @@ import qualified Component.Button as Button import qualified Icon data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_label :: Text - , _inputIn_initialValue :: Text + { _inputIn_reset :: Event t a + , _inputIn_hasResetButton :: Bool + , _inputIn_label :: Text + , _inputIn_initialValue :: Text + , _inputIn_inputType :: Text } defaultInputIn :: (Reflex t) => InputIn t a b defaultInputIn = InputIn - { _inputIn_reset = R.never - , _inputIn_label = "" - , _inputIn_initialValue = "" + { _inputIn_reset = R.never + , _inputIn_hasResetButton = True + , _inputIn_label = "" + , _inputIn_initialValue = "" + , _inputIn_inputType = "text" } data InputOut t = InputOut @@ -40,11 +44,13 @@ input inputIn = rec let resetValue = R.leftmost [ fmap (const "") (_inputIn_reset inputIn) - , fmap (const "") (_buttonOut_clic reset) + , fmap (const "") resetClic ] attributes = R.ffor value (\v -> - if T.null v then M.empty else M.singleton "class" "filled") + if T.null v && _inputIn_inputType inputIn /= "date" + then M.empty + else M.singleton "class" "filled") value = R._textInput_value textInput @@ -52,14 +58,20 @@ input inputIn = & R.attributes .~ attributes & R.setValue .~ resetValue & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) + & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn) R.el "label" $ R.text (_inputIn_label inputIn) - reset <- Button.button $ - (Button.defaultButtonIn Icon.cross) - { _buttonIn_class = R.constDyn "reset" - , _buttonIn_tabIndex = Just (-1) - } + resetClic <- + if _inputIn_hasResetButton inputIn + then + _buttonOut_clic <$> (Button.button $ + (Button.defaultButtonIn Icon.cross) + { _buttonIn_class = R.constDyn "reset" + , _buttonIn_tabIndex = Just (-1) + }) + else + return R.never let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 2eaec0f..5ff09dd 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -8,6 +8,7 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Map as M import qualified Data.Maybe as Maybe import qualified Data.Text as T +import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Time import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R @@ -17,7 +18,6 @@ import Common.Model (Category (..), CreatePayment (..), Frequency (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as Time -import qualified Common.View.Format as Format import Component (ButtonIn (..), InputIn (..), InputOut (..), SelectIn (..), SelectOut (..)) @@ -49,8 +49,10 @@ view addIn = do date <- _inputOut_value <$> (Component.input $ Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Cost - , _inputIn_initialValue = Format.shortDay currentDay + { _inputIn_label = Msg.get Msg.Payment_Date + , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay + , _inputIn_inputType = "date" + , _inputIn_hasResetButton = False }) frequency <- _selectOut_value <$> (Component.select $ SelectIn diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index d01dec6..fd46c25 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -104,10 +104,8 @@ payerAndAdd incomes payments users categories currency = do searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency) searchLine = do R.divClass "searchLine" $ do - searchName <- _inputOut_value <$> (Component.input $ InputIn - { _inputIn_reset = R.never - , _inputIn_label = Msg.get Msg.Search_Name - , _inputIn_initialValue = "" + searchName <- _inputOut_value <$> (Component.input $ Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Search_Name }) let frequencies = M.fromList diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 912aea2..21d0fcc 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -30,8 +30,10 @@ view signInMessage = rec input <- Component.input $ InputIn { _inputIn_reset = R.ffilter Either.isRight signInResult + , _inputIn_hasResetButton = True , _inputIn_label = Msg.get Msg.SignIn_EmailLabel , _inputIn_initialValue = "" + , _inputIn_inputType = "text" } button <- Component.button $ -- cgit v1.2.3 From 40b4994797a797b1fa86cafda789a5c488730c6d Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 28 Oct 2018 17:57:58 +0100 Subject: Delete payment --- client/client.cabal | 6 ++-- client/src/Component/Form.hs | 2 +- client/src/Component/Modal.hs | 33 ++++++++++++------- client/src/Component/Select.hs | 2 +- client/src/Util/Ajax.hs | 67 +++++++++++++++++++++++++++++---------- client/src/Util/Dom.hs | 36 ++++++++++++++++++--- client/src/View/Payment/Add.hs | 6 ++-- client/src/View/Payment/Delete.hs | 40 +++++++++++++---------- client/src/View/Payment/Header.hs | 4 +-- client/src/View/Payment/Table.hs | 2 +- client/src/View/SignIn.hs | 6 ++-- 11 files changed, 143 insertions(+), 61 deletions(-) (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 0aec05f..26ad2ec 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -10,7 +10,7 @@ Cabal-version: >=1.10 Executable client Main-Is: Main.hs - Ghc-options: -Wall -Werror + -- Ghc-options: -Wall -Werror Hs-source-dirs: src Default-language: Haskell2010 @@ -22,10 +22,12 @@ Executable client Build-depends: aeson - , base >=4.9 && <4.11 + , base >=4.9 && <5 , bytestring , common , containers + , data-default + , ghcjs-dom-jsffi , jsaddle-dom , reflex-dom , text diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs index 0a89c6e..6ea02fa 100644 --- a/client/src/Component/Form.hs +++ b/client/src/Component/Form.hs @@ -6,7 +6,7 @@ import qualified Data.Map as M import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -form :: forall t m a. (MonadWidget t m) => m a -> m a +form :: forall t m a. MonadWidget t m => m a -> m a form content = R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $ content diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index 1d70c90..72091c9 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -1,14 +1,19 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module Component.Modal ( ModalIn(..) , ModalOut(..) , modal ) where -import qualified Data.Map as M -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import Control.Monad (void) +import qualified Data.Map as M +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified GHCJS.DOM.Node as Node +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R +import qualified Reflex.Dom.Class as R + +import qualified Util.Dom as Dom data ModalIn t m a = ModalIn { _modalIn_show :: Event t () @@ -29,16 +34,22 @@ modal modalIn = do , False <$ curtainClick ] - let attr = flip fmap showModal (\s -> M.fromList $ - [ ("style", if s then "display:block" else "display:none") - , ("class", "modal") - ]) - - (curtainClick, content) <- R.elDynAttr "div" attr $ do + (elem, (curtainClick, content)) <- R.buildElement "div" (getAttributes <$> showModal) $ do (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank cont <- R.divClass "modalContent" $ _modalIn_content modalIn return (R.domEvent R.Click curtain, cont) + body <- Dom.getBody + let moveBackdrop = (const $ (Node.appendChild body elem)) `fmap` (_modalIn_show modalIn) + R.performEvent_ $ void `fmap` moveBackdrop + return $ ModalOut { _modalOut_content = content } + +getAttributes :: Bool -> LM.Map Text Text +getAttributes show = + M.fromList $ + [ ("style", if show then "display:block" else "display:none") + , ("class", "modal") + ] diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 876548e..17a4958 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -19,7 +19,7 @@ data SelectOut t a = SelectOut { _selectOut_value :: Dynamic t a } -select :: forall t m a. (Ord a) => MonadWidget t m => SelectIn t a -> m (SelectOut t a) +select :: forall t m a. (Ord a, MonadWidget t m) => SelectIn t a -> m (SelectOut t a) select selectIn = R.divClass "selectInput" $ do R.el "label" $ R.text (_selectIn_label selectIn) diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 1e8e4c7..14675df 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -1,20 +1,55 @@ module Util.Ajax - ( post + ( postJson + , delete ) where -import Data.Aeson (ToJSON) -import Data.Text (Text) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import Data.Aeson (ToJSON) +import Data.Default (def) +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, + XhrRequest, XhrRequestConfig (..), XhrResponse, + XhrResponseHeaders (..)) +import qualified Reflex.Dom as R -post :: forall t m a. (MonadWidget t m, ToJSON a) => Text -> Event t a -> m (Event t (Either Text Text)) -post url input = - fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = R.postJson url <$> input - getResult response = - case R._xhrResponse_responseText response of - Just responseText -> - if R._xhrResponse_status response == 200 - then Right responseText - else Left responseText - _ -> Left "NoKey" +postJson + :: forall t m a. (MonadWidget t m, ToJSON a) + => Text + -> Event t a + -> m (Event t (Either Text Text)) +postJson url input = + fmap getResult <$> + R.performRequestAsync (R.postJson url <$> input) + +delete + :: forall t m. MonadWidget t m + => Dynamic t Text + -> Event t () + -> m (Event t (Either Text Text)) +delete url fire = + fmap getResult <$> + R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire) + +getResult :: XhrResponse -> Either Text Text +getResult response = + case R._xhrResponse_responseText response of + Just responseText -> + if R._xhrResponse_status response == 200 + then Right responseText + else Left responseText + _ -> Left "NoKey" + +request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a +request method url sendData = + let + config = XhrRequestConfig + { _xhrRequestConfig_headers = def + , _xhrRequestConfig_user = def + , _xhrRequestConfig_password = def + , _xhrRequestConfig_responseType = def + , _xhrRequestConfig_responseHeaders = def + , _xhrRequestConfig_withCredentials = False + , _xhrRequestConfig_sendData = sendData + } + in + R.xhrRequest method url config diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs index f3e9c88..55b8521 100644 --- a/client/src/Util/Dom.hs +++ b/client/src/Util/Dom.hs @@ -1,12 +1,31 @@ module Util.Dom - ( divVisibleIf + ( divIfDyn + , divIfEvent + , divVisibleIf , divClassVisibleIf + , getBody ) where -import qualified Data.Map as M -import Data.Text (Text) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Text (Text) +import qualified GHCJS.DOM as Dom +import qualified GHCJS.DOM.Document as Document +import qualified GHCJS.DOM.HTMLCollection as HTMLCollection +import GHCJS.DOM.Types (Element) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +divIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Dynamic t a) +divIfDyn cond = divIfEvent (R.updated cond) + +divIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a) +divIfEvent cond empty content = + R.widgetHold empty (flip fmap cond (\show -> + if show + then + content + else + empty)) divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a divVisibleIf cond content = divClassVisibleIf cond "" content @@ -17,3 +36,10 @@ divClassVisibleIf cond className content = "div" (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond) content + +getBody :: forall t m. MonadWidget t m => m Element +getBody = do + document <- Dom.currentDocumentUnchecked + nodelist <- Document.getElementsByTagName document ("body" :: String) + Just body <- nodelist `HTMLCollection.item` 0 + return body diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 5ff09dd..8b1b56e 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -23,7 +23,7 @@ import Component (ButtonIn (..), InputIn (..), SelectOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax -import qualified Util.WaitFor as Util +import qualified Util.WaitFor as WaitFor data AddIn = AddIn { _addIn_categories :: [Category] @@ -83,8 +83,8 @@ view addIn = do , _buttonIn_submit = True }) - (_, waiting) <- Util.waitFor - (Ajax.post "/payment") + (_, waiting) <- WaitFor.waitFor + (Ajax.postJson "/payment") validate payment diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index a1be16d..03cf267 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -4,24 +4,27 @@ module View.Payment.Delete , DeleteOut(..) ) where -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R - -import qualified Common.Msg as Msg -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component --- import qualified Util.Ajax as Ajax --- import qualified Util.WaitFor as Util - -data DeleteIn = DeleteIn - {} +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model.Payment (PaymentId) +import qualified Common.Msg as Msg +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +-- import qualified Util.WaitFor as WaitFor + +data DeleteIn t = DeleteIn + { _deleteIn_id :: Dynamic t PaymentId + } data DeleteOut t = DeleteOut { _deleteOut_cancel :: Event t () } -view :: forall t m. MonadWidget t m => DeleteIn -> m (DeleteOut t) -view _ = +view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t) +view deleteIn = R.divClass "delete" $ do R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm @@ -29,14 +32,19 @@ view _ = cancel <- R.divClass "buttons" $ do rec - _ <- Component._buttonOut_clic <$> (Component.button $ + confirm <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) { _buttonIn_class = R.constDyn "confirm" , _buttonIn_submit = True }) - -- (_, waiting) <- Util.waitFor - -- (Ajax.post "/payment") + let url = flip fmap (_deleteIn_id deleteIn) (\id -> + T.concat ["/payment/", T.pack . show $ id] + ) + Ajax.delete url confirm + + -- (_, waiting) <- WaitFor.waitFor + -- (Ajax.delete "/payment") -- validate -- payment diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index fd46c25..be7f6d5 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -86,7 +86,7 @@ payerAndAdd incomes payments users categories currency = do R.text "+ " R.text . Format.price currency $ _exceedingPayer_amount p ) - addPayment <- _buttonOut_clic <$> (Component.button $ ButtonIn + addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn { _buttonIn_class = R.constDyn "addPayment" , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add , _buttonIn_waiting = R.never @@ -95,7 +95,7 @@ payerAndAdd incomes payments users categories currency = do }) rec modalOut <- Component.modal $ ModalIn - { _modalIn_show = addPayment + { _modalIn_show = addPaymentClic , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories } } diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 23d7225..13cedda 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -118,7 +118,7 @@ paymentRow init payment = modalOut <- Component.modal $ ModalIn { _modalIn_show = deletePayment , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut - , _modalIn_content = Delete.view (DeleteIn {}) + , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment }) } return () diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 21d0fcc..24e5be0 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -16,7 +16,7 @@ import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax -import qualified Util.WaitFor as Util +import qualified Util.WaitFor as WaitFor data SignInMessage = SuccessMessage Text @@ -43,8 +43,8 @@ view signInMessage = , _buttonIn_submit = True } - (signInResult, waiting) <- Util.waitFor - (\email -> Ajax.post "/askSignIn" (SignIn <$> email)) + (signInResult, waiting) <- WaitFor.waitFor + (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email)) (_buttonOut_clic button) (_inputOut_value input) -- cgit v1.2.3 From 50fb8fa48d1c4881da20b4ecf6d68a772301e713 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 30 Oct 2018 18:04:58 +0100 Subject: Update table when adding or removing a payment --- client/src/Component/Input.hs | 20 +++++----- client/src/Component/Modal.hs | 66 +++++++++++++++++++++----------- client/src/Component/Select.hs | 10 ++++- client/src/Icon.hs | 2 +- client/src/Main.hs | 5 ++- client/src/Util/Ajax.hs | 40 ++++++++++++-------- client/src/Util/Either.hs | 7 ++++ client/src/View/Payment.hs | 61 ++++++++++++++++++++++++++---- client/src/View/Payment/Add.hs | 39 ++++++++++++------- client/src/View/Payment/Delete.hs | 13 +++++-- client/src/View/Payment/Header.hs | 79 +++++++++++++++++++++++---------------- client/src/View/Payment/Pages.hs | 2 +- client/src/View/Payment/Table.hs | 29 ++++++++------ client/src/View/SignIn.hs | 10 ++--- 14 files changed, 255 insertions(+), 128 deletions(-) create mode 100644 client/src/Util/Either.hs (limited to 'client') diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index c1eb4e8..57018a6 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -16,18 +16,16 @@ import Component.Button (ButtonIn (..), ButtonOut (..)) import qualified Component.Button as Button import qualified Icon -data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_hasResetButton :: Bool +data InputIn = InputIn + { _inputIn_hasResetButton :: Bool , _inputIn_label :: Text , _inputIn_initialValue :: Text , _inputIn_inputType :: Text } -defaultInputIn :: (Reflex t) => InputIn t a b +defaultInputIn :: InputIn defaultInputIn = InputIn - { _inputIn_reset = R.never - , _inputIn_hasResetButton = True + { _inputIn_hasResetButton = True , _inputIn_label = "" , _inputIn_initialValue = "" , _inputIn_inputType = "text" @@ -38,12 +36,16 @@ data InputOut t = InputOut , _inputOut_enter :: Event t () } -input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) -input inputIn = +input + :: forall t m a b. MonadWidget t m + => InputIn + -> Event t a -- reset + -> m (InputOut t) +input inputIn reset = R.divClass "textInput" $ do rec let resetValue = R.leftmost - [ fmap (const "") (_inputIn_reset inputIn) + [ fmap (const "") reset , fmap (const "") resetClic ] diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index 72091c9..b86fee0 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -4,16 +4,18 @@ module Component.Modal , modal ) where -import Control.Monad (void) -import qualified Data.Map as M -import qualified Data.Map.Lazy as LM -import Data.Text (Text) -import qualified GHCJS.DOM.Node as Node -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R -import qualified Reflex.Dom.Class as R +import Control.Monad (void) +import qualified Data.Map as M +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified GHCJS.DOM.Element as Element +import qualified GHCJS.DOM.Node as Node +import JSDOM.Types (JSString) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R +import qualified Reflex.Dom.Class as R -import qualified Util.Dom as Dom +import qualified Util.Dom as Dom data ModalIn t m a = ModalIn { _modalIn_show :: Event t () @@ -28,20 +30,21 @@ data ModalOut a = ModalOut modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut a) modal modalIn = do rec - showModal <- R.holdDyn False $ R.leftmost - [ True <$ _modalIn_show modalIn - , False <$ _modalIn_hide modalIn - , False <$ curtainClick - ] + let showEvent = R.leftmost + [ True <$ _modalIn_show modalIn + , False <$ _modalIn_hide modalIn + , False <$ curtainClick + ] - (elem, (curtainClick, content)) <- R.buildElement "div" (getAttributes <$> showModal) $ do - (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank - cont <- R.divClass "modalContent" $ _modalIn_content modalIn - return (R.domEvent R.Click curtain, cont) + showModal <- R.holdDyn False showEvent - body <- Dom.getBody - let moveBackdrop = (const $ (Node.appendChild body elem)) `fmap` (_modalIn_show modalIn) - R.performEvent_ $ void `fmap` moveBackdrop + (elem, (curtainClick, content)) <- + R.buildElement "div" (getAttributes <$> showModal) $ do + (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank + cont <- R.divClass "modalContent" $ _modalIn_content modalIn + return (R.domEvent R.Click curtain, cont) + + performShowEffects showEvent elem return $ ModalOut { _modalOut_content = content @@ -53,3 +56,24 @@ getAttributes show = [ ("style", if show then "display:block" else "display:none") , ("class", "modal") ] + +performShowEffects + :: forall t m a. MonadWidget t m + => Event t Bool + -> Element.Element + -> m () +performShowEffects showEvent elem = do + body <- Dom.getBody + + let showEffects = + flip fmap showEvent (\show -> do + if show + then + do + Node.appendChild body elem + Element.setClassName body ("modal" :: JSString) + else + Element.setClassName body ("" :: JSString) + ) + + R.performEvent_ $ void `fmap` showEffects diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 17a4958..7cb6726 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -6,13 +6,14 @@ module Component.Select import Data.Map (Map) import Data.Text (Text) -import Reflex.Dom (Dynamic, MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R data (Reflex t) => SelectIn t a = SelectIn { _selectIn_label :: Text , _selectIn_initialValue :: a , _selectIn_values :: Dynamic t (Map a Text) + , _selectIn_reset :: Event t () } data SelectOut t a = SelectOut @@ -24,8 +25,13 @@ select selectIn = R.divClass "selectInput" $ do R.el "label" $ R.text (_selectIn_label selectIn) + let initialValue = _selectIn_initialValue selectIn + value <- R._dropdown_value <$> - R.dropdown (_selectIn_initialValue selectIn) (_selectIn_values selectIn) R.def + R.dropdown + initialValue + (_selectIn_values selectIn) + (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) }) return SelectOut { _selectOut_value = value diff --git a/client/src/Icon.hs b/client/src/Icon.hs index dae5e7f..1a45933 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -59,7 +59,7 @@ edit = loading :: forall t m. MonadWidget t m => m () loading = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader"), ("fill", "currentColor") ]) $ svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank signOut :: forall t m. MonadWidget t m => m () diff --git a/client/src/Main.hs b/client/src/Main.hs index 6c048c6..d6f89cd 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -9,7 +9,8 @@ import qualified Data.Text.Encoding as T import qualified JSDOM as Dom import qualified JSDOM.Generated.HTMLElement as Dom import qualified JSDOM.Generated.NonElementParentNode as Dom -import JSDOM.Types (HTMLElement (..), JSM) +import JSDOM.Types (HTMLElement (..), JSM, + JSString) import qualified JSDOM.Types as Dom import Prelude hiding (error, init) @@ -26,7 +27,7 @@ main = do readInit :: JSM InitResult readInit = do document <- Dom.currentDocumentUnchecked - initNode <- Dom.getElementById document ("init" :: Dom.JSString) + initNode <- Dom.getElementById document ("init" :: JSString) case initNode of Just node -> do diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 14675df..0d76638 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -3,32 +3,42 @@ module Util.Ajax , delete ) where -import Data.Aeson (ToJSON) -import Data.Default (def) -import qualified Data.Map.Lazy as LM -import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, - XhrRequest, XhrRequestConfig (..), XhrResponse, - XhrResponseHeaders (..)) -import qualified Reflex.Dom as R +import Control.Arrow (left) +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as Aeson +import Data.Default (def) +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, + XhrRequest, XhrRequestConfig (..), + XhrResponse, XhrResponseHeaders (..)) +import qualified Reflex.Dom as R postJson - :: forall t m a. (MonadWidget t m, ToJSON a) + :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) => Text -> Event t a - -> m (Event t (Either Text Text)) + -> m (Event t (Either Text b)) postJson url input = - fmap getResult <$> + fmap getJsonResult <$> R.performRequestAsync (R.postJson url <$> input) delete - :: forall t m. MonadWidget t m + :: forall t m a. (MonadWidget t m) => Dynamic t Text -> Event t () -> m (Event t (Either Text Text)) -delete url fire = - fmap getResult <$> - R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire) +delete url fire = do + response <- R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire) + return $ fmap getResult response + +getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a +getJsonResult response = + case getResult response of + Left l -> Left l + Right r -> left T.pack . Aeson.eitherDecodeStrict $ (T.encodeUtf8 r) getResult :: XhrResponse -> Either Text Text getResult response = diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs new file mode 100644 index 0000000..2910d95 --- /dev/null +++ b/client/src/Util/Either.hs @@ -0,0 +1,7 @@ +module Util.Either + ( eitherToMaybe + ) where + +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Right b) = Just b +eitherToMaybe _ = Nothing diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 42da8fb..5245e72 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -4,17 +4,20 @@ module View.Payment , PaymentOut(..) ) where +import Data.Text (Text) +import qualified Data.Text as T import Prelude hiding (init) -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Init (..)) - +import Common.Model (Frequency, Init (..), Payment (..), + PaymentId) +import qualified Common.Util.Text as T import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn (..)) +import View.Payment.Table (TableIn (..), TableOut (..)) import qualified View.Payment.Table as Table data PaymentIn = PaymentIn @@ -32,21 +35,63 @@ widget paymentIn = do let init = _paymentIn_init paymentIn paymentsPerPage = 7 + payments <- getPayments + (_init_payments init) + (_headerOut_addedPayment header) + (_tableOut_deletedPayment table) + + let searchPayments = + getSearchPayments + (_headerOut_searchName header) + (_headerOut_searchFrequency header) + payments + header <- Header.widget $ HeaderIn { _headerIn_init = init + , _headerIn_searchPayments = searchPayments } - _ <- Table.widget $ TableIn + table <- Table.widget $ TableIn { _tableIn_init = init , _tableIn_currentPage = _pagesOut_currentPage pages - , _tableIn_payments = _headerOut_searchPayments header + , _tableIn_payments = searchPayments , _tableIn_perPage = paymentsPerPage } pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> _headerOut_searchPayments header + { _pagesIn_total = length <$> searchPayments , _pagesIn_perPage = paymentsPerPage - , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_searchName header + , _pagesIn_reset = R.leftmost $ + [ fmap (const ()) . R.updated . _headerOut_searchName $ header + , fmap (const ()) . _headerOut_addedPayment $ header + ] } pure $ PaymentOut {} + +getPayments + :: forall t m. MonadWidget t m + => [Payment] + -> Event t Payment + -> Event t PaymentId + -> m (Dynamic t [Payment]) +getPayments initPayments addedPayment deletedPayment = + R.foldDyn id initPayments $ R.leftmost + [ flip fmap addedPayment (:) + , flip fmap deletedPayment (\paymentId -> filter ((/= paymentId) . _payment_id)) + ] + +getSearchPayments + :: forall t. Reflex t + => Dynamic t Text + -> Dynamic t Frequency + -> Dynamic t [Payment] + -> Dynamic t [Payment] +getSearchPayments name frequency payments = do + n <- name + f <- frequency + ps <- payments + pure $ flip filter ps (\p -> + ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) + && (_payment_frequency p == f) + )) diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 8b1b56e..602f7f3 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -10,12 +10,12 @@ import qualified Data.Maybe as Maybe import qualified Data.Text as T import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Time -import Reflex.Dom (Event, MonadWidget) +import Reflex.Dom (Event, MonadWidget, Reflex) import qualified Reflex.Dom as R import qualified Text.Read as T import Common.Model (Category (..), CreatePayment (..), - Frequency (..)) + Frequency (..), Payment (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as Time import Component (ButtonIn (..), InputIn (..), @@ -23,48 +23,56 @@ import Component (ButtonIn (..), InputIn (..), SelectOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil import qualified Util.WaitFor as WaitFor -data AddIn = AddIn +data AddIn t = AddIn { _addIn_categories :: [Category] + , _addIn_show :: Event t () } data AddOut t = AddOut - { _addOut_cancel :: Event t () + { _addOut_cancel :: Event t () + , _addOut_addedPayment :: Event t Payment } -view :: forall t m. MonadWidget t m => AddIn -> m (AddOut t) +view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t) view addIn = do R.divClass "add" $ do R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add R.divClass "addContent" $ do - name <- _inputOut_value <$> (Component.input $ - Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) + name <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) + (_addIn_show addIn)) - cost <- _inputOut_value <$> (Component.input $ - Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) + cost <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) + (_addIn_show addIn)) currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay - date <- _inputOut_value <$> (Component.input $ - Component.defaultInputIn + date <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Date , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay , _inputIn_inputType = "date" , _inputIn_hasResetButton = False }) + (_addIn_show addIn)) frequency <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Frequency , _selectIn_initialValue = Punctual , _selectIn_values = R.constDyn frequencies + , _selectIn_reset = _addIn_show addIn }) category <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Category , _selectIn_initialValue = 0 , _selectIn_values = R.constDyn categories + , _selectIn_reset = _addIn_show addIn }) let payment = CreatePayment @@ -74,7 +82,7 @@ view addIn = do <*> category <*> frequency - cancel <- R.divClass "buttons" $ do + (addedPayment, cancel) <- R.divClass "buttons" $ do rec validate <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) @@ -83,17 +91,20 @@ view addIn = do , _buttonIn_submit = True }) - (_, waiting) <- WaitFor.waitFor + (result, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") validate payment - Component._buttonOut_clic <$> (Component.button $ + cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) { _buttonIn_class = R.constDyn "undo" }) + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) + return AddOut { _addOut_cancel = cancel + , _addOut_addedPayment = addedPayment } where diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 03cf267..330ef9f 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -4,6 +4,7 @@ module View.Payment.Delete , DeleteOut(..) ) where +import Data.Text (Text) import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R @@ -13,6 +14,7 @@ import qualified Common.Msg as Msg import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil -- import qualified Util.WaitFor as WaitFor data DeleteIn t = DeleteIn @@ -20,7 +22,8 @@ data DeleteIn t = DeleteIn } data DeleteOut t = DeleteOut - { _deleteOut_cancel :: Event t () + { _deleteOut_cancel :: Event t () + , _deleteOut_validate :: Event t PaymentId } view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t) @@ -30,7 +33,7 @@ view deleteIn = R.divClass "deleteContent" $ do - cancel <- R.divClass "buttons" $ do + (deletedPayment, cancel) <- R.divClass "buttons" $ do rec confirm <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) @@ -41,7 +44,8 @@ view deleteIn = let url = flip fmap (_deleteIn_id deleteIn) (\id -> T.concat ["/payment/", T.pack . show $ id] ) - Ajax.delete url confirm + + result <- Ajax.delete url confirm -- (_, waiting) <- WaitFor.waitFor -- (Ajax.delete "/payment") @@ -52,8 +56,9 @@ view deleteIn = (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) { _buttonIn_class = R.constDyn "undo" }) - return cancel + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) return DeleteOut { _deleteOut_cancel = cancel + , _deleteOut_validate = R.tag (R.current $ _deleteIn_id deleteIn) deletedPayment } diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index be7f6d5..653df5e 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -13,7 +13,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time as Time import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R import Common.Model (Category, Currency, @@ -22,7 +22,6 @@ import Common.Model (Category, Currency, User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg -import qualified Common.Util.Text as T import qualified Common.View.Format as Format import Component (ButtonIn (..), ButtonOut (..), @@ -34,44 +33,47 @@ import View.Payment.Add (AddIn (..), AddOut (..)) import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn - { _headerIn_init :: Init + { _headerIn_init :: Init + , _headerIn_searchPayments :: Dynamic t [Payment] } data HeaderOut t = HeaderOut - { _headerOut_searchName :: Dynamic t Text - , _headerOut_searchPayments :: Dynamic t [Payment] + { _headerOut_searchName :: Dynamic t Text + , _headerOut_searchFrequency :: Dynamic t Frequency + , _headerOut_addedPayment :: Event t Payment } widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - payerAndAdd incomes punctualPayments users categories currency - (searchName, searchFrequency) <- searchLine - let searchPayments = getSearchPayments searchName searchFrequency payments - infos searchPayments users currency + addedPayment <- payerAndAdd incomes punctualPayments users categories currency + let resetSearchName = fmap (const ()) $ addedPayment + (searchName, searchFrequency) <- searchLine resetSearchName + + infos (_headerIn_searchPayments headerIn) users currency + return $ HeaderOut { _headerOut_searchName = searchName - , _headerOut_searchPayments = searchPayments + , _headerOut_searchFrequency = searchFrequency + , _headerOut_addedPayment = addedPayment } where init = _headerIn_init headerIn incomes = _init_incomes init - payments = _init_payments init - punctualPayments = filter ((==) Punctual . _payment_frequency) payments + initPayments = _init_payments init + punctualPayments = filter ((==) Punctual . _payment_frequency) initPayments users = _init_users init categories = _init_categories init currency = _init_currency init -getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment] -getSearchPayments name frequency payments = do - n <- name - f <- frequency - pure $ flip filter payments (\p -> - ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) - && (_payment_frequency p == f) - )) - -payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> [Category] -> Currency -> m () +payerAndAdd + :: forall t m. MonadWidget t m + => [Income] + -> [Payment] + -> [User] + -> [Category] + -> Currency + -> m (Event t Payment) payerAndAdd incomes payments users categories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do @@ -94,19 +96,28 @@ payerAndAdd incomes payments users categories currency = do , _buttonIn_submit = False }) rec - modalOut <- Component.modal $ ModalIn + modalOut <- fmap _modalOut_content . Component.modal $ ModalIn { _modalIn_show = addPaymentClic - , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut - , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories } + , _modalIn_hide = R.leftmost $ + [ _addOut_cancel modalOut + , fmap (const ()) . _addOut_addedPayment $ modalOut + ] + , _modalIn_content = Add.view $ AddIn + { _addIn_categories = categories + , _addIn_show = addPaymentClic + } } - return () + return (_addOut_addedPayment modalOut) -searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency) -searchLine = do +searchLine + :: forall t m. MonadWidget t m + => Event t () + -> m (Dynamic t Text, Dynamic t Frequency) +searchLine reset = do R.divClass "searchLine" $ do - searchName <- _inputOut_value <$> (Component.input $ Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Search_Name - }) + searchName <- _inputOut_value <$> (Component.input + ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name }) + reset) let frequencies = M.fromList [ (Punctual, Msg.get Msg.Payment_PunctualMale) @@ -118,7 +129,11 @@ searchLine = do return (searchName, searchFrequency) -infos :: forall t m. MonadWidget t m => Dynamic t [Payment] -> [User] -> Currency -> m () +infos + :: forall t m. MonadWidget t m + => Dynamic t [Payment] + -> [User] + -> Currency -> m () infos payments users currency = R.divClass "infos" $ do diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index d14b640..57d67ac 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -64,7 +64,7 @@ pageButtons total perPage reset = do return currentPage where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) - pageEvent = R.switchPromptlyDyn . fmap R.leftmost + pageEvent = R.switch . R.current . fmap R.leftmost noCurrentPage = R.constDyn Nothing range :: Int -> Int -> [Int] diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 13cedda..ba16bf5 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -9,11 +9,12 @@ import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) + PaymentCategory (..), PaymentId, + User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.Util.Text as T @@ -34,15 +35,15 @@ data TableIn t = TableIn , _tableIn_perPage :: Int } -data TableOut = TableOut - { +data TableOut t = TableOut + { _tableOut_deletedPayment :: Event t PaymentId } -widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut +widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) widget tableIn = do R.divClass "table" $ do - R.divClass "lines" $ do + deletedPayment <- R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost @@ -52,13 +53,14 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - _ <- R.simpleList paymentRange (paymentRow init) - return () + (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init)) Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty - return $ TableOut {} + return $ TableOut + { _tableOut_deletedPayment = deletedPayment + } where init = _tableIn_init tableIn @@ -74,7 +76,7 @@ getPaymentRange perPage payments currentPage = . L.sortOn _payment_date $ payments -paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () +paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m (Event t PaymentId) paymentRow init payment = R.divClass "row" $ do R.divClass "cell name" . R.dynText . fmap _payment_name $ payment @@ -117,10 +119,13 @@ paymentRow init payment = rec modalOut <- Component.modal $ ModalIn { _modalIn_show = deletePayment - , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut + , _modalIn_hide = R.leftmost $ + [ _deleteOut_cancel . _modalOut_content $ modalOut + , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut + ] , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment }) } - return () + return (_deleteOut_validate . _modalOut_content $ modalOut) findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 24e5be0..7f53299 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -28,13 +28,9 @@ view signInMessage = R.divClass "signIn" $ Component.form $ do rec - input <- Component.input $ InputIn - { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_hasResetButton = True - , _inputIn_label = Msg.get Msg.SignIn_EmailLabel - , _inputIn_initialValue = "" - , _inputIn_inputType = "text" - } + input <- (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.SignIn_EmailLabel }) + (R.ffilter Either.isRight signInResult)) button <- Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button)) -- cgit v1.2.3 From 8a28f608d8e08fba4bbe54b46804d261686c3c03 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 30 Oct 2018 20:33:17 +0100 Subject: Upgrade reflex-platform --- client/src/Util/Ajax.hs | 2 +- client/src/Util/WaitFor.hs | 2 +- client/src/View/Payment/Header.hs | 1 + 3 files changed, 3 insertions(+), 2 deletions(-) (limited to 'client') diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 0d76638..7b65c52 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -31,7 +31,7 @@ delete -> Event t () -> m (Event t (Either Text Text)) delete url fire = do - response <- R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire) + response <- R.performRequestAsync (R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire) return $ fmap getResult response getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs index 0175c95..7d5e7c5 100644 --- a/client/src/Util/WaitFor.hs +++ b/client/src/Util/WaitFor.hs @@ -13,6 +13,6 @@ waitFor -> Dynamic t a -> m (Event t b, Event t Bool) waitFor op start input = do - result <- op (R.tagPromptlyDyn input start) >>= R.debounce (0.5 :: NominalDiffTime) + result <- op (R.tag (R.current input) start) >>= R.debounce (0.5 :: NominalDiffTime) let waiting = R.leftmost [ const True <$> start , const False <$> result ] return (result, waiting) diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 653df5e..6fbaecf 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -11,6 +11,7 @@ import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T +import Data.Time (NominalDiffTime) import qualified Data.Time as Time import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -- cgit v1.2.3 From b5244184920b4d7a8d64eada2eca21e9a6ea2df9 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 30 Oct 2018 20:44:12 +0100 Subject: Use waitfor with delete confirm button --- client/src/Util/WaitFor.hs | 9 ++++----- client/src/View/Payment/Add.hs | 3 +-- client/src/View/Payment/Delete.hs | 12 +++++------- client/src/View/SignIn.hs | 3 +-- 4 files changed, 11 insertions(+), 16 deletions(-) (limited to 'client') diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs index 7d5e7c5..46882aa 100644 --- a/client/src/Util/WaitFor.hs +++ b/client/src/Util/WaitFor.hs @@ -9,10 +9,9 @@ import qualified Reflex.Dom as R waitFor :: forall t m a b. MonadWidget t m => (Event t a -> m (Event t b)) - -> Event t () - -> Dynamic t a + -> Event t a -> m (Event t b, Event t Bool) -waitFor op start input = do - result <- op (R.tag (R.current input) start) >>= R.debounce (0.5 :: NominalDiffTime) - let waiting = R.leftmost [ const True <$> start , const False <$> result ] +waitFor op input = do + result <- op input >>= R.debounce (0.2 :: NominalDiffTime) + let waiting = R.leftmost [ const True <$> input , const False <$> result ] return (result, waiting) diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 602f7f3..1864e76 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -93,8 +93,7 @@ view addIn = do (result, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") - validate - payment + (R.tag (R.current payment) validate) cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 330ef9f..81c7c57 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -15,7 +15,7 @@ import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil --- import qualified Util.WaitFor as WaitFor +import qualified Util.WaitFor as WaitFor data DeleteIn t = DeleteIn { _deleteIn_id :: Dynamic t PaymentId @@ -39,18 +39,16 @@ view deleteIn = (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) { _buttonIn_class = R.constDyn "confirm" , _buttonIn_submit = True + , _buttonIn_waiting = waiting }) let url = flip fmap (_deleteIn_id deleteIn) (\id -> T.concat ["/payment/", T.pack . show $ id] ) - result <- Ajax.delete url confirm - - -- (_, waiting) <- WaitFor.waitFor - -- (Ajax.delete "/payment") - -- validate - -- payment + (result, waiting) <- WaitFor.waitFor + (Ajax.delete url) + confirm cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 7f53299..428997e 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -41,8 +41,7 @@ view signInMessage = (signInResult, waiting) <- WaitFor.waitFor (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email)) - (_buttonOut_clic button) - (_inputOut_value input) + (R.tag (R.current (_inputOut_value input)) (_buttonOut_clic button)) showSignInResult signInMessage signInResult -- cgit v1.2.3 From 86957359ecf54c205aee1c09e151172c327e987a Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 31 Oct 2018 19:03:19 +0100 Subject: Various fixes --- client/src/Util/WaitFor.hs | 2 +- client/src/View/Payment/Add.hs | 115 +++++++++++++++++++++-------------------- 2 files changed, 59 insertions(+), 58 deletions(-) (limited to 'client') diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs index 46882aa..02edff5 100644 --- a/client/src/Util/WaitFor.hs +++ b/client/src/Util/WaitFor.hs @@ -12,6 +12,6 @@ waitFor -> Event t a -> m (Event t b, Event t Bool) waitFor op input = do - result <- op input >>= R.debounce (0.2 :: NominalDiffTime) + result <- op input >>= R.debounce (0.5 :: NominalDiffTime) let waiting = R.leftmost [ const True <$> input , const False <$> result ] return (result, waiting) diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 1864e76..061eeeb 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -42,64 +42,65 @@ view addIn = do R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add R.divClass "addContent" $ do - name <- _inputOut_value <$> (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) - (_addIn_show addIn)) - - cost <- _inputOut_value <$> (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) - (_addIn_show addIn)) - - currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay - - date <- _inputOut_value <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Date - , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay - , _inputIn_inputType = "date" - , _inputIn_hasResetButton = False + rec + name <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) + (const () <$ addedPayment)) + + cost <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) + (const () <$ addedPayment)) + + currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + + date <- _inputOut_value <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Date + , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay + , _inputIn_inputType = "date" + , _inputIn_hasResetButton = False + }) + (const () <$ addedPayment)) + + frequency <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Frequency + , _selectIn_initialValue = Punctual + , _selectIn_values = R.constDyn frequencies + , _selectIn_reset = _addIn_show addIn }) - (_addIn_show addIn)) - - frequency <- _selectOut_value <$> (Component.select $ SelectIn - { _selectIn_label = Msg.get Msg.Payment_Frequency - , _selectIn_initialValue = Punctual - , _selectIn_values = R.constDyn frequencies - , _selectIn_reset = _addIn_show addIn - }) - - category <- _selectOut_value <$> (Component.select $ SelectIn - { _selectIn_label = Msg.get Msg.Payment_Category - , _selectIn_initialValue = 0 - , _selectIn_values = R.constDyn categories - , _selectIn_reset = _addIn_show addIn - }) - - let payment = CreatePayment - <$> name - <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost - <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date - <*> category - <*> frequency - - (addedPayment, cancel) <- R.divClass "buttons" $ do - rec - validate <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { _buttonIn_class = R.constDyn "confirm" - , _buttonIn_waiting = waiting - , _buttonIn_submit = True - }) - - (result, waiting) <- WaitFor.waitFor - (Ajax.postJson "/payment") - (R.tag (R.current payment) validate) - - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) - - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) + + category <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Category + , _selectIn_initialValue = 0 + , _selectIn_values = R.constDyn categories + , _selectIn_reset = _addIn_show addIn + }) + + let payment = CreatePayment + <$> name + <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost + <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date + <*> category + <*> frequency + + (addedPayment, cancel) <- R.divClass "buttons" $ do + rec + validate <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { _buttonIn_class = R.constDyn "confirm" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + }) + + (result, waiting) <- WaitFor.waitFor + (Ajax.postJson "/payment") + (R.tag (R.current payment) validate) + + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) return AddOut { _addOut_cancel = cancel -- cgit v1.2.3 From 2741f47ef7b87255203bc2f7f7b2b9140c70b8f0 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 1 Nov 2018 13:14:25 +0100 Subject: Implementing client side validation --- client/client.cabal | 8 ++- client/src/Component/Input.hs | 114 +++++++++++++++++++++++----------- client/src/Component/Modal.hs | 19 +++--- client/src/Component/Select.hs | 61 +++++++++++++----- client/src/Util/Validation.hs | 37 +++++++++++ client/src/View/App.hs | 3 +- client/src/View/Payment.hs | 2 +- client/src/View/Payment/Add.hs | 127 ++++++++++++++++++++++++-------------- client/src/View/Payment/Header.hs | 16 ++--- client/src/View/Payment/Pages.hs | 2 +- client/src/View/SignIn.hs | 48 ++++++++------ 11 files changed, 302 insertions(+), 135 deletions(-) create mode 100644 client/src/Util/Validation.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 26ad2ec..af71f2d 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -21,8 +21,8 @@ Executable client RecursiveDo Build-depends: - aeson - , base >=4.9 && <5 + aeson + , base >= 4.11 && < 5 , bytestring , common , containers @@ -32,8 +32,10 @@ Executable client , reflex-dom , text , time + , validation other-modules: + Component Component.Button Component.Form Component.Input @@ -42,7 +44,9 @@ Executable client Icon Util.Ajax Util.Dom + Util.Either Util.List + Util.Validation Util.WaitFor View.App View.Header diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 57018a6..67f97c0 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -5,59 +5,91 @@ module Component.Input , defaultInputIn ) where -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex, (&), - (.~)) -import qualified Reflex.Dom as R - -import Component.Button (ButtonIn (..), ButtonOut (..)) -import qualified Component.Button as Button +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (NominalDiffTime) +import Data.Validation (Validation (Failure, Success)) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex, + (&), (.~)) +import qualified Reflex.Dom as R + +import qualified Common.Util.Validation as ValidationUtil +import Component.Button (ButtonIn (..), ButtonOut (..)) +import qualified Component.Button as Button import qualified Icon -data InputIn = InputIn +data InputIn a = InputIn { _inputIn_hasResetButton :: Bool , _inputIn_label :: Text , _inputIn_initialValue :: Text , _inputIn_inputType :: Text + , _inputIn_validation :: Text -> Validation Text a } -defaultInputIn :: InputIn +defaultInputIn :: InputIn Text defaultInputIn = InputIn { _inputIn_hasResetButton = True , _inputIn_label = "" , _inputIn_initialValue = "" , _inputIn_inputType = "text" + , _inputIn_validation = V.Success } -data InputOut t = InputOut - { _inputOut_value :: Dynamic t Text +data InputOut t a = InputOut + { _inputOut_raw :: Dynamic t Text + , _inputOut_value :: Dynamic t (Maybe (Validation Text a)) , _inputOut_enter :: Event t () } input :: forall t m a b. MonadWidget t m - => InputIn - -> Event t a -- reset - -> m (InputOut t) -input inputIn reset = - R.divClass "textInput" $ do - rec - let resetValue = R.leftmost - [ fmap (const "") reset - , fmap (const "") resetClic - ] - - attributes = R.ffor value (\v -> - if T.null v && _inputIn_inputType inputIn /= "date" - then M.empty - else M.singleton "class" "filled") - - value = R._textInput_value textInput + => InputIn a + -> Event t Text -- reset + -> Event t b -- validate + -> m (InputOut t a) +input inputIn reset validate = do + rec + let resetValue = R.leftmost + [ R.traceEvent "reset" reset + , fmap (const "") resetClic + ] + + inputAttr = R.ffor value (\v -> + if T.null v && _inputIn_inputType inputIn /= "date" + then M.empty + else M.singleton "class" "filled") + + value = R._textInput_value textInput + + containerAttr = R.ffor validatedValue (\v -> + M.singleton "class" $ T.intercalate " " + [ "textInput" + , if Maybe.fromMaybe False (ValidationUtil.isFailure <$> v) then "error" else "" + ]) + + -- Clear validation errors after reset + delayedReset <- R.delay (0.1 :: NominalDiffTime) reset + + validatedValue <- R.holdDyn Nothing $ R.attachWith + (\v (clearValidation, validateEmpty) -> + if clearValidation + then Nothing + else Just (_inputIn_validation inputIn $ (if validateEmpty then "" else v))) + (R.current value) + (R.leftmost + [ const (False, True) <$> resetClic + , (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput) + , const (False, False) <$> validate + , const (True, False) <$> R.traceEvent "delayedReset" delayedReset + ]) + + (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do textInput <- R.textInput $ R.def - & R.attributes .~ attributes + & R.attributes .~ inputAttr & R.setValue .~ resetValue & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn) @@ -75,9 +107,19 @@ input inputIn reset = else return R.never - let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + R.divClass "errorMessage" $ + R.dynText . fmap validationError $ validatedValue + + return (textInput, resetClic) + + let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + + return $ InputOut + { _inputOut_raw = value + , _inputOut_value = validatedValue + , _inputOut_enter = enter + } - return $ InputOut - { _inputOut_value = value - , _inputOut_enter = enter - } +validationError :: Maybe (Validation Text a) -> Text +validationError (Just (Failure e)) = e +validationError _ = "" diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index b86fee0..d7943a9 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -23,11 +23,12 @@ data ModalIn t m a = ModalIn , _modalIn_content :: m a } -data ModalOut a = ModalOut +data ModalOut t a = ModalOut { _modalOut_content :: a + , _modalOut_hide :: Event t () } -modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut a) +modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut t a) modal modalIn = do rec let showEvent = R.leftmost @@ -48,6 +49,7 @@ modal modalIn = do return $ ModalOut { _modalOut_content = content + , _modalOut_hide = curtainClick } getAttributes :: Bool -> LM.Map Text Text @@ -67,12 +69,13 @@ performShowEffects showEvent elem = do let showEffects = flip fmap showEvent (\show -> do - if show - then - do - Node.appendChild body elem - Element.setClassName body ("modal" :: JSString) - else + if show then + do + Node.appendChild body elem + Element.setClassName body ("modal" :: JSString) + else + do + Node.removeChild body elem Element.setClassName body ("" :: JSString) ) diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 7cb6726..9f671d3 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -5,34 +5,65 @@ module Component.Select ) where import Data.Map (Map) +import qualified Data.Map as M import Data.Text (Text) +import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -data (Reflex t) => SelectIn t a = SelectIn +import qualified Common.Msg as Msg + +data (Reflex t) => SelectIn t a b c = SelectIn { _selectIn_label :: Text , _selectIn_initialValue :: a , _selectIn_values :: Dynamic t (Map a Text) - , _selectIn_reset :: Event t () + , _selectIn_reset :: Event t b + , _selectIn_isValid :: a -> Bool + , _selectIn_validate :: Event t c } data SelectOut t a = SelectOut { _selectOut_value :: Dynamic t a } -select :: forall t m a. (Ord a, MonadWidget t m) => SelectIn t a -> m (SelectOut t a) -select selectIn = - R.divClass "selectInput" $ do - R.el "label" $ R.text (_selectIn_label selectIn) +select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a) +select selectIn = do + rec + let containerAttr = R.ffor hasError (\e -> + M.singleton "class" $ T.intercalate " " + [ "selectInput" + , if e then "error" else "" + ]) + + hasError <- R.holdDyn False $ R.attachWith + (\v clearError -> not clearError && not (_selectIn_isValid selectIn v)) + (R.current value) + (R.leftmost + [ const False <$> _selectIn_validate selectIn + , const True <$> _selectIn_reset selectIn + ]) + + value <- R.elDynAttr "div" containerAttr $ do + R.el "label" $ R.text (_selectIn_label selectIn) + + let initialValue = _selectIn_initialValue selectIn + + value <- R._dropdown_value <$> + R.dropdown + initialValue + (_selectIn_values selectIn) + (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) }) + + errorMessage <- R.holdDyn "" $ R.attachWith + (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!") + (R.current value) + (_selectIn_validate selectIn) - let initialValue = _selectIn_initialValue selectIn + R.divClass "errorMessage" . R.dynText $ + R.ffor hasError (\e -> if e then Msg.get Msg.Form_NonEmpty else "") - value <- R._dropdown_value <$> - R.dropdown - initialValue - (_selectIn_values selectIn) - (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) }) + return value - return SelectOut - { _selectOut_value = value - } + return SelectOut + { _selectOut_value = value + } diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs new file mode 100644 index 0000000..e2a3dcb --- /dev/null +++ b/client/src/Util/Validation.hs @@ -0,0 +1,37 @@ +module Util.Validation + ( fireValidation + , fireMaybe + , nelError + ) where + +import Control.Monad (join) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NEL +import Data.Text (Text) +import Data.Validation (Validation (Failure, Success)) +import qualified Data.Validation as Validation +import Reflex.Dom (Dynamic, Event, Reflex) +import qualified Reflex.Dom as R + +nelError :: Validation a b -> Validation (NonEmpty a) b +nelError = Validation.validation (Failure . NEL.fromList . (:[])) Success + +fireValidation + :: forall t a b c. Reflex t + => Dynamic t (Maybe (Validation a b)) + -> Event t c + -> Event t b +fireValidation value validate = + R.fmapMaybe + (join . fmap (Validation.validation (const Nothing) Just)) + (R.tag (R.current value) validate) + +fireMaybe + :: forall t a b. Reflex t + => Dynamic t (Maybe a) + -> Event t b + -> Event t a +fireMaybe value validate = + R.fmapMaybe + id + (R.tag (R.current value) validate) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 9aa6c57..6435297 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -16,7 +16,8 @@ import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = - R.mainWidget $ do + R.mainWidget $ R.divClass "app" $ do + headerOut <- Header.view $ HeaderIn { _headerIn_initResult = initResult } diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 5245e72..007471d 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -30,7 +30,7 @@ data PaymentOut = PaymentOut widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut widget paymentIn = do - R.divClass "payment" $ do + R.elClass "main" "payment" $ do rec let init = _paymentIn_init paymentIn paymentsPerPage = 7 diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 061eeeb..62b26a3 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -4,31 +4,34 @@ module View.Payment.Add , AddOut(..) ) where -import Control.Monad.IO.Class (liftIO) -import qualified Data.Map as M -import qualified Data.Maybe as Maybe -import qualified Data.Text as T -import qualified Data.Time.Calendar as Calendar -import qualified Data.Time.Clock as Time -import Reflex.Dom (Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R -import qualified Text.Read as T - -import Common.Model (Category (..), CreatePayment (..), - Frequency (..), Payment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as Time -import Component (ButtonIn (..), InputIn (..), - InputOut (..), SelectIn (..), - SelectOut (..)) -import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.WaitFor as WaitFor +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Time +import qualified Data.Validation as V +import Reflex.Dom (Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R +import qualified Text.Read as T + +import Common.Model (Category (..), CreatePayment (..), + Frequency (..), Payment (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as Time +import qualified Common.Validation.Payment as PaymentValidation +import Component (ButtonIn (..), InputIn (..), + InputOut (..), SelectIn (..), + SelectOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor data AddIn t = AddIn { _addIn_categories :: [Category] - , _addIn_show :: Event t () + , _addIn_cancel :: Event t () } data AddOut t = AddOut @@ -43,48 +46,84 @@ view addIn = do R.divClass "addContent" $ do rec + let reset = R.leftmost + [ const "" <$> cancel + , const "" <$> addedPayment + , const "" <$> _addIn_cancel addIn + ] + name <- _inputOut_value <$> (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) - (const () <$ addedPayment)) + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Name + , _inputIn_validation = PaymentValidation.name + }) + reset + validate) cost <- _inputOut_value <$> (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) - (const () <$ addedPayment)) + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Cost + , _inputIn_validation = PaymentValidation.cost + }) + reset + validate) - currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + currentDay <- do + d <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + return . T.pack . Calendar.showGregorian $ d date <- _inputOut_value <$> (Component.input (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Date - , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay + , _inputIn_initialValue = currentDay , _inputIn_inputType = "date" , _inputIn_hasResetButton = False + , _inputIn_validation = PaymentValidation.date }) - (const () <$ addedPayment)) + (const currentDay <$> reset) + validate) frequency <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Frequency , _selectIn_initialValue = Punctual , _selectIn_values = R.constDyn frequencies - , _selectIn_reset = _addIn_show addIn + , _selectIn_reset = reset + , _selectIn_isValid = const True + , _selectIn_validate = validate }) category <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Category - , _selectIn_initialValue = 0 + , _selectIn_initialValue = -1 , _selectIn_values = R.constDyn categories - , _selectIn_reset = _addIn_show addIn + , _selectIn_reset = reset + , _selectIn_isValid = \id -> id /= -1 + , _selectIn_validate = validate }) - let payment = CreatePayment - <$> name - <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost - <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date - <*> category - <*> frequency - - (addedPayment, cancel) <- R.divClass "buttons" $ do + let payment = do + n <- name + c <- cost + d <- date + cat <- category + f <- frequency + pure $ do + n' <- n + c' <- c + d' <- d + pure $ CreatePayment + <$> ValidationUtil.nelError n' + <*> ValidationUtil.nelError c' + <*> ValidationUtil.nelError d' + <*> ValidationUtil.nelError (V.Success cat) + <*> ValidationUtil.nelError (V.Success f) + + (addedPayment, cancel, validate) <- R.divClass "buttons" $ do rec + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + validate <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) { _buttonIn_class = R.constDyn "confirm" @@ -94,13 +133,9 @@ view addIn = do (result, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") - (R.tag (R.current payment) validate) - - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) + (ValidationUtil.fireValidation payment validate) - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel, validate) return AddOut { _addOut_cancel = cancel diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 6fbaecf..56441eb 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -97,18 +97,19 @@ payerAndAdd incomes payments users categories currency = do , _buttonIn_submit = False }) rec - modalOut <- fmap _modalOut_content . Component.modal $ ModalIn + modalOut <- Component.modal $ ModalIn { _modalIn_show = addPaymentClic , _modalIn_hide = R.leftmost $ - [ _addOut_cancel modalOut - , fmap (const ()) . _addOut_addedPayment $ modalOut + [ _addOut_cancel addOut + , fmap (const ()) . _addOut_addedPayment $ addOut ] , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories - , _addIn_show = addPaymentClic + , _addIn_cancel = _modalOut_hide modalOut } } - return (_addOut_addedPayment modalOut) + let addOut = _modalOut_content modalOut + return (_addOut_addedPayment addOut) searchLine :: forall t m. MonadWidget t m @@ -116,9 +117,10 @@ searchLine -> m (Dynamic t Text, Dynamic t Frequency) searchLine reset = do R.divClass "searchLine" $ do - searchName <- _inputOut_value <$> (Component.input + searchName <- _inputOut_raw <$> (Component.input ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name }) - reset) + (const "" <$> reset) + R.never) let frequencies = M.fromList [ (Punctual, Msg.get Msg.Payment_PunctualMale) diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index 57d67ac..cbe7b50 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -47,7 +47,7 @@ pageButtons total perPage reset = do , pageClic , nextPageClic , lastPageClic - , (const 1) <$> reset + , 1 <$ reset ] firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 428997e..6fbf6d6 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -3,20 +3,24 @@ module View.SignIn , view ) where -import qualified Data.Either as Either -import Data.Text (Text) -import Prelude hiding (error) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Either as Either +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import Data.Validation (Validation) +import Prelude hiding (error) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (SignIn (SignIn)) -import qualified Common.Msg as Msg +import Common.Model (SignInForm (SignInForm)) +import qualified Common.Msg as Msg +import qualified Common.Validation.SignIn as SignInValidation -import Component (ButtonIn (..), ButtonOut (..), InputIn (..), - InputOut (..)) -import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.WaitFor as WaitFor +import Component (ButtonIn (..), ButtonOut (..), + InputIn (..), InputOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor data SignInMessage = SuccessMessage Text @@ -29,19 +33,27 @@ view signInMessage = Component.form $ do rec input <- (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.SignIn_EmailLabel }) - (R.ffilter Either.isRight signInResult)) + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.SignIn_EmailLabel + , _inputIn_validation = SignInValidation.email + }) + (const "" <$> R.ffilter Either.isRight signInResult) + validate) - button <- Component.button $ + validate <- _buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button)) { _buttonIn_class = R.constDyn "validate" , _buttonIn_waiting = waiting , _buttonIn_submit = True - } + }) + + let form = SignInForm <$> _inputOut_raw input (signInResult, waiting) <- WaitFor.waitFor - (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email)) - (R.tag (R.current (_inputOut_value input)) (_buttonOut_clic button)) + (Ajax.postJson "/askSignIn") + (ValidationUtil.fireMaybe + ((\f -> const f <$> SignInValidation.signIn f) <$> form) + validate) showSignInResult signInMessage signInResult -- cgit v1.2.3 From bc81084933f8ec1bfe6c2834defd12243117fdd9 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 5 Aug 2019 21:53:30 +0200 Subject: Use updated payment categories from payment add in payment’s table --- client/src/Component/Input.hs | 4 ++-- client/src/View/Payment.hs | 30 +++++++++++++++++++++++------- client/src/View/Payment/Add.hs | 22 +++++++++++++--------- client/src/View/Payment/Header.hs | 22 +++++++++++----------- client/src/View/Payment/Table.hs | 31 +++++++++++++++++-------------- 5 files changed, 66 insertions(+), 43 deletions(-) (limited to 'client') diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 67f97c0..d679f9b 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -53,7 +53,7 @@ input input inputIn reset validate = do rec let resetValue = R.leftmost - [ R.traceEvent "reset" reset + [ reset , fmap (const "") resetClic ] @@ -83,7 +83,7 @@ input inputIn reset validate = do [ const (False, True) <$> resetClic , (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput) , const (False, False) <$> validate - , const (True, False) <$> R.traceEvent "delayedReset" delayedReset + , const (True, False) <$> delayedReset ]) (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 007471d..f614936 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -10,7 +10,8 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Frequency, Init (..), Payment (..), +import Common.Model (CreatedPayment (..), Frequency, Init (..), + Payment (..), PaymentCategory (..), PaymentId) import qualified Common.Util.Text as T import View.Payment.Header (HeaderIn (..), HeaderOut (..)) @@ -37,8 +38,12 @@ widget paymentIn = do payments <- getPayments (_init_payments init) - (_headerOut_addedPayment header) - (_tableOut_deletedPayment table) + (_createdPayment_payment <$> _headerOut_addPayment header) + (_tableOut_deletePayment table) + + paymentCategories <- getPaymentCategories + (_init_paymentCategories init) + (_createdPayment_paymentCategory <$> _headerOut_addPayment header) let searchPayments = getSearchPayments @@ -56,6 +61,7 @@ widget paymentIn = do , _tableIn_currentPage = _pagesOut_currentPage pages , _tableIn_payments = searchPayments , _tableIn_perPage = paymentsPerPage + , _tableIn_paymentCategories = paymentCategories } pages <- Pages.widget $ PagesIn @@ -63,7 +69,7 @@ widget paymentIn = do , _pagesIn_perPage = paymentsPerPage , _pagesIn_reset = R.leftmost $ [ fmap (const ()) . R.updated . _headerOut_searchName $ header - , fmap (const ()) . _headerOut_addedPayment $ header + , fmap (const ()) . _headerOut_addPayment $ header ] } @@ -75,10 +81,20 @@ getPayments -> Event t Payment -> Event t PaymentId -> m (Dynamic t [Payment]) -getPayments initPayments addedPayment deletedPayment = +getPayments initPayments addPayment deletePayment = R.foldDyn id initPayments $ R.leftmost - [ flip fmap addedPayment (:) - , flip fmap deletedPayment (\paymentId -> filter ((/= paymentId) . _payment_id)) + [ (:) <$> addPayment + , flip fmap deletePayment (\paymentId -> filter ((/= paymentId) . _payment_id)) + ] + +getPaymentCategories + :: forall t m. MonadWidget t m + => [PaymentCategory] + -> Event t PaymentCategory + -> m (Dynamic t [PaymentCategory]) +getPaymentCategories initPaymentCategories addPaymentCategory = + R.foldDyn id initPaymentCategories $ R.leftmost + [ (:) <$> addPaymentCategory ] getSearchPayments diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 62b26a3..2970394 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -16,7 +16,8 @@ import qualified Reflex.Dom as R import qualified Text.Read as T import Common.Model (Category (..), CreatePayment (..), - Frequency (..), Payment (..)) + CreatedPayment (..), Frequency (..), + Payment (..), PaymentCategory (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as Time import qualified Common.Validation.Payment as PaymentValidation @@ -35,8 +36,9 @@ data AddIn t = AddIn } data AddOut t = AddOut - { _addOut_cancel :: Event t () - , _addOut_addedPayment :: Event t Payment + { _addOut_cancel :: Event t () + , _addOut_addPayment :: Event t CreatedPayment + , _addOut_addPaymentCategory :: Event t PaymentCategory } view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t) @@ -48,7 +50,7 @@ view addIn = do rec let reset = R.leftmost [ const "" <$> cancel - , const "" <$> addedPayment + , const "" <$> addPayment , const "" <$> _addIn_cancel addIn ] @@ -68,8 +70,10 @@ view addIn = do reset validate) + now <- liftIO Time.getCurrentTime + currentDay <- do - d <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + d <- liftIO $ Time.timeToDay now return . T.pack . Calendar.showGregorian $ d date <- _inputOut_value <$> (Component.input @@ -118,7 +122,7 @@ view addIn = do <*> ValidationUtil.nelError (V.Success cat) <*> ValidationUtil.nelError (V.Success f) - (addedPayment, cancel, validate) <- R.divClass "buttons" $ do + (addPayment, cancel, validate) <- R.divClass "buttons" $ do rec cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) @@ -131,15 +135,15 @@ view addIn = do , _buttonIn_submit = True }) - (result, waiting) <- WaitFor.waitFor + (addPayment, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") (ValidationUtil.fireValidation payment validate) - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel, validate) + return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, validate) return AddOut { _addOut_cancel = cancel - , _addOut_addedPayment = addedPayment + , _addOut_addPayment = addPayment } where diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 56441eb..c49b284 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -17,10 +17,10 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Category, Currency, - ExceedingPayer (..), Frequency (..), - Income (..), Init (..), Payment (..), - User (..)) +import Common.Model (Category, CreatedPayment (..), + Currency, ExceedingPayer (..), + Frequency (..), Income (..), Init (..), + Payment (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -41,14 +41,14 @@ data HeaderIn t = HeaderIn data HeaderOut t = HeaderOut { _headerOut_searchName :: Dynamic t Text , _headerOut_searchFrequency :: Dynamic t Frequency - , _headerOut_addedPayment :: Event t Payment + , _headerOut_addPayment :: Event t CreatedPayment } widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - addedPayment <- payerAndAdd incomes punctualPayments users categories currency - let resetSearchName = fmap (const ()) $ addedPayment + addPayment <- payerAndAdd incomes punctualPayments users categories currency + let resetSearchName = fmap (const ()) $ addPayment (searchName, searchFrequency) <- searchLine resetSearchName infos (_headerIn_searchPayments headerIn) users currency @@ -56,7 +56,7 @@ widget headerIn = return $ HeaderOut { _headerOut_searchName = searchName , _headerOut_searchFrequency = searchFrequency - , _headerOut_addedPayment = addedPayment + , _headerOut_addPayment = addPayment } where init = _headerIn_init headerIn @@ -74,7 +74,7 @@ payerAndAdd -> [User] -> [Category] -> Currency - -> m (Event t Payment) + -> m (Event t CreatedPayment) payerAndAdd incomes payments users categories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do @@ -101,7 +101,7 @@ payerAndAdd incomes payments users categories currency = do { _modalIn_show = addPaymentClic , _modalIn_hide = R.leftmost $ [ _addOut_cancel addOut - , fmap (const ()) . _addOut_addedPayment $ addOut + , fmap (const ()) . _addOut_addPayment $ addOut ] , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories @@ -109,7 +109,7 @@ payerAndAdd incomes payments users categories currency = do } } let addOut = _modalOut_content modalOut - return (_addOut_addedPayment addOut) + return (_addOut_addPayment addOut) searchLine :: forall t m. MonadWidget t m diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index ba16bf5..6432274 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -29,21 +29,22 @@ import qualified Icon import qualified Util.Dom as Dom data TableIn t = TableIn - { _tableIn_init :: Init - , _tableIn_currentPage :: Dynamic t Int - , _tableIn_payments :: Dynamic t [Payment] - , _tableIn_perPage :: Int + { _tableIn_init :: Init + , _tableIn_currentPage :: Dynamic t Int + , _tableIn_payments :: Dynamic t [Payment] + , _tableIn_perPage :: Int + , _tableIn_paymentCategories :: Dynamic t [PaymentCategory] } data TableOut t = TableOut - { _tableOut_deletedPayment :: Event t PaymentId + { _tableOut_deletePayment :: Event t PaymentId } widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) widget tableIn = do R.divClass "table" $ do - deletedPayment <- R.divClass "lines" $ do + deletePayment <- R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost @@ -53,13 +54,14 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init)) + (R.switch . R.current . fmap R.leftmost) <$> + (R.simpleList paymentRange (paymentRow init paymentCategories)) Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty return $ TableOut - { _tableOut_deletedPayment = deletedPayment + { _tableOut_deletePayment = deletePayment } where @@ -67,6 +69,7 @@ widget tableIn = do currentPage = _tableIn_currentPage tableIn payments = _tableIn_payments tableIn paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage + paymentCategories = _tableIn_paymentCategories tableIn getPaymentRange :: Int -> [Payment] -> Int -> [Payment] getPaymentRange perPage payments currentPage = @@ -76,8 +79,8 @@ getPaymentRange perPage payments currentPage = . L.sortOn _payment_date $ payments -paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m (Event t PaymentId) -paymentRow init payment = +paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment -> m (Event t PaymentId) +paymentRow init paymentCategories payment = R.divClass "row" $ do R.divClass "cell name" . R.dynText . fmap _payment_name $ payment R.divClass "cell cost" . R.dynText . fmap (Format.price (_init_currency init) . _payment_cost) $ payment @@ -88,10 +91,10 @@ paymentRow init payment = Just u -> _user_name u _ -> "" - let category = flip fmap payment $ \p -> findCategory - (_init_categories init) - (_init_paymentCategories init) - (_payment_name p) + let category = do + p <- payment + pcs <- paymentCategories + return $ findCategory (_init_categories init) pcs (_payment_name p) R.divClass "cell category" $ do let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of Just c -> M.fromList -- cgit v1.2.3 From fc8be14dd0089eb12b78af7aaaecd8ed57896677 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 7 Aug 2019 21:27:59 +0200 Subject: Update category according to payment in add overlay --- client/src/Component/Select.hs | 8 +++++- client/src/Util/Validation.hs | 9 +++++-- client/src/View/Payment.hs | 1 + client/src/View/Payment/Add.hs | 33 ++++++++++++++++++----- client/src/View/Payment/Delete.hs | 9 ++++--- client/src/View/Payment/Header.hs | 15 +++++++---- client/src/View/Payment/Table.hs | 57 ++++++++++++++++++++++++++++----------- 7 files changed, 97 insertions(+), 35 deletions(-) (limited to 'client') diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 9f671d3..43a8a6e 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -16,6 +16,7 @@ import qualified Common.Msg as Msg data (Reflex t) => SelectIn t a b c = SelectIn { _selectIn_label :: Text , _selectIn_initialValue :: a + , _selectIn_value :: Event t a , _selectIn_values :: Dynamic t (Map a Text) , _selectIn_reset :: Event t b , _selectIn_isValid :: a -> Bool @@ -48,11 +49,16 @@ select selectIn = do let initialValue = _selectIn_initialValue selectIn + let setValue = R.leftmost + [ const initialValue <$> (_selectIn_reset selectIn) + , _selectIn_value selectIn + ] + value <- R._dropdown_value <$> R.dropdown initialValue (_selectIn_values selectIn) - (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) }) + (R.def { R._dropdownConfig_setValue = setValue }) errorMessage <- R.holdDyn "" $ R.attachWith (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!") diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs index e2a3dcb..fc13f36 100644 --- a/client/src/Util/Validation.hs +++ b/client/src/Util/Validation.hs @@ -1,7 +1,8 @@ module Util.Validation - ( fireValidation + ( nelError + , toMaybe + , fireValidation , fireMaybe - , nelError ) where import Control.Monad (join) @@ -16,6 +17,10 @@ import qualified Reflex.Dom as R nelError :: Validation a b -> Validation (NonEmpty a) b nelError = Validation.validation (Failure . NEL.fromList . (:[])) Success +toMaybe :: Validation a b -> Maybe b +toMaybe (Success s) = Just s +toMaybe (Failure _) = Nothing + fireValidation :: forall t a b c. Reflex t => Dynamic t (Maybe (Validation a b)) diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f614936..05eedab 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -54,6 +54,7 @@ widget paymentIn = do header <- Header.widget $ HeaderIn { _headerIn_init = init , _headerIn_searchPayments = searchPayments + , _headerIn_paymentCategories = paymentCategories } table <- Table.widget $ TableIn diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 2970394..d023613 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -4,21 +4,26 @@ module View.Payment.Add , AddOut(..) ) where +import Control.Monad (join) import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L import qualified Data.Map as M import qualified Data.Maybe as Maybe +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Time import qualified Data.Validation as V -import Reflex.Dom (Event, MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R import qualified Text.Read as T -import Common.Model (Category (..), CreatePayment (..), +import Common.Model (Category (..), CategoryId, + CreatePayment (..), CreatedPayment (..), Frequency (..), Payment (..), PaymentCategory (..)) import qualified Common.Msg as Msg +import qualified Common.Util.Text as Text import qualified Common.Util.Time as Time import qualified Common.Validation.Payment as PaymentValidation import Component (ButtonIn (..), InputIn (..), @@ -31,8 +36,9 @@ import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor data AddIn t = AddIn - { _addIn_categories :: [Category] - , _addIn_cancel :: Event t () + { _addIn_categories :: [Category] + , _addIn_paymentCategories :: Dynamic t [PaymentCategory] + , _addIn_cancel :: Event t () } data AddOut t = AddOut @@ -54,13 +60,13 @@ view addIn = do , const "" <$> _addIn_cancel addIn ] - name <- _inputOut_value <$> (Component.input + name <- Component.input (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name , _inputIn_validation = PaymentValidation.name }) reset - validate) + validate cost <- _inputOut_value <$> (Component.input (Component.defaultInputIn @@ -90,15 +96,22 @@ view addIn = do frequency <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Frequency , _selectIn_initialValue = Punctual + , _selectIn_value = R.never , _selectIn_values = R.constDyn frequencies , _selectIn_reset = reset , _selectIn_isValid = const True , _selectIn_validate = validate }) + let setCategory = + R.fmapMaybe id + . R.updated + $ findCategory <$> (_inputOut_raw name) <*> (_addIn_paymentCategories addIn) + category <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Category , _selectIn_initialValue = -1 + , _selectIn_value = setCategory , _selectIn_values = R.constDyn categories , _selectIn_reset = reset , _selectIn_isValid = \id -> id /= -1 @@ -106,7 +119,7 @@ view addIn = do }) let payment = do - n <- name + n <- _inputOut_value name c <- cost d <- date cat <- category @@ -154,3 +167,9 @@ view addIn = do categories = M.fromList . flip map (_addIn_categories addIn) $ \c -> (_category_id c, _category_name c) + + +findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId +findCategory paymentName = + fmap _paymentCategory_category + . L.find ((==) (Text.formatSearch paymentName) . _paymentCategory_name) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 81c7c57..4aa10f3 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -34,6 +34,11 @@ view deleteIn = R.divClass "deleteContent" $ do (deletedPayment, cancel) <- R.divClass "buttons" $ do + + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + rec confirm <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) @@ -50,10 +55,6 @@ view deleteIn = (Ajax.delete url) confirm - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) return DeleteOut diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index c49b284..5cc362a 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -20,7 +20,8 @@ import qualified Reflex.Dom as R import Common.Model (Category, CreatedPayment (..), Currency, ExceedingPayer (..), Frequency (..), Income (..), Init (..), - Payment (..), User (..)) + Payment (..), PaymentCategory, + User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -34,8 +35,9 @@ import View.Payment.Add (AddIn (..), AddOut (..)) import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn - { _headerIn_init :: Init - , _headerIn_searchPayments :: Dynamic t [Payment] + { _headerIn_init :: Init + , _headerIn_searchPayments :: Dynamic t [Payment] + , _headerIn_paymentCategories :: Dynamic t [PaymentCategory] } data HeaderOut t = HeaderOut @@ -47,7 +49,7 @@ data HeaderOut t = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - addPayment <- payerAndAdd incomes punctualPayments users categories currency + addPayment <- payerAndAdd incomes punctualPayments users categories paymentCategories currency let resetSearchName = fmap (const ()) $ addPayment (searchName, searchFrequency) <- searchLine resetSearchName @@ -66,6 +68,7 @@ widget headerIn = users = _init_users init categories = _init_categories init currency = _init_currency init + paymentCategories = _headerIn_paymentCategories headerIn payerAndAdd :: forall t m. MonadWidget t m @@ -73,9 +76,10 @@ payerAndAdd -> [Payment] -> [User] -> [Category] + -> Dynamic t [PaymentCategory] -> Currency -> m (Event t CreatedPayment) -payerAndAdd incomes payments users categories currency = do +payerAndAdd incomes payments users categories paymentCategories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do R.divClass "exceedingPayers" $ @@ -105,6 +109,7 @@ payerAndAdd incomes payments users categories currency = do ] , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories + , _addIn_paymentCategories = paymentCategories , _addIn_cancel = _modalOut_hide modalOut } } diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 6432274..cdc4bb3 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -26,7 +26,7 @@ import View.Payment.Delete (DeleteIn (..), DeleteOut (..)) import qualified View.Payment.Delete as Delete import qualified Icon -import qualified Util.Dom as Dom +import qualified Util.Dom as DomUtil data TableIn t = TableIn { _tableIn_init :: Init @@ -57,7 +57,7 @@ widget tableIn = do (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init paymentCategories)) - Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ + DomUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty return $ TableOut @@ -79,13 +79,24 @@ getPaymentRange perPage payments currentPage = . L.sortOn _payment_date $ payments -paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment -> m (Event t PaymentId) +paymentRow + :: forall t m. MonadWidget t m + => Init + -> Dynamic t [PaymentCategory] + -> Dynamic t Payment + -> m (Event t PaymentId) paymentRow init paymentCategories payment = R.divClass "row" $ do - R.divClass "cell name" . R.dynText . fmap _payment_name $ payment - R.divClass "cell cost" . R.dynText . fmap (Format.price (_init_currency init) . _payment_cost) $ payment - let user = flip fmap payment $ \p -> CM.findUser (_payment_user p) (_init_users init) + R.divClass "cell name" $ + R.dynText $ fmap _payment_name payment + + R.divClass "cell cost" $ + R.dynText $ fmap (Format.price (_init_currency init) . _payment_cost) payment + + let user = R.ffor payment (\p -> + CM.findUser (_payment_user p) (_init_users init)) + R.divClass "cell user" $ R.dynText $ flip fmap user $ \mbUser -> case mbUser of Just u -> _user_name u @@ -95,13 +106,16 @@ paymentRow init paymentCategories payment = p <- payment pcs <- paymentCategories return $ findCategory (_init_categories init) pcs (_payment_name p) + R.divClass "cell category" $ do + let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of Just c -> M.fromList [ ("class", "tag") , ("style", T.concat [ "background-color: ", _category_color c ]) ] Nothing -> M.singleton "display" "none" + R.elDynAttr "span" attrs $ R.dynText $ flip fmap category $ \mbCategory -> case mbCategory of Just c -> _category_name c @@ -110,15 +124,26 @@ paymentRow init paymentCategories payment = R.divClass "cell date" $ do R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment - R.divClass "cell button" . R.el "button" $ Icon.clone - let modifyAttrs = flip fmap payment $ \p -> - M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")] - R.elDynAttr "div" modifyAttrs $ - R.el "button" $ Icon.edit - deletePayment <- R.elDynAttr "div" modifyAttrs $ - _buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn Icon.delete) - { _buttonIn_class = R.constDyn "deletePayment" }) + + R.divClass "cell button" $ + R.el "button" Icon.clone + + let isFromCurrentUser = + R.ffor + payment + (\p -> _payment_user p == _init_currentUser init) + + R.divClass "cell button" $ + DomUtil.divVisibleIf isFromCurrentUser $ + R.el "button" Icon.edit + + deletePayment <- + R.divClass "cell button" $ + DomUtil.divVisibleIf isFromCurrentUser $ + _buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn Icon.delete) + { _buttonIn_class = R.constDyn "deletePayment" }) + rec modalOut <- Component.modal $ ModalIn { _modalIn_show = deletePayment @@ -133,6 +158,6 @@ paymentRow init paymentCategories payment = findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do paymentCategory <- L.find - ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name) + ((== T.formatSearch paymentName) . _paymentCategory_name) paymentCategories L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories -- cgit v1.2.3 From 7c77e52faa71e43324087903c905f9d493b1dfb7 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 8 Aug 2019 21:28:22 +0200 Subject: Finish payment add modal --- client/src/Component/Input.hs | 69 ++++++++++++++++++++++++++------------- client/src/Component/Select.hs | 54 ++++++++++++++++-------------- client/src/Util/Validation.hs | 9 +++-- client/src/View/Payment.hs | 1 + client/src/View/Payment/Add.hs | 36 +++++++++----------- client/src/View/Payment/Header.hs | 34 +++++++++++-------- 6 files changed, 121 insertions(+), 82 deletions(-) (limited to 'client') diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index d679f9b..abdc51c 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -40,7 +40,7 @@ defaultInputIn = InputIn data InputOut t a = InputOut { _inputOut_raw :: Dynamic t Text - , _inputOut_value :: Dynamic t (Maybe (Validation Text a)) + , _inputOut_value :: Dynamic t (Validation Text a) , _inputOut_enter :: Event t () } @@ -64,27 +64,14 @@ input inputIn reset validate = do value = R._textInput_value textInput - containerAttr = R.ffor validatedValue (\v -> + containerAttr = R.ffor inputError (\e -> M.singleton "class" $ T.intercalate " " [ "textInput" - , if Maybe.fromMaybe False (ValidationUtil.isFailure <$> v) then "error" else "" + , if Maybe.isJust e then "error" else "" ]) - -- Clear validation errors after reset - delayedReset <- R.delay (0.1 :: NominalDiffTime) reset - - validatedValue <- R.holdDyn Nothing $ R.attachWith - (\v (clearValidation, validateEmpty) -> - if clearValidation - then Nothing - else Just (_inputIn_validation inputIn $ (if validateEmpty then "" else v))) - (R.current value) - (R.leftmost - [ const (False, True) <$> resetClic - , (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput) - , const (False, False) <$> validate - , const (True, False) <$> delayedReset - ]) + let valueWithValidation = R.ffor value (\v -> (v, _inputIn_validation inputIn $ v)) + inputError <- getInputError valueWithValidation validate (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do @@ -108,7 +95,7 @@ input inputIn reset validate = do return R.never R.divClass "errorMessage" $ - R.dynText . fmap validationError $ validatedValue + R.dynText . fmap (Maybe.fromMaybe "") $ inputError return (textInput, resetClic) @@ -116,10 +103,46 @@ input inputIn reset validate = do return $ InputOut { _inputOut_raw = value - , _inputOut_value = validatedValue + , _inputOut_value = fmap snd valueWithValidation , _inputOut_enter = enter } -validationError :: Maybe (Validation Text a) -> Text -validationError (Just (Failure e)) = e -validationError _ = "" +getInputError + :: forall t m a b c. MonadWidget t m + => Dynamic t (Text, Validation Text a) + -> Event t c + -> m (Dynamic t (Maybe Text)) +getInputError validatedValue validate = do + let errorDynamic = fmap (\(t, v) -> (t, validationError v)) validatedValue + errorEvent = R.updated errorDynamic + delayedError <- R.debounce (1 :: NominalDiffTime) errorEvent + fmap (fmap fst) $ R.foldDyn + (\event (err, hasBeenResetted) -> + case event of + ModifiedEvent t -> + (Nothing, T.null t) + + ValidateEvent e -> + (e, False) + + DelayEvent e -> + if hasBeenResetted then + (Nothing, False) + else + (e, False) + ) + (Nothing, False) + (R.leftmost + [ fmap (\(t, _) -> ModifiedEvent t) errorEvent + , fmap (\(_, e) -> DelayEvent e) delayedError + , R.attachWith (\(_, e) _ -> ValidateEvent e) (R.current errorDynamic) validate + ]) + +validationError :: (Validation Text a) -> Maybe Text +validationError (Failure e) = Just e +validationError _ = Nothing + +data InputEvent + = ModifiedEvent Text + | DelayEvent (Maybe Text) + | ValidateEvent (Maybe Text) diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 43a8a6e..01ed37a 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -4,14 +4,17 @@ module Component.Select , select ) where -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Validation (Validation (Failure, Success)) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R -import qualified Common.Msg as Msg +import qualified Common.Msg as Msg +import qualified Util.Validation as ValidationUtil data (Reflex t) => SelectIn t a b c = SelectIn { _selectIn_label :: Text @@ -24,25 +27,33 @@ data (Reflex t) => SelectIn t a b c = SelectIn } data SelectOut t a = SelectOut - { _selectOut_value :: Dynamic t a + { _selectOut_value :: Dynamic t (Validation Text a) } select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a) select selectIn = do rec - let containerAttr = R.ffor hasError (\e -> + let containerAttr = R.ffor showedError (\e -> M.singleton "class" $ T.intercalate " " [ "selectInput" - , if e then "error" else "" + , if Maybe.isJust e then "error" else "" ]) - hasError <- R.holdDyn False $ R.attachWith - (\v clearError -> not clearError && not (_selectIn_isValid selectIn v)) - (R.current value) - (R.leftmost - [ const False <$> _selectIn_validate selectIn - , const True <$> _selectIn_reset selectIn - ]) + validatedValue = + R.ffor value (\v -> + if _selectIn_isValid selectIn v then + Success v + else + Failure (Msg.get Msg.Form_NonEmpty)) + + maybeError = + fmap ValidationUtil.maybeError validatedValue + + showedError <- R.holdDyn Nothing $ R.leftmost + [ const Nothing <$> _selectIn_reset selectIn + , R.updated maybeError + , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn) + ] value <- R.elDynAttr "div" containerAttr $ do R.el "label" $ R.text (_selectIn_label selectIn) @@ -60,16 +71,11 @@ select selectIn = do (_selectIn_values selectIn) (R.def { R._dropdownConfig_setValue = setValue }) - errorMessage <- R.holdDyn "" $ R.attachWith - (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!") - (R.current value) - (_selectIn_validate selectIn) - R.divClass "errorMessage" . R.dynText $ - R.ffor hasError (\e -> if e then Msg.get Msg.Form_NonEmpty else "") + R.ffor showedError (Maybe.fromMaybe "") return value return SelectOut - { _selectOut_value = value + { _selectOut_value = validatedValue } diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs index fc13f36..f9545a4 100644 --- a/client/src/Util/Validation.hs +++ b/client/src/Util/Validation.hs @@ -1,6 +1,7 @@ module Util.Validation ( nelError , toMaybe + , maybeError , fireValidation , fireMaybe ) where @@ -21,14 +22,18 @@ toMaybe :: Validation a b -> Maybe b toMaybe (Success s) = Just s toMaybe (Failure _) = Nothing +maybeError :: Validation a b -> Maybe a +maybeError (Success _) = Nothing +maybeError (Failure e) = Just e + fireValidation :: forall t a b c. Reflex t - => Dynamic t (Maybe (Validation a b)) + => Dynamic t (Validation a b) -> Event t c -> Event t b fireValidation value validate = R.fmapMaybe - (join . fmap (Validation.validation (const Nothing) Just)) + (Validation.validation (const Nothing) Just) (R.tag (R.current value) validate) fireMaybe diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 05eedab..ae20079 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -53,6 +53,7 @@ widget paymentIn = do header <- Header.widget $ HeaderIn { _headerIn_init = init + , _headerIn_payments = payments , _headerIn_searchPayments = searchPayments , _headerIn_paymentCategories = paymentCategories } diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index d023613..e0772f7 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -66,7 +66,7 @@ view addIn = do , _inputIn_validation = PaymentValidation.name }) reset - validate + confirm cost <- _inputOut_value <$> (Component.input (Component.defaultInputIn @@ -74,7 +74,7 @@ view addIn = do , _inputIn_validation = PaymentValidation.cost }) reset - validate) + confirm) now <- liftIO Time.getCurrentTime @@ -91,7 +91,7 @@ view addIn = do , _inputIn_validation = PaymentValidation.date }) (const currentDay <$> reset) - validate) + confirm) frequency <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Frequency @@ -100,7 +100,7 @@ view addIn = do , _selectIn_values = R.constDyn frequencies , _selectIn_reset = reset , _selectIn_isValid = const True - , _selectIn_validate = validate + , _selectIn_validate = confirm }) let setCategory = @@ -115,7 +115,7 @@ view addIn = do , _selectIn_values = R.constDyn categories , _selectIn_reset = reset , _selectIn_isValid = \id -> id /= -1 - , _selectIn_validate = validate + , _selectIn_validate = confirm }) let payment = do @@ -124,24 +124,20 @@ view addIn = do d <- date cat <- category f <- frequency - pure $ do - n' <- n - c' <- c - d' <- d - pure $ CreatePayment - <$> ValidationUtil.nelError n' - <*> ValidationUtil.nelError c' - <*> ValidationUtil.nelError d' - <*> ValidationUtil.nelError (V.Success cat) - <*> ValidationUtil.nelError (V.Success f) - - (addPayment, cancel, validate) <- R.divClass "buttons" $ do + return (CreatePayment + <$> ValidationUtil.nelError n + <*> ValidationUtil.nelError c + <*> ValidationUtil.nelError d + <*> ValidationUtil.nelError cat + <*> ValidationUtil.nelError f) + + (addPayment, cancel, confirm) <- R.divClass "buttons" $ do rec cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) { _buttonIn_class = R.constDyn "undo" }) - validate <- Component._buttonOut_clic <$> (Component.button $ + confirm <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) { _buttonIn_class = R.constDyn "confirm" , _buttonIn_waiting = waiting @@ -150,9 +146,9 @@ view addIn = do (addPayment, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") - (ValidationUtil.fireValidation payment validate) + (ValidationUtil.fireValidation payment confirm) - return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, validate) + return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) return AddOut { _addOut_cancel = cancel diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 5cc362a..73517f0 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -36,6 +36,7 @@ import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn { _headerIn_init :: Init + , _headerIn_payments :: Dynamic t [Payment] , _headerIn_searchPayments :: Dynamic t [Payment] , _headerIn_paymentCategories :: Dynamic t [PaymentCategory] } @@ -49,7 +50,7 @@ data HeaderOut t = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - addPayment <- payerAndAdd incomes punctualPayments users categories paymentCategories currency + addPayment <- payerAndAdd incomes payments users categories paymentCategories currency let resetSearchName = fmap (const ()) $ addPayment (searchName, searchFrequency) <- searchLine resetSearchName @@ -64,7 +65,7 @@ widget headerIn = init = _headerIn_init headerIn incomes = _init_incomes init initPayments = _init_payments init - punctualPayments = filter ((==) Punctual . _payment_frequency) initPayments + payments = _headerIn_payments headerIn users = _init_users init categories = _init_categories init currency = _init_currency init @@ -73,7 +74,7 @@ widget headerIn = payerAndAdd :: forall t m. MonadWidget t m => [Income] - -> [Payment] + -> Dynamic t [Payment] -> [User] -> [Category] -> Dynamic t [PaymentCategory] @@ -82,17 +83,23 @@ payerAndAdd payerAndAdd incomes payments users categories paymentCategories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do + + let exceedingPayers = + R.ffor payments $ \ps -> + CM.getExceedingPayers time users incomes $ + filter ((==) Punctual . _payment_frequency) ps + R.divClass "exceedingPayers" $ - forM_ - (CM.getExceedingPayers time users incomes payments) - (\p -> - R.elClass "span" "exceedingPayer" $ do - R.elClass "span" "userName" $ - R.text . fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId p) users - R.elClass "span" "amount" $ do - R.text "+ " - R.text . Format.price currency $ _exceedingPayer_amount p - ) + R.simpleList exceedingPayers $ \exceedingPayer -> + R.elClass "span" "exceedingPayer" $ do + R.elClass "span" "userName" $ + R.dynText . R.ffor exceedingPayer $ \ep -> + fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users + R.elClass "span" "amount" $ do + R.text "+ " + R.dynText . R.ffor exceedingPayer $ \ep -> + Format.price currency $ _exceedingPayer_amount ep + addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn { _buttonIn_class = R.constDyn "addPayment" , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add @@ -100,6 +107,7 @@ payerAndAdd incomes payments users categories paymentCategories currency = do , _buttonIn_tabIndex = Nothing , _buttonIn_submit = False }) + rec modalOut <- Component.modal $ ModalIn { _modalIn_show = addPaymentClic -- cgit v1.2.3 From 3943c50d5320f7137bd5acec4485dd56a2aa52b3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 09:59:22 +0200 Subject: Debounce payments search --- client/src/View/Payment.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) (limited to 'client') diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index ae20079..915cc18 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -6,6 +6,7 @@ module View.Payment import Data.Text (Text) import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R @@ -47,10 +48,16 @@ widget paymentIn = do let searchPayments = getSearchPayments - (_headerOut_searchName header) + debouncedSearchName (_headerOut_searchFrequency header) payments + debouncedSearchNameEvt <- + R.debounce (0.5 :: NominalDiffTime) (R.updated $ _headerOut_searchName header) + + debouncedSearchName <- + R.holdDyn "" debouncedSearchNameEvt + header <- Header.widget $ HeaderIn { _headerIn_init = init , _headerIn_payments = payments @@ -70,8 +77,8 @@ widget paymentIn = do { _pagesIn_total = length <$> searchPayments , _pagesIn_perPage = paymentsPerPage , _pagesIn_reset = R.leftmost $ - [ fmap (const ()) . R.updated . _headerOut_searchName $ header - , fmap (const ()) . _headerOut_addPayment $ header + [ const () <$> debouncedSearchNameEvt + , const () <$> _headerOut_addPayment header ] } -- cgit v1.2.3 From fb8f0fe577e28dae69903413b761da50586e0099 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 14:53:41 +0200 Subject: Remove payment category if unused after a payment is deleted --- client/src/View/Payment.hs | 49 +++++++++++++++++++++++++++------------ client/src/View/Payment/Add.hs | 3 +-- client/src/View/Payment/Delete.hs | 35 ++++++++++++++-------------- client/src/View/Payment/Table.hs | 12 ++++------ 4 files changed, 58 insertions(+), 41 deletions(-) (limited to 'client') diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 915cc18..46ab642 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -45,18 +45,14 @@ widget paymentIn = do paymentCategories <- getPaymentCategories (_init_paymentCategories init) (_createdPayment_paymentCategory <$> _headerOut_addPayment header) + payments + (_tableOut_deletePayment table) - let searchPayments = - getSearchPayments - debouncedSearchName - (_headerOut_searchFrequency header) - payments - - debouncedSearchNameEvt <- - R.debounce (0.5 :: NominalDiffTime) (R.updated $ _headerOut_searchName header) + (searchNameEvent, searchName) <- + debounceSearchName (_headerOut_searchName header) - debouncedSearchName <- - R.holdDyn "" debouncedSearchNameEvt + let searchPayments = + getSearchPayments searchName (_headerOut_searchFrequency header) payments header <- Header.widget $ HeaderIn { _headerIn_init = init @@ -77,34 +73,57 @@ widget paymentIn = do { _pagesIn_total = length <$> searchPayments , _pagesIn_perPage = paymentsPerPage , _pagesIn_reset = R.leftmost $ - [ const () <$> debouncedSearchNameEvt + [ const () <$> searchNameEvent , const () <$> _headerOut_addPayment header ] } pure $ PaymentOut {} +debounceSearchName + :: forall t m. MonadWidget t m + => Dynamic t Text + -> m (Event t Text, Dynamic t Text) +debounceSearchName searchName = do + event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) + dynamic <- R.holdDyn "" event + return (event, dynamic) + getPayments :: forall t m. MonadWidget t m => [Payment] -> Event t Payment - -> Event t PaymentId + -> Event t Payment -> m (Dynamic t [Payment]) getPayments initPayments addPayment deletePayment = R.foldDyn id initPayments $ R.leftmost [ (:) <$> addPayment - , flip fmap deletePayment (\paymentId -> filter ((/= paymentId) . _payment_id)) + , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) ] getPaymentCategories :: forall t m. MonadWidget t m => [PaymentCategory] - -> Event t PaymentCategory + -> Event t PaymentCategory -- add payment category + -> Dynamic t [Payment] -- payments + -> Event t Payment -- delete payment -> m (Dynamic t [PaymentCategory]) -getPaymentCategories initPaymentCategories addPaymentCategory = +getPaymentCategories initPaymentCategories addPaymentCategory payments deletePayment = R.foldDyn id initPaymentCategories $ R.leftmost [ (:) <$> addPaymentCategory + , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) ] + where + deletePaymentName = + R.attachWithMaybe + (\ps p -> + if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then + Nothing + else + Just (_payment_name p)) + (R.current payments) + deletePayment + lowerName = T.toLower . _payment_name getSearchPayments :: forall t. Reflex t diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index e0772f7..bd10e5a 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -23,7 +23,6 @@ import Common.Model (Category (..), CategoryId, CreatedPayment (..), Frequency (..), Payment (..), PaymentCategory (..)) import qualified Common.Msg as Msg -import qualified Common.Util.Text as Text import qualified Common.Util.Time as Time import qualified Common.Validation.Payment as PaymentValidation import Component (ButtonIn (..), InputIn (..), @@ -168,4 +167,4 @@ view addIn = do findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId findCategory paymentName = fmap _paymentCategory_category - . L.find ((==) (Text.formatSearch paymentName) . _paymentCategory_name) + . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 4aa10f3..65ce660 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -4,26 +4,26 @@ module View.Payment.Delete , DeleteOut(..) ) where -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model.Payment (PaymentId) -import qualified Common.Msg as Msg -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.WaitFor as WaitFor +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Payment (..)) +import qualified Common.Msg as Msg +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.WaitFor as WaitFor data DeleteIn t = DeleteIn - { _deleteIn_id :: Dynamic t PaymentId + { _deleteIn_payment :: Dynamic t Payment } data DeleteOut t = DeleteOut { _deleteOut_cancel :: Event t () - , _deleteOut_validate :: Event t PaymentId + , _deleteOut_validate :: Event t Payment } view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t) @@ -47,8 +47,9 @@ view deleteIn = , _buttonIn_waiting = waiting }) - let url = flip fmap (_deleteIn_id deleteIn) (\id -> - T.concat ["/payment/", T.pack . show $ id] + let url = + R.ffor (_deleteIn_payment deleteIn) (\id -> + T.concat ["/payment/", T.pack . show $ _payment_id id] ) (result, waiting) <- WaitFor.waitFor @@ -59,5 +60,5 @@ view deleteIn = return DeleteOut { _deleteOut_cancel = cancel - , _deleteOut_validate = R.tag (R.current $ _deleteIn_id deleteIn) deletedPayment + , _deleteOut_validate = R.tag (R.current $ _deleteIn_payment deleteIn) deletedPayment } diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index cdc4bb3..b09f30f 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -13,11 +13,9 @@ import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), PaymentId, - User (..)) + PaymentCategory (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg -import qualified Common.Util.Text as T import qualified Common.View.Format as Format import Component (ButtonIn (..), ButtonOut (..), ModalIn (..), ModalOut (..)) @@ -37,7 +35,7 @@ data TableIn t = TableIn } data TableOut t = TableOut - { _tableOut_deletePayment :: Event t PaymentId + { _tableOut_deletePayment :: Event t Payment } widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) @@ -84,7 +82,7 @@ paymentRow => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment - -> m (Event t PaymentId) + -> m (Event t Payment) paymentRow init paymentCategories payment = R.divClass "row" $ do @@ -151,13 +149,13 @@ paymentRow init paymentCategories payment = [ _deleteOut_cancel . _modalOut_content $ modalOut , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut ] - , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment }) + , _modalIn_content = Delete.view (DeleteIn { _deleteIn_payment = payment }) } return (_deleteOut_validate . _modalOut_content $ modalOut) findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do paymentCategory <- L.find - ((== T.formatSearch paymentName) . _paymentCategory_name) + ((== T.toLower paymentName) . _paymentCategory_name) paymentCategories L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories -- cgit v1.2.3 From 234b5b29361734656dc780148309962f932d9907 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 15:07:11 +0200 Subject: Use select component in payment search line --- client/src/Component/Select.hs | 6 ++++-- client/src/View/Payment/Header.hs | 15 ++++++++++++--- 2 files changed, 16 insertions(+), 5 deletions(-) (limited to 'client') diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 01ed37a..cf62f26 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -27,7 +27,8 @@ data (Reflex t) => SelectIn t a b c = SelectIn } data SelectOut t a = SelectOut - { _selectOut_value :: Dynamic t (Validation Text a) + { _selectOut_raw :: Dynamic t a + , _selectOut_value :: Dynamic t (Validation Text a) } select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a) @@ -77,5 +78,6 @@ select selectIn = do return value return SelectOut - { _selectOut_value = validatedValue + { _selectOut_raw = value + , _selectOut_value = validatedValue } diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 73517f0..7a85493 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -28,7 +28,8 @@ import qualified Common.View.Format as Format import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..), - ModalIn (..), ModalOut (..)) + ModalIn (..), ModalOut (..), + SelectIn (..), SelectOut (..)) import qualified Component as Component import qualified Util.List as L import View.Payment.Add (AddIn (..), AddOut (..)) @@ -140,8 +141,16 @@ searchLine reset = do , (Monthly, Msg.get Msg.Payment_MonthlyMale) ] - searchFrequency <- R._dropdown_value <$> - R.dropdown Punctual (R.constDyn frequencies) R.def + searchFrequency <- _selectOut_raw <$> (Component.select $ + SelectIn + { _selectIn_label = "" + , _selectIn_initialValue = Punctual + , _selectIn_value = R.never + , _selectIn_values = R.constDyn frequencies + , _selectIn_reset = R.never + , _selectIn_isValid = const True + , _selectIn_validate = R.never + }) return (searchName, searchFrequency) -- cgit v1.2.3 From c5c54722f4736108c8418c9865f81f05a6db560d Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 15:29:56 +0200 Subject: Fix payment add frequency to the one selected in the page --- client/src/View/Payment/Add.hs | 15 +++------------ client/src/View/Payment/Header.hs | 23 +++++++++++++++++------ 2 files changed, 20 insertions(+), 18 deletions(-) (limited to 'client') diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index bd10e5a..d2d2dc4 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -37,6 +37,7 @@ import qualified Util.WaitFor as WaitFor data AddIn t = AddIn { _addIn_categories :: [Category] , _addIn_paymentCategories :: Dynamic t [PaymentCategory] + , _addIn_frequency :: Dynamic t Frequency , _addIn_cancel :: Event t () } @@ -92,16 +93,6 @@ view addIn = do (const currentDay <$> reset) confirm) - frequency <- _selectOut_value <$> (Component.select $ SelectIn - { _selectIn_label = Msg.get Msg.Payment_Frequency - , _selectIn_initialValue = Punctual - , _selectIn_value = R.never - , _selectIn_values = R.constDyn frequencies - , _selectIn_reset = reset - , _selectIn_isValid = const True - , _selectIn_validate = confirm - }) - let setCategory = R.fmapMaybe id . R.updated @@ -122,13 +113,13 @@ view addIn = do c <- cost d <- date cat <- category - f <- frequency + f <- _addIn_frequency addIn return (CreatePayment <$> ValidationUtil.nelError n <*> ValidationUtil.nelError c <*> ValidationUtil.nelError d <*> ValidationUtil.nelError cat - <*> ValidationUtil.nelError f) + <*> V.Success f) (addPayment, cancel, confirm) <- R.divClass "buttons" $ do rec diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 7a85493..fa21731 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -51,11 +51,20 @@ data HeaderOut t = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - addPayment <- payerAndAdd incomes payments users categories paymentCategories currency - let resetSearchName = fmap (const ()) $ addPayment - (searchName, searchFrequency) <- searchLine resetSearchName - - infos (_headerIn_searchPayments headerIn) users currency + rec + addPayment <- + payerAndAdd + incomes + payments + users + categories + paymentCategories + currency + searchFrequency + let resetSearchName = fmap (const ()) $ addPayment + (searchName, searchFrequency) <- searchLine resetSearchName + + infos (_headerIn_searchPayments headerIn) users currency return $ HeaderOut { _headerOut_searchName = searchName @@ -80,8 +89,9 @@ payerAndAdd -> [Category] -> Dynamic t [PaymentCategory] -> Currency + -> Dynamic t Frequency -> m (Event t CreatedPayment) -payerAndAdd incomes payments users categories paymentCategories currency = do +payerAndAdd incomes payments users categories paymentCategories currency frequency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do @@ -119,6 +129,7 @@ payerAndAdd incomes payments users categories paymentCategories currency = do , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories , _addIn_paymentCategories = paymentCategories + , _addIn_frequency = frequency , _addIn_cancel = _modalOut_hide modalOut } } -- cgit v1.2.3 From c542424b7b41c78a170763f6996c12f56b359860 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 21:31:27 +0200 Subject: Add smooth transitions to modal show and hide --- client/client.cabal | 1 + client/src/Component/Modal.hs | 79 ++++++++++++++++++++++++++------------- client/src/Component/Select.hs | 4 +- client/src/Util/WaitFor.hs | 2 +- client/src/View/Payment.hs | 4 +- client/src/View/Payment/Add.hs | 8 ++-- client/src/View/Payment/Header.hs | 2 +- client/src/View/SignIn.hs | 4 +- 8 files changed, 65 insertions(+), 39 deletions(-) (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index af71f2d..ce3c059 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -16,6 +16,7 @@ Executable client Default-extensions: ExistentialQuantification + LambdaCase MultiParamTypeClasses OverloadedStrings RecursiveDo diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index d7943a9..fac417e 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -8,6 +8,8 @@ import Control.Monad (void) import qualified Data.Map as M import qualified Data.Map.Lazy as LM import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) import qualified GHCJS.DOM.Element as Element import qualified GHCJS.DOM.Node as Node import JSDOM.Types (JSString) @@ -31,52 +33,75 @@ data ModalOut t a = ModalOut modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut t a) modal modalIn = do rec - let showEvent = R.leftmost - [ True <$ _modalIn_show modalIn - , False <$ _modalIn_hide modalIn - , False <$ curtainClick - ] + let show = Show <$ (_modalIn_show modalIn) - showModal <- R.holdDyn False showEvent + startHiding = + R.attachWithMaybe + (\a _ -> if a then Just StartHiding else Nothing) + (R.current canBeHidden) + (R.leftmost [ _modalIn_hide modalIn, curtainClick ]) + + canBeHidden <- + R.holdDyn True $ R.leftmost + [ False <$ startHiding + , True <$ endHiding + ] + + endHiding <- + R.delay (0.2 :: NominalDiffTime) (EndHiding <$ startHiding) + + let action = + R.leftmost [ show, startHiding, endHiding ] + + modalClass <- + R.holdDyn "" (fmap getModalClass action) (elem, (curtainClick, content)) <- - R.buildElement "div" (getAttributes <$> showModal) $ do - (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank - cont <- R.divClass "modalContent" $ _modalIn_content modalIn - return (R.domEvent R.Click curtain, cont) + R.buildElement "div" (fmap getAttributes modalClass) $ do + (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank + content <- R.divClass "g-Modal__Content" $ _modalIn_content modalIn + return (R.domEvent R.Click curtain, content) - performShowEffects showEvent elem + performShowEffects action elem return $ ModalOut { _modalOut_content = content , _modalOut_hide = curtainClick } -getAttributes :: Bool -> LM.Map Text Text -getAttributes show = - M.fromList $ - [ ("style", if show then "display:block" else "display:none") - , ("class", "modal") - ] +getAttributes :: Text -> LM.Map Text Text +getAttributes modalClass = + M.singleton "class" $ + T.intercalate " " [ "g-Modal", modalClass] performShowEffects :: forall t m a. MonadWidget t m - => Event t Bool + => Event t Action -> Element.Element -> m () performShowEffects showEvent elem = do body <- Dom.getBody let showEffects = - flip fmap showEvent (\show -> do - if show then - do - Node.appendChild body elem - Element.setClassName body ("modal" :: JSString) - else - do - Node.removeChild body elem - Element.setClassName body ("" :: JSString) + flip fmap showEvent (\case + Show -> do + Node.appendChild body elem + Element.setClassName body ("g-Body--Modal" :: JSString) + StartHiding -> + return () + EndHiding -> do + Node.removeChild body elem + Element.setClassName body ("" :: JSString) ) R.performEvent_ $ void `fmap` showEffects + +data Action + = Show + | StartHiding + | EndHiding + +getModalClass :: Action -> Text +getModalClass Show = "g-Modal--Show" +getModalClass StartHiding = "g-Modal--Hiding" +getModalClass _ = "" diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index cf62f26..9a37afc 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -51,7 +51,7 @@ select selectIn = do fmap ValidationUtil.maybeError validatedValue showedError <- R.holdDyn Nothing $ R.leftmost - [ const Nothing <$> _selectIn_reset selectIn + [ Nothing <$ _selectIn_reset selectIn , R.updated maybeError , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn) ] @@ -62,7 +62,7 @@ select selectIn = do let initialValue = _selectIn_initialValue selectIn let setValue = R.leftmost - [ const initialValue <$> (_selectIn_reset selectIn) + [ initialValue <$ (_selectIn_reset selectIn) , _selectIn_value selectIn ] diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs index 02edff5..fe7b733 100644 --- a/client/src/Util/WaitFor.hs +++ b/client/src/Util/WaitFor.hs @@ -13,5 +13,5 @@ waitFor -> m (Event t b, Event t Bool) waitFor op input = do result <- op input >>= R.debounce (0.5 :: NominalDiffTime) - let waiting = R.leftmost [ const True <$> input , const False <$> result ] + let waiting = R.leftmost [ True <$ input , False <$ result ] return (result, waiting) diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 46ab642..f363b06 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -73,8 +73,8 @@ widget paymentIn = do { _pagesIn_total = length <$> searchPayments , _pagesIn_perPage = paymentsPerPage , _pagesIn_reset = R.leftmost $ - [ const () <$> searchNameEvent - , const () <$> _headerOut_addPayment header + [ () <$ searchNameEvent + , () <$ _headerOut_addPayment header ] } diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index d2d2dc4..69e29a7 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -55,9 +55,9 @@ view addIn = do R.divClass "addContent" $ do rec let reset = R.leftmost - [ const "" <$> cancel - , const "" <$> addPayment - , const "" <$> _addIn_cancel addIn + [ "" <$ cancel + , "" <$ addPayment + , "" <$ _addIn_cancel addIn ] name <- Component.input @@ -90,7 +90,7 @@ view addIn = do , _inputIn_hasResetButton = False , _inputIn_validation = PaymentValidation.date }) - (const currentDay <$> reset) + (currentDay <$ reset) confirm) let setCategory = diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index fa21731..1bdee8d 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -144,7 +144,7 @@ searchLine reset = do R.divClass "searchLine" $ do searchName <- _inputOut_raw <$> (Component.input ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name }) - (const "" <$> reset) + ("" <$ reset) R.never) let frequencies = M.fromList diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 6fbf6d6..f8b985f 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -37,7 +37,7 @@ view signInMessage = { _inputIn_label = Msg.get Msg.SignIn_EmailLabel , _inputIn_validation = SignInValidation.email }) - (const "" <$> R.ffilter Either.isRight signInResult) + ("" <$ R.ffilter Either.isRight signInResult) validate) validate <- _buttonOut_clic <$> (Component.button $ @@ -52,7 +52,7 @@ view signInMessage = (signInResult, waiting) <- WaitFor.waitFor (Ajax.postJson "/askSignIn") (ValidationUtil.fireMaybe - ((\f -> const f <$> SignInValidation.signIn f) <$> form) + ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) showSignInResult signInMessage signInResult -- cgit v1.2.3 From 2d79ab0e0a11f55255fc21a5dfab1598d3beeba3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 11 Aug 2019 22:40:09 +0200 Subject: Add payment clone --- client/client.cabal | 5 +- client/src/Component/Modal.hs | 63 +++++++------ client/src/Util/Dom.hs | 45 --------- client/src/Util/Reflex.hs | 52 +++++++++++ client/src/View/Payment.hs | 14 ++- client/src/View/Payment/Add.hs | 187 ++++++++------------------------------ client/src/View/Payment/Clone.hs | 60 ++++++++++++ client/src/View/Payment/Delete.hs | 57 ++++++------ client/src/View/Payment/Edit.hs | 55 +++++++++++ client/src/View/Payment/Form.hs | 165 +++++++++++++++++++++++++++++++++ client/src/View/Payment/Header.hs | 39 +++----- client/src/View/Payment/Pages.hs | 14 +-- client/src/View/Payment/Table.hs | 109 ++++++++++++++++------ 13 files changed, 548 insertions(+), 317 deletions(-) delete mode 100644 client/src/Util/Dom.hs create mode 100644 client/src/Util/Reflex.hs create mode 100644 client/src/View/Payment/Clone.hs create mode 100644 client/src/View/Payment/Edit.hs create mode 100644 client/src/View/Payment/Form.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index ce3c059..5fc20ae 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -44,16 +44,19 @@ Executable client Component.Select Icon Util.Ajax - Util.Dom Util.Either Util.List + Util.Reflex Util.Validation Util.WaitFor View.App View.Header View.Payment View.Payment.Add + View.Payment.Clone View.Payment.Delete + View.Payment.Edit + View.Payment.Form View.Payment.Header View.Payment.Pages View.Payment.Table diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index fac417e..96c2679 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -1,7 +1,7 @@ module Component.Modal - ( ModalIn(..) - , ModalOut(..) - , modal + ( Input(..) + , Content + , view ) where import Control.Monad (void) @@ -17,29 +17,26 @@ import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import qualified Reflex.Dom.Class as R -import qualified Util.Dom as Dom +import qualified Util.Reflex as ReflexUtil -data ModalIn t m a = ModalIn - { _modalIn_show :: Event t () - , _modalIn_hide :: Event t () - , _modalIn_content :: m a - } +-- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent) +type Content t m a = Event t () -> m (Event t (), Event t a) -data ModalOut t a = ModalOut - { _modalOut_content :: a - , _modalOut_hide :: Event t () +data Input t m a = Input + { _input_show :: Event t () + , _input_content :: Content t m a } -modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut t a) -modal modalIn = do +view :: forall t m a. MonadWidget t m => Input t m a -> m (Event t a) +view input = do rec - let show = Show <$ (_modalIn_show modalIn) + let show = Show <$ (_input_show input) startHiding = R.attachWithMaybe (\a _ -> if a then Just StartHiding else Nothing) (R.current canBeHidden) - (R.leftmost [ _modalIn_hide modalIn, curtainClick ]) + (R.leftmost [ hide, curtainClick ]) canBeHidden <- R.holdDyn True $ R.leftmost @@ -56,18 +53,25 @@ modal modalIn = do modalClass <- R.holdDyn "" (fmap getModalClass action) - (elem, (curtainClick, content)) <- - R.buildElement "div" (fmap getAttributes modalClass) $ do - (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank - content <- R.divClass "g-Modal__Content" $ _modalIn_content modalIn - return (R.domEvent R.Click curtain, content) + (elem, dyn) <- + R.buildElement "div" (getAttributes <$> modalClass) $ + ReflexUtil.visibleIfEvent + (isVisible <$> action) + (R.blank >> return (R.never, R.never, R.never)) + (do + (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank + let curtainClick = R.domEvent R.Click curtain + (hide, content) <- R.divClass "g-Modal__Content" (_input_content input curtainClick) + return (curtainClick, hide, content)) + - performShowEffects action elem + performShowEffects action elem - return $ ModalOut - { _modalOut_content = content - , _modalOut_hide = curtainClick - } + let curtainClick = R.switchDyn $ (\(a, _, _) -> a) <$> dyn + let hide = R.switchDyn $ (\(_, b, _) -> b) <$> dyn + let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn + + return content getAttributes :: Text -> LM.Map Text Text getAttributes modalClass = @@ -80,7 +84,7 @@ performShowEffects -> Element.Element -> m () performShowEffects showEvent elem = do - body <- Dom.getBody + body <- ReflexUtil.getBody let showEffects = flip fmap showEvent (\case @@ -105,3 +109,8 @@ getModalClass :: Action -> Text getModalClass Show = "g-Modal--Show" getModalClass StartHiding = "g-Modal--Hiding" getModalClass _ = "" + +isVisible :: Action -> Bool +isVisible Show = True +isVisible StartHiding = True +isVisible EndHiding = False diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs deleted file mode 100644 index 55b8521..0000000 --- a/client/src/Util/Dom.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Util.Dom - ( divIfDyn - , divIfEvent - , divVisibleIf - , divClassVisibleIf - , getBody - ) where - -import qualified Data.Map as M -import Data.Text (Text) -import qualified GHCJS.DOM as Dom -import qualified GHCJS.DOM.Document as Document -import qualified GHCJS.DOM.HTMLCollection as HTMLCollection -import GHCJS.DOM.Types (Element) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -divIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Dynamic t a) -divIfDyn cond = divIfEvent (R.updated cond) - -divIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a) -divIfEvent cond empty content = - R.widgetHold empty (flip fmap cond (\show -> - if show - then - content - else - empty)) - -divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -divVisibleIf cond content = divClassVisibleIf cond "" content - -divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a -divClassVisibleIf cond className content = - R.elDynAttr - "div" - (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond) - content - -getBody :: forall t m. MonadWidget t m => m Element -getBody = do - document <- Dom.currentDocumentUnchecked - nodelist <- Document.getElementsByTagName document ("body" :: String) - Just body <- nodelist `HTMLCollection.item` 0 - return body diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs new file mode 100644 index 0000000..c14feeb --- /dev/null +++ b/client/src/Util/Reflex.hs @@ -0,0 +1,52 @@ +module Util.Reflex + ( visibleIfDyn + , visibleIfEvent + , divVisibleIf + , divClassVisibleIf + , flatten + , getBody + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import qualified GHCJS.DOM as Dom +import qualified GHCJS.DOM.Document as Document +import qualified GHCJS.DOM.HTMLCollection as HTMLCollection +import GHCJS.DOM.Types (Element) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +visibleIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Event t a) +visibleIfDyn cond empty content = + R.dyn $ R.ffor cond $ \case + True -> content + False -> empty + +visibleIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a) +visibleIfEvent cond empty content = + R.widgetHold empty $ + R.ffor cond $ \case + True -> content + False -> empty + +divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a +divVisibleIf cond content = divClassVisibleIf cond "" content + +divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a +divClassVisibleIf cond className content = + R.elDynAttr + "div" + (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond) + content + +flatten :: forall t m a. MonadWidget t m => Event t (Event t a) -> m (Event t a) +flatten e = do + dyn <- R.holdDyn R.never e + return $ R.switchDyn dyn + +getBody :: forall t m. MonadWidget t m => m Element +getBody = do + document <- Dom.currentDocumentUnchecked + nodelist <- Document.getElementsByTagName document ("body" :: String) + Just body <- nodelist `HTMLCollection.item` 0 + return body diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f363b06..ab83447 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -11,9 +11,9 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (CreatedPayment (..), Frequency, Init (..), - Payment (..), PaymentCategory (..), - PaymentId) +import Common.Model (Frequency, Init (..), Payment (..), + PaymentCategory (..), PaymentId, + SavedPayment (..)) import qualified Common.Util.Text as T import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header @@ -36,15 +36,19 @@ widget paymentIn = do rec let init = _paymentIn_init paymentIn paymentsPerPage = 7 + savedPayments = R.leftmost + [ _headerOut_addPayment header + , _tableOut_addPayment table + ] payments <- getPayments (_init_payments init) - (_createdPayment_payment <$> _headerOut_addPayment header) + (_savedPayment_payment <$> savedPayments) (_tableOut_deletePayment table) paymentCategories <- getPaymentCategories (_init_paymentCategories init) - (_createdPayment_paymentCategory <$> _headerOut_addPayment header) + (_savedPayment_paymentCategory <$> savedPayments) payments (_tableOut_deletePayment table) diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 69e29a7..88806bc 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -1,161 +1,54 @@ module View.Payment.Add ( view - , AddIn(..) - , AddOut(..) + , Input(..) ) where import Control.Monad (join) import Control.Monad.IO.Class (liftIO) -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Maybe as Maybe -import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Time -import qualified Data.Validation as V -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import qualified Text.Read as T -import Common.Model (Category (..), CategoryId, - CreatePayment (..), - CreatedPayment (..), Frequency (..), - Payment (..), PaymentCategory (..)) +import Common.Model (Category (..), CreatePayment (..), + Frequency (..), Payment (..), + PaymentCategory (..), + SavedPayment (..)) import qualified Common.Msg as Msg -import qualified Common.Util.Time as Time +import qualified Common.Util.Time as TimeUtil import qualified Common.Validation.Payment as PaymentValidation -import Component (ButtonIn (..), InputIn (..), - InputOut (..), SelectIn (..), - SelectOut (..)) -import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.Validation as ValidationUtil -import qualified Util.WaitFor as WaitFor - -data AddIn t = AddIn - { _addIn_categories :: [Category] - , _addIn_paymentCategories :: Dynamic t [PaymentCategory] - , _addIn_frequency :: Dynamic t Frequency - , _addIn_cancel :: Event t () - } - -data AddOut t = AddOut - { _addOut_cancel :: Event t () - , _addOut_addPayment :: Event t CreatedPayment - , _addOut_addPaymentCategory :: Event t PaymentCategory +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form + +data Input t = Input + { _input_categories :: [Category] + , _input_paymentCategories :: Dynamic t [PaymentCategory] + , _input_frequency :: Dynamic t Frequency } -view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t) -view addIn = do - R.divClass "add" $ do - R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add - - R.divClass "addContent" $ do - rec - let reset = R.leftmost - [ "" <$ cancel - , "" <$ addPayment - , "" <$ _addIn_cancel addIn - ] - - name <- Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Name - , _inputIn_validation = PaymentValidation.name - }) - reset - confirm - - cost <- _inputOut_value <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Cost - , _inputIn_validation = PaymentValidation.cost - }) - reset - confirm) - - now <- liftIO Time.getCurrentTime - - currentDay <- do - d <- liftIO $ Time.timeToDay now - return . T.pack . Calendar.showGregorian $ d - - date <- _inputOut_value <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Date - , _inputIn_initialValue = currentDay - , _inputIn_inputType = "date" - , _inputIn_hasResetButton = False - , _inputIn_validation = PaymentValidation.date - }) - (currentDay <$ reset) - confirm) - - let setCategory = - R.fmapMaybe id - . R.updated - $ findCategory <$> (_inputOut_raw name) <*> (_addIn_paymentCategories addIn) - - category <- _selectOut_value <$> (Component.select $ SelectIn - { _selectIn_label = Msg.get Msg.Payment_Category - , _selectIn_initialValue = -1 - , _selectIn_value = setCategory - , _selectIn_values = R.constDyn categories - , _selectIn_reset = reset - , _selectIn_isValid = \id -> id /= -1 - , _selectIn_validate = confirm - }) - - let payment = do - n <- _inputOut_value name - c <- cost - d <- date - cat <- category - f <- _addIn_frequency addIn - return (CreatePayment - <$> ValidationUtil.nelError n - <*> ValidationUtil.nelError c - <*> ValidationUtil.nelError d - <*> ValidationUtil.nelError cat - <*> V.Success f) - - (addPayment, cancel, confirm) <- R.divClass "buttons" $ do - rec - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) - - confirm <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { _buttonIn_class = R.constDyn "confirm" - , _buttonIn_waiting = waiting - , _buttonIn_submit = True - }) - - (addPayment, waiting) <- WaitFor.waitFor - (Ajax.postJson "/payment") - (ValidationUtil.fireValidation payment confirm) - - return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) - - return AddOut - { _addOut_cancel = cancel - , _addOut_addPayment = addPayment - } - - where - frequencies = M.fromList - [ (Punctual, Msg.get Msg.Payment_PunctualMale) - , (Monthly, Msg.get Msg.Payment_MonthlyMale) - ] - - categories = M.fromList . flip map (_addIn_categories addIn) $ \c -> - (_category_id c, _category_name c) - - -findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId -findCategory paymentName = - fmap _paymentCategory_category - . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) +view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment +view input cancel = do + + currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay + + formOutput <- R.dyn $ do + paymentCategories <- _input_paymentCategories input + frequency <- _input_frequency input + return $ Form.view $ Form.Input + { Form._input_cancel = cancel + , Form._input_headerLabel = Msg.get Msg.Payment_Add + , Form._input_categories = _input_categories input + , Form._input_paymentCategories = paymentCategories + , Form._input_name = "" + , Form._input_cost = "" + , Form._input_date = currentDay + , Form._input_category = -1 + , Form._input_frequency = frequency + , Form._input_mkPayload = CreatePayment + } + + hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) + addPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) + + return (hide, addPayment) diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs new file mode 100644 index 0000000..5624f6c --- /dev/null +++ b/client/src/View/Payment/Clone.hs @@ -0,0 +1,60 @@ +module View.Payment.Clone + ( Input(..) + , view + ) where + +import qualified Control.Monad as Monad +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import qualified Data.Time.Clock as Time +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), CategoryId, + CreatePayment (..), Frequency (..), + Payment (..), PaymentCategory (..), + SavedPayment (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Common.Validation.Payment as PaymentValidation +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form + +data Input t = Input + { _input_show :: Event t () + , _input_categories :: [Category] + , _input_paymentCategories :: Dynamic t [PaymentCategory] + , _input_payment :: Dynamic t Payment + , _input_category :: Dynamic t CategoryId + } + +view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment +view input cancel = do + + currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay + + formOutput <- R.dyn $ do + paymentCategories <- _input_paymentCategories input + payment <- _input_payment input + category <- _input_category input + return . Form.view $ Form.Input + { Form._input_cancel = cancel + , Form._input_headerLabel = Msg.get Msg.Payment_CloneLong + , Form._input_categories = _input_categories input + , Form._input_paymentCategories = paymentCategories + , Form._input_name = _payment_name payment + , Form._input_cost = T.pack . show . _payment_cost $ payment + , Form._input_date = currentDay + , Form._input_category = category + , Form._input_frequency = _payment_frequency payment + , Form._input_mkPayload = CreatePayment + } + + hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) + clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) + + return $ + ( hide + , clonePayment + ) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 65ce660..e7e319e 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -1,39 +1,34 @@ module View.Payment.Delete - ( view - , DeleteIn(..) - , DeleteOut(..) + ( Input(..) + , view ) where -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Payment (..)) -import qualified Common.Msg as Msg -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.WaitFor as WaitFor - -data DeleteIn t = DeleteIn - { _deleteIn_payment :: Dynamic t Payment - } - -data DeleteOut t = DeleteOut - { _deleteOut_cancel :: Event t () - , _deleteOut_validate :: Event t Payment +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Payment (..)) +import qualified Common.Msg as Msg +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component +import qualified Component.Modal as Modal +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.WaitFor as WaitFor + +data Input t = Input + { _input_payment :: Dynamic t Payment } -view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t) -view deleteIn = +view :: forall t m. MonadWidget t m => (Input t) -> Modal.Content t m Payment +view input _ = R.divClass "delete" $ do R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm R.divClass "deleteContent" $ do - (deletedPayment, cancel) <- R.divClass "buttons" $ do + (confirm, cancel) <- R.divClass "buttons" $ do cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) @@ -48,7 +43,7 @@ view deleteIn = }) let url = - R.ffor (_deleteIn_payment deleteIn) (\id -> + R.ffor (_input_payment input) (\id -> T.concat ["/payment/", T.pack . show $ _payment_id id] ) @@ -58,7 +53,7 @@ view deleteIn = return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) - return DeleteOut - { _deleteOut_cancel = cancel - , _deleteOut_validate = R.tag (R.current $ _deleteIn_payment deleteIn) deletedPayment - } + return $ + ( R.leftmost [ cancel, () <$ confirm ] + , R.tag (R.current $ _input_payment input) confirm + ) diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs new file mode 100644 index 0000000..5020e57 --- /dev/null +++ b/client/src/View/Payment/Edit.hs @@ -0,0 +1,55 @@ +module View.Payment.Edit + ( Input(..) + , view + ) where + +import qualified Control.Monad as Monad +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), CategoryId, + EditPayment (..), Frequency (..), + Payment (..), PaymentCategory (..), + SavedPayment (..)) +import qualified Common.Msg as Msg +import qualified Common.Validation.Payment as PaymentValidation +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form + +data Input t = Input + { _input_show :: Event t () + , _input_categories :: [Category] + , _input_paymentCategories :: Dynamic t [PaymentCategory] + , _input_payment :: Dynamic t Payment + , _input_category :: Dynamic t CategoryId + } + +view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment +view input cancel = do + + formOutput <- R.dyn $ do + paymentCategories <- _input_paymentCategories input + payment <- _input_payment input + category <- _input_category input + return . Form.view $ Form.Input + { Form._input_cancel = cancel + , Form._input_headerLabel = Msg.get Msg.Payment_EditLong + , Form._input_categories = _input_categories input + , Form._input_paymentCategories = paymentCategories + , Form._input_name = _payment_name payment + , Form._input_cost = T.pack . show . _payment_cost $ payment + , Form._input_date = _payment_date payment + , Form._input_category = category + , Form._input_frequency = _payment_frequency payment + , Form._input_mkPayload = EditPayment (_payment_id payment) + } + + hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) + editPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) + + return $ + ( hide + , editPayment + ) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs new file mode 100644 index 0000000..ba54957 --- /dev/null +++ b/client/src/View/Payment/Form.hs @@ -0,0 +1,165 @@ +module View.Payment.Form + ( view + , Input(..) + , Output(..) + ) where + +import Control.Monad (join) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (ToJSON) +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadHold, + MonadWidget, Reflex) +import qualified Reflex.Dom as R +import qualified Text.Read as T + +import Common.Model (Category (..), CategoryId, + Frequency (..), Payment (..), + PaymentCategory (..), + SavedPayment (..)) +import qualified Common.Msg as Msg +import qualified Common.Validation.Payment as PaymentValidation +import Component (ButtonIn (..), InputIn (..), + InputOut (..), SelectIn (..), + SelectOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor + +data Input t p = Input + { _input_cancel :: Event t () + , _input_headerLabel :: Text + , _input_categories :: [Category] + , _input_paymentCategories :: [PaymentCategory] + , _input_name :: Text + , _input_cost :: Text + , _input_date :: Day + , _input_category :: CategoryId + , _input_frequency :: Frequency + , _input_mkPayload :: Text -> Int -> Day -> CategoryId -> Frequency -> p + } + +data Output t = Output + { _output_hide :: Event t () + , _output_addPayment :: Event t SavedPayment + } + +view :: forall t m p. (MonadWidget t m, ToJSON p) => Input t p -> m (Output t) +view input = do + R.divClass "form" $ do + R.divClass "formHeader" $ + R.text (_input_headerLabel input) + + R.divClass "formContent" $ do + rec + let reset = R.leftmost + [ "" <$ cancel + , "" <$ addPayment + , "" <$ _input_cancel input + ] + + name <- Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Name + , _inputIn_initialValue = _input_name input + , _inputIn_validation = PaymentValidation.name + }) + (_input_name input <$ reset) + confirm + + cost <- _inputOut_value <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Cost + , _inputIn_initialValue = _input_cost input + , _inputIn_validation = PaymentValidation.cost + }) + (_input_cost input <$ reset) + confirm) + + let initialDate = T.pack . Calendar.showGregorian . _input_date $ input + + date <- _inputOut_value <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Date + , _inputIn_initialValue = initialDate + , _inputIn_inputType = "date" + , _inputIn_hasResetButton = False + , _inputIn_validation = PaymentValidation.date + }) + (initialDate <$ reset) + confirm) + + let setCategory = + R.fmapMaybe id . R.updated $ + R.ffor (_inputOut_raw name) $ \name -> + findCategory name (_input_paymentCategories input) + + category <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Category + , _selectIn_initialValue = _input_category input + , _selectIn_value = setCategory + , _selectIn_values = R.constDyn categories + , _selectIn_reset = _input_category input <$ reset + , _selectIn_isValid = (/= -1) + , _selectIn_validate = confirm + }) + + let payment = do + n <- _inputOut_value name + c <- cost + d <- date + cat <- category + return ((_input_mkPayload input) + <$> ValidationUtil.nelError n + <*> ValidationUtil.nelError c + <*> ValidationUtil.nelError d + <*> ValidationUtil.nelError cat + <*> V.Success (_input_frequency input)) + + (addPayment, cancel, confirm) <- R.divClass "buttons" $ do + rec + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + confirm <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { _buttonIn_class = R.constDyn "confirm" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + }) + + (addPayment, waiting) <- WaitFor.waitFor + (Ajax.postJson "/payment") + (ValidationUtil.fireValidation payment confirm) + + return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) + + return Output + { _output_hide = R.leftmost [ cancel, () <$ addPayment ] + , _output_addPayment = addPayment + } + + where + frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + categories = M.fromList . flip map (_input_categories input) $ \c -> + (_category_id c, _category_name c) + + +findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId +findCategory paymentName = + fmap _paymentCategory_category + . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 1bdee8d..7281195 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -17,10 +17,10 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Category, CreatedPayment (..), - Currency, ExceedingPayer (..), - Frequency (..), Income (..), Init (..), - Payment (..), PaymentCategory, +import Common.Model (Category, Currency, + ExceedingPayer (..), Frequency (..), + Income (..), Init (..), Payment (..), + PaymentCategory, SavedPayment (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg @@ -28,11 +28,10 @@ import qualified Common.View.Format as Format import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..), - ModalIn (..), ModalOut (..), SelectIn (..), SelectOut (..)) import qualified Component as Component +import qualified Component.Modal as Modal import qualified Util.List as L -import View.Payment.Add (AddIn (..), AddOut (..)) import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn @@ -45,7 +44,7 @@ data HeaderIn t = HeaderIn data HeaderOut t = HeaderOut { _headerOut_searchName :: Dynamic t Text , _headerOut_searchFrequency :: Dynamic t Frequency - , _headerOut_addPayment :: Event t CreatedPayment + , _headerOut_addPayment :: Event t SavedPayment } widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) @@ -90,7 +89,7 @@ payerAndAdd -> Dynamic t [PaymentCategory] -> Currency -> Dynamic t Frequency - -> m (Event t CreatedPayment) + -> m (Event t SavedPayment) payerAndAdd incomes payments users categories paymentCategories currency frequency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do @@ -119,22 +118,14 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen , _buttonIn_submit = False }) - rec - modalOut <- Component.modal $ ModalIn - { _modalIn_show = addPaymentClic - , _modalIn_hide = R.leftmost $ - [ _addOut_cancel addOut - , fmap (const ()) . _addOut_addPayment $ addOut - ] - , _modalIn_content = Add.view $ AddIn - { _addIn_categories = categories - , _addIn_paymentCategories = paymentCategories - , _addIn_frequency = frequency - , _addIn_cancel = _modalOut_hide modalOut - } - } - let addOut = _modalOut_content modalOut - return (_addOut_addPayment addOut) + Modal.view $ Modal.Input + { Modal._input_show = addPaymentClic + , Modal._input_content = Add.view $ Add.Input + { Add._input_categories = categories + , Add._input_paymentCategories = paymentCategories + , Add._input_frequency = frequency + } + } searchLine :: forall t m. MonadWidget t m diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index cbe7b50..9247143 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -4,15 +4,15 @@ module View.Payment.Pages , PagesOut(..) ) where -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component import qualified Icon -import qualified Util.Dom as Dom +import qualified Util.Reflex as ReflexUtil data PagesIn t = PagesIn { _pagesIn_total :: Dynamic t Int @@ -26,7 +26,7 @@ data PagesOut t = PagesOut widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) widget pagesIn = do - currentPage <- Dom.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset + currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset return $ PagesOut { _pagesOut_currentPage = currentPage diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index b09f30f..f2b8870 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -6,25 +6,32 @@ module View.Payment.Table import qualified Data.List as L import qualified Data.Map as M +import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) +import Common.Model (Category (..), Frequency (Punctual), + Init (..), Payment (..), + PaymentCategory (..), SavedPayment, + User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import Component (ButtonIn (..), ButtonOut (..), - ModalIn (..), ModalOut (..)) +import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component -import View.Payment.Delete (DeleteIn (..), DeleteOut (..)) +import qualified Component.Modal as Modal +import qualified View.Payment.Clone as Clone import qualified View.Payment.Delete as Delete +import qualified View.Payment.Edit as Edit import qualified Icon -import qualified Util.Dom as DomUtil +import qualified Util.Reflex as ReflexUtil + +-- TODO: remove +import Debug.Trace (trace) data TableIn t = TableIn { _tableIn_init :: Init @@ -32,17 +39,19 @@ data TableIn t = TableIn , _tableIn_payments :: Dynamic t [Payment] , _tableIn_perPage :: Int , _tableIn_paymentCategories :: Dynamic t [PaymentCategory] + , _tableIn_categories :: [Category] } data TableOut t = TableOut - { _tableOut_deletePayment :: Event t Payment + { _tableOut_addPayment :: Event t SavedPayment + , _tableOut_deletePayment :: Event t Payment } widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) widget tableIn = do R.divClass "table" $ do - deletePayment <- R.divClass "lines" $ do + (addPayment, deletePayment) <- R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost @@ -52,14 +61,21 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - (R.switch . R.current . fmap R.leftmost) <$> + + result <- (R.simpleList paymentRange (paymentRow init paymentCategories)) - DomUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ + return $ + ( R.switch . R.current . fmap (R.leftmost . map fst) $ result + , R.switch . R.current . fmap (R.leftmost . map snd) $ result + ) + + ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty return $ TableOut - { _tableOut_deletePayment = deletePayment + { _tableOut_addPayment = addPayment + , _tableOut_deletePayment = deletePayment } where @@ -82,7 +98,7 @@ paymentRow => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment - -> m (Event t Payment) + -> m (Event t SavedPayment, Event t Payment) paymentRow init paymentCategories payment = R.divClass "row" $ do @@ -115,7 +131,7 @@ paymentRow init paymentCategories payment = Nothing -> M.singleton "display" "none" R.elDynAttr "span" attrs $ - R.dynText $ flip fmap category $ \mbCategory -> case mbCategory of + R.dynText $ R.ffor category $ \case Just c -> _category_name c _ -> "" @@ -123,35 +139,68 @@ paymentRow init paymentCategories payment = R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment - R.divClass "cell button" $ - R.el "button" Icon.clone + let categoryId = (Maybe.fromMaybe (-1) . fmap _category_id) <$> category + + clonePayment <- + R.divClass "cell button" $ + _buttonOut_clic <$> (Component.button $ + Component.defaultButtonIn Icon.clone) + + paymentCloned <- + Modal.view $ Modal.Input + { Modal._input_show = clonePayment + , Modal._input_content = + Clone.view $ Clone.Input + { Clone._input_show = clonePayment + , Clone._input_categories = _init_categories init + , Clone._input_paymentCategories = paymentCategories + , Clone._input_payment = payment + , Clone._input_category = categoryId + } + } let isFromCurrentUser = R.ffor payment (\p -> _payment_user p == _init_currentUser init) - R.divClass "cell button" $ - DomUtil.divVisibleIf isFromCurrentUser $ - R.el "button" Icon.edit + editPayment <- + R.divClass "cell button" $ + ReflexUtil.divVisibleIf isFromCurrentUser $ + _buttonOut_clic <$> (Component.button $ + Component.defaultButtonIn Icon.edit) + + paymentEdited <- + Modal.view $ Modal.Input + { Modal._input_show = editPayment + , Modal._input_content = + Edit.view $ Edit.Input + { Edit._input_show = editPayment + , Edit._input_categories = _init_categories init + , Edit._input_paymentCategories = paymentCategories + , Edit._input_payment = payment + , Edit._input_category = categoryId + } + } deletePayment <- R.divClass "cell button" $ - DomUtil.divVisibleIf isFromCurrentUser $ + ReflexUtil.divVisibleIf isFromCurrentUser $ _buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn Icon.delete) - { _buttonIn_class = R.constDyn "deletePayment" }) - - rec - modalOut <- Component.modal $ ModalIn - { _modalIn_show = deletePayment - , _modalIn_hide = R.leftmost $ - [ _deleteOut_cancel . _modalOut_content $ modalOut - , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut - ] - , _modalIn_content = Delete.view (DeleteIn { _deleteIn_payment = payment }) + { _buttonIn_class = R.constDyn "deletePayment" + }) + + paymentDeleted <- + Modal.view $ Modal.Input + { Modal._input_show = deletePayment + , Modal._input_content = + Delete.view $ Delete.Input + { Delete._input_payment = payment + } } - return (_deleteOut_validate . _modalOut_content $ modalOut) + + return $ (paymentCloned, paymentDeleted) findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do -- cgit v1.2.3 From f4c5df9e1b1afddeb5a482d4fbe654d0b321159c Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 6 Oct 2019 19:28:54 +0200 Subject: Make payment edition to work on the frontend --- client/src/Util/Ajax.hs | 63 +++++++++++++++++++++++++++++----------- client/src/View/Payment.hs | 38 ++++++++++++++++-------- client/src/View/Payment/Add.hs | 1 + client/src/View/Payment/Clone.hs | 1 + client/src/View/Payment/Edit.hs | 1 + client/src/View/Payment/Form.hs | 19 ++++++++---- client/src/View/Payment/Table.hs | 13 +++++---- 7 files changed, 97 insertions(+), 39 deletions(-) (limited to 'client') diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 7b65c52..a4f6a74 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -1,20 +1,24 @@ module Util.Ajax ( postJson + , putJson , delete ) where -import Control.Arrow (left) -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as Aeson -import Data.Default (def) -import qualified Data.Map.Lazy as LM -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, - XhrRequest, XhrRequestConfig (..), - XhrResponse, XhrResponseHeaders (..)) -import qualified Reflex.Dom as R +import Control.Arrow (left) +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import Data.Default (def) +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Reflex.Dom (Dynamic, Event, IsXhrPayload, + MonadWidget, XhrRequest, + XhrRequestConfig (..), XhrResponse, + XhrResponseHeaders (..)) +import qualified Reflex.Dom as R postJson :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) @@ -23,7 +27,16 @@ postJson -> m (Event t (Either Text b)) postJson url input = fmap getJsonResult <$> - R.performRequestAsync (R.postJson url <$> input) + R.performRequestAsync (jsonRequest "POST" url <$> input) + +putJson + :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) + => Text + -> Event t a + -> m (Event t (Either Text b)) +putJson url input = + fmap getJsonResult <$> + R.performRequestAsync (jsonRequest "PUT" url <$> input) delete :: forall t m a. (MonadWidget t m) @@ -31,8 +44,9 @@ delete -> Event t () -> m (Event t (Either Text Text)) delete url fire = do - response <- R.performRequestAsync (R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire) - return $ fmap getResult response + fmap getResult <$> + (R.performRequestAsync $ + R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire) getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a getJsonResult response = @@ -50,7 +64,22 @@ getResult response = _ -> Left "NoKey" request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a -request method url sendData = +request method url payload = + let + config = XhrRequestConfig + { _xhrRequestConfig_headers = def + , _xhrRequestConfig_user = def + , _xhrRequestConfig_password = def + , _xhrRequestConfig_responseType = def + , _xhrRequestConfig_responseHeaders = def + , _xhrRequestConfig_withCredentials = False + , _xhrRequestConfig_sendData = payload + } + in + R.xhrRequest method url config + +jsonRequest :: forall a. (ToJSON a) => Text -> Text -> a -> XhrRequest ByteString +jsonRequest method url payload = let config = XhrRequestConfig { _xhrRequestConfig_headers = def @@ -59,7 +88,7 @@ request method url sendData = , _xhrRequestConfig_responseType = def , _xhrRequestConfig_responseHeaders = def , _xhrRequestConfig_withCredentials = False - , _xhrRequestConfig_sendData = sendData + , _xhrRequestConfig_sendData = LBS.toStrict $ Aeson.encode payload } in R.xhrRequest method url config diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index ab83447..f2a5071 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -35,21 +35,25 @@ widget paymentIn = do R.elClass "main" "payment" $ do rec let init = _paymentIn_init paymentIn + paymentsPerPage = 7 - savedPayments = R.leftmost + + addPayment = R.leftmost [ _headerOut_addPayment header , _tableOut_addPayment table ] - payments <- getPayments + payments <- reducePayments (_init_payments init) - (_savedPayment_payment <$> savedPayments) + (_savedPayment_payment <$> addPayment) + (_savedPayment_payment <$> _tableOut_editPayment table) (_tableOut_deletePayment table) - paymentCategories <- getPaymentCategories + paymentCategories <- reducePaymentCategories (_init_paymentCategories init) - (_savedPayment_paymentCategory <$> savedPayments) payments + (_savedPayment_paymentCategory <$> addPayment) + (_savedPayment_paymentCategory <$> _tableOut_editPayment table) (_tableOut_deletePayment table) (searchNameEvent, searchName) <- @@ -93,28 +97,38 @@ debounceSearchName searchName = do dynamic <- R.holdDyn "" event return (event, dynamic) -getPayments +reducePayments :: forall t m. MonadWidget t m => [Payment] - -> Event t Payment - -> Event t Payment + -> Event t Payment -- add payment + -> Event t Payment -- edit payment + -> Event t Payment -- delete payment -> m (Dynamic t [Payment]) -getPayments initPayments addPayment deletePayment = +reducePayments initPayments addPayment editPayment deletePayment = R.foldDyn id initPayments $ R.leftmost [ (:) <$> addPayment + , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) ] -getPaymentCategories +reducePaymentCategories :: forall t m. MonadWidget t m => [PaymentCategory] - -> Event t PaymentCategory -- add payment category -> Dynamic t [Payment] -- payments + -> Event t PaymentCategory -- add payment category + -> Event t PaymentCategory -- edit payment category -> Event t Payment -- delete payment -> m (Dynamic t [PaymentCategory]) -getPaymentCategories initPaymentCategories addPaymentCategory payments deletePayment = +reducePaymentCategories + initPaymentCategories + payments + addPaymentCategory + editPaymentCategory + deletePayment + = R.foldDyn id initPaymentCategories $ R.leftmost [ (:) <$> addPaymentCategory + , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) ] where diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 88806bc..e83dba9 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -46,6 +46,7 @@ view input cancel = do , Form._input_category = -1 , Form._input_frequency = frequency , Form._input_mkPayload = CreatePayment + , Form._input_httpMethod = Form.Post } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs index 5624f6c..922e89c 100644 --- a/client/src/View/Payment/Clone.hs +++ b/client/src/View/Payment/Clone.hs @@ -49,6 +49,7 @@ view input cancel = do , Form._input_category = category , Form._input_frequency = _payment_frequency payment , Form._input_mkPayload = CreatePayment + , Form._input_httpMethod = Form.Post } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs index 5020e57..9c11af0 100644 --- a/client/src/View/Payment/Edit.hs +++ b/client/src/View/Payment/Edit.hs @@ -44,6 +44,7 @@ view input cancel = do , Form._input_category = category , Form._input_frequency = _payment_frequency payment , Form._input_mkPayload = EditPayment (_payment_id payment) + , Form._input_httpMethod = Form.Put } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index ba54957..9889638 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -1,6 +1,7 @@ module View.Payment.Form ( view , Input(..) + , HttpMethod(..) , Output(..) ) where @@ -46,8 +47,11 @@ data Input t p = Input , _input_category :: CategoryId , _input_frequency :: Frequency , _input_mkPayload :: Text -> Int -> Day -> CategoryId -> Frequency -> p + , _input_httpMethod :: HttpMethod } +data HttpMethod = Put | Post + data Output t = Output { _output_hide :: Event t () , _output_addPayment :: Event t SavedPayment @@ -139,7 +143,7 @@ view input = do }) (addPayment, waiting) <- WaitFor.waitFor - (Ajax.postJson "/payment") + (ajax "/payment") (ValidationUtil.fireValidation payment confirm) return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) @@ -150,14 +154,19 @@ view input = do } where - frequencies = M.fromList - [ (Punctual, Msg.get Msg.Payment_PunctualMale) - , (Monthly, Msg.get Msg.Payment_MonthlyMale) - ] + frequencies = + M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] categories = M.fromList . flip map (_input_categories input) $ \c -> (_category_id c, _category_name c) + ajax = + case _input_httpMethod input of + Post -> Ajax.postJson + Put -> Ajax.putJson findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId findCategory paymentName = diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index f2b8870..40bc864 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -44,6 +44,7 @@ data TableIn t = TableIn data TableOut t = TableOut { _tableOut_addPayment :: Event t SavedPayment + , _tableOut_editPayment :: Event t SavedPayment , _tableOut_deletePayment :: Event t Payment } @@ -51,7 +52,7 @@ widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) widget tableIn = do R.divClass "table" $ do - (addPayment, deletePayment) <- R.divClass "lines" $ do + (addPayment, editPayment, deletePayment) <- R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost @@ -66,8 +67,9 @@ widget tableIn = do (R.simpleList paymentRange (paymentRow init paymentCategories)) return $ - ( R.switch . R.current . fmap (R.leftmost . map fst) $ result - , R.switch . R.current . fmap (R.leftmost . map snd) $ result + ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result + , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result + , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result ) ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ @@ -75,6 +77,7 @@ widget tableIn = do return $ TableOut { _tableOut_addPayment = addPayment + , _tableOut_editPayment = editPayment , _tableOut_deletePayment = deletePayment } @@ -98,7 +101,7 @@ paymentRow => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment - -> m (Event t SavedPayment, Event t Payment) + -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment) paymentRow init paymentCategories payment = R.divClass "row" $ do @@ -200,7 +203,7 @@ paymentRow init paymentCategories payment = } } - return $ (paymentCloned, paymentDeleted) + return $ (paymentCloned, paymentEdited, paymentDeleted) findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do -- cgit v1.2.3 From 2cbd43c3a0f0640776a4e7c7425b3210d2e6632b Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 6 Oct 2019 19:41:17 +0200 Subject: Make input label clickable again --- client/src/Component/Input.hs | 16 ++++++++++------ client/src/Component/Select.hs | 16 +++++++++------- 2 files changed, 19 insertions(+), 13 deletions(-) (limited to 'client') diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index abdc51c..0c84754 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -75,13 +75,17 @@ input inputIn reset validate = do (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do - textInput <- R.textInput $ R.def - & R.attributes .~ inputAttr - & R.setValue .~ resetValue - & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) - & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn) + textInput <- R.el "label" $ do + textInput <- R.textInput $ R.def + & R.attributes .~ inputAttr + & R.setValue .~ resetValue + & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) + & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn) - R.el "label" $ R.text (_inputIn_label inputIn) + R.divClass "label" $ + R.text (_inputIn_label inputIn) + + return textInput resetClic <- if _inputIn_hasResetButton inputIn diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 9a37afc..5980ed2 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -57,8 +57,6 @@ select selectIn = do ] value <- R.elDynAttr "div" containerAttr $ do - R.el "label" $ R.text (_selectIn_label selectIn) - let initialValue = _selectIn_initialValue selectIn let setValue = R.leftmost @@ -66,11 +64,15 @@ select selectIn = do , _selectIn_value selectIn ] - value <- R._dropdown_value <$> - R.dropdown - initialValue - (_selectIn_values selectIn) - (R.def { R._dropdownConfig_setValue = setValue }) + value <- R.el "label" $ do + R.divClass "label" $ + R.text (_selectIn_label selectIn) + + R._dropdown_value <$> + R.dropdown + initialValue + (_selectIn_values selectIn) + (R.def { R._dropdownConfig_setValue = setValue }) R.divClass "errorMessage" . R.dynText $ R.ffor showedError (Maybe.fromMaybe "") -- cgit v1.2.3 From 7529a18ff0ac443e7f9764b5e2d0f57a5d3a850b Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 9 Oct 2019 23:16:00 +0200 Subject: Use common payment validation in the backend Remove deprecated backend validation --- client/src/Component/Select.hs | 11 +++-------- client/src/View/Payment/Add.hs | 35 +++++++++++++++++------------------ client/src/View/Payment/Clone.hs | 35 +++++++++++++++++------------------ client/src/View/Payment/Edit.hs | 27 +++++++++++++-------------- client/src/View/Payment/Form.hs | 12 ++++++------ client/src/View/Payment/Header.hs | 3 ++- 6 files changed, 58 insertions(+), 65 deletions(-) (limited to 'client') diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 5980ed2..102f554 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -9,11 +9,10 @@ import qualified Data.Map as M import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T -import Data.Validation (Validation (Failure, Success)) +import Data.Validation (Validation) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import qualified Common.Msg as Msg import qualified Util.Validation as ValidationUtil data (Reflex t) => SelectIn t a b c = SelectIn @@ -22,7 +21,7 @@ data (Reflex t) => SelectIn t a b c = SelectIn , _selectIn_value :: Event t a , _selectIn_values :: Dynamic t (Map a Text) , _selectIn_reset :: Event t b - , _selectIn_isValid :: a -> Bool + , _selectIn_isValid :: a -> Validation Text a , _selectIn_validate :: Event t c } @@ -41,11 +40,7 @@ select selectIn = do ]) validatedValue = - R.ffor value (\v -> - if _selectIn_isValid selectIn v then - Success v - else - Failure (Msg.get Msg.Form_NonEmpty)) + fmap (_selectIn_isValid selectIn) value maybeError = fmap ValidationUtil.maybeError validatedValue diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index e83dba9..28c0148 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -3,23 +3,22 @@ module View.Payment.Add , Input(..) ) where -import Control.Monad (join) -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import qualified Data.Time.Clock as Time -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), CreatePayment (..), - Frequency (..), Payment (..), - PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as TimeUtil -import qualified Common.Validation.Payment as PaymentValidation -import qualified Component.Modal as Modal -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form +import Control.Monad (join) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import qualified Data.Time.Clock as Time +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), CreatePaymentForm (..), + Frequency (..), Payment (..), + PaymentCategory (..), + SavedPayment (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form data Input t = Input { _input_categories :: [Category] @@ -45,7 +44,7 @@ view input cancel = do , Form._input_date = currentDay , Form._input_category = -1 , Form._input_frequency = frequency - , Form._input_mkPayload = CreatePayment + , Form._input_mkPayload = CreatePaymentForm , Form._input_httpMethod = Form.Post } diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs index 922e89c..60694ca 100644 --- a/client/src/View/Payment/Clone.hs +++ b/client/src/View/Payment/Clone.hs @@ -3,23 +3,22 @@ module View.Payment.Clone , view ) where -import qualified Control.Monad as Monad -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import qualified Data.Time.Clock as Time -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), CategoryId, - CreatePayment (..), Frequency (..), - Payment (..), PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as TimeUtil -import qualified Common.Validation.Payment as PaymentValidation -import qualified Component.Modal as Modal -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form +import qualified Control.Monad as Monad +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import qualified Data.Time.Clock as Time +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), CategoryId, + CreatePaymentForm (..), Frequency (..), + Payment (..), PaymentCategory (..), + SavedPayment (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form data Input t = Input { _input_show :: Event t () @@ -48,7 +47,7 @@ view input cancel = do , Form._input_date = currentDay , Form._input_category = category , Form._input_frequency = _payment_frequency payment - , Form._input_mkPayload = CreatePayment + , Form._input_mkPayload = CreatePaymentForm , Form._input_httpMethod = Form.Post } diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs index 9c11af0..0361602 100644 --- a/client/src/View/Payment/Edit.hs +++ b/client/src/View/Payment/Edit.hs @@ -3,20 +3,19 @@ module View.Payment.Edit , view ) where -import qualified Control.Monad as Monad -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Control.Monad as Monad +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Category (..), CategoryId, - EditPayment (..), Frequency (..), - Payment (..), PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Common.Validation.Payment as PaymentValidation -import qualified Component.Modal as Modal -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form +import Common.Model (Category (..), CategoryId, + EditPaymentForm (..), Frequency (..), + Payment (..), PaymentCategory (..), + SavedPayment (..)) +import qualified Common.Msg as Msg +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form data Input t = Input { _input_show :: Event t () @@ -43,7 +42,7 @@ view input cancel = do , Form._input_date = _payment_date payment , Form._input_category = category , Form._input_frequency = _payment_frequency payment - , Form._input_mkPayload = EditPayment (_payment_id payment) + , Form._input_mkPayload = EditPaymentForm (_payment_id payment) , Form._input_httpMethod = Form.Put } diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 9889638..187b64b 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -46,7 +46,7 @@ data Input t p = Input , _input_date :: Day , _input_category :: CategoryId , _input_frequency :: Frequency - , _input_mkPayload :: Text -> Int -> Day -> CategoryId -> Frequency -> p + , _input_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> p , _input_httpMethod :: HttpMethod } @@ -80,7 +80,7 @@ view input = do (_input_name input <$ reset) confirm - cost <- _inputOut_value <$> (Component.input + cost <- _inputOut_raw <$> (Component.input (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost , _inputIn_initialValue = _input_cost input @@ -91,7 +91,7 @@ view input = do let initialDate = T.pack . Calendar.showGregorian . _input_date $ input - date <- _inputOut_value <$> (Component.input + date <- _inputOut_raw <$> (Component.input (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Date , _inputIn_initialValue = initialDate @@ -113,7 +113,7 @@ view input = do , _selectIn_value = setCategory , _selectIn_values = R.constDyn categories , _selectIn_reset = _input_category input <$ reset - , _selectIn_isValid = (/= -1) + , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input) , _selectIn_validate = confirm }) @@ -124,8 +124,8 @@ view input = do cat <- category return ((_input_mkPayload input) <$> ValidationUtil.nelError n - <*> ValidationUtil.nelError c - <*> ValidationUtil.nelError d + <*> V.Success c + <*> V.Success d <*> ValidationUtil.nelError cat <*> V.Success (_input_frequency input)) diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 7281195..6ed3b0e 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -13,6 +13,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time (NominalDiffTime) import qualified Data.Time as Time +import qualified Data.Validation as V import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R @@ -150,7 +151,7 @@ searchLine reset = do , _selectIn_value = R.never , _selectIn_values = R.constDyn frequencies , _selectIn_reset = R.never - , _selectIn_isValid = const True + , _selectIn_isValid = V.Success , _selectIn_validate = R.never }) -- cgit v1.2.3 From 52331eeadce8d250564851c25fc965172640bc55 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 12 Oct 2019 11:23:10 +0200 Subject: Implement client routing --- client/client.cabal | 12 ++ client/src/Component.hs | 1 + client/src/Component/Link.hs | 33 +++++ client/src/Model/Route.hs | 9 ++ client/src/Util/Css.hs | 9 ++ client/src/Util/Router.hs | 266 ++++++++++++++++++++++++++++++++++++++ client/src/View/App.hs | 87 +++++++++---- client/src/View/Header.hs | 65 +++++++--- client/src/View/NotFound.hs | 20 +++ client/src/View/Payment.hs | 9 +- client/src/View/Payment/Delete.hs | 2 +- client/src/View/Payment/Form.hs | 2 +- client/src/View/SignIn.hs | 2 +- 13 files changed, 469 insertions(+), 48 deletions(-) create mode 100644 client/src/Component/Link.hs create mode 100644 client/src/Model/Route.hs create mode 100644 client/src/Util/Css.hs create mode 100644 client/src/Util/Router.hs create mode 100644 client/src/View/NotFound.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 5fc20ae..55ba5e1 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -35,22 +35,34 @@ Executable client , time , validation + -- Router + , ghcjs-base + , ghcjs-prim + , ghcjs-dom + , jsaddle + , lens + , uri-bytestring + other-modules: Component Component.Button Component.Form Component.Input + Component.Link Component.Modal Component.Select Icon Util.Ajax + Util.Css Util.Either Util.List Util.Reflex + Util.Router Util.Validation Util.WaitFor View.App View.Header + View.NotFound View.Payment View.Payment.Add View.Payment.Clone diff --git a/client/src/Component.hs b/client/src/Component.hs index 7b87a75..7e0b151 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -3,5 +3,6 @@ module Component (module X) where import Component.Button as X import Component.Form as X import Component.Input as X +import Component.Link as X import Component.Modal as X import Component.Select as X diff --git a/client/src/Component/Link.hs b/client/src/Component/Link.hs new file mode 100644 index 0000000..7e8558b --- /dev/null +++ b/client/src/Component/Link.hs @@ -0,0 +1,33 @@ +module Component.Link + ( link + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +link :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> Text -> m () +link href inputAttrs content = + R.elDynAttr "a" attrs (R.text content) + where + + onclickHandler = + T.intercalate ";" + [ "history.pushState(0, '', event.target.href)" + , "dispatchEvent(new PopStateEvent('popstate', {cancelable: true, bubbles: true, view: window}))" + , "return false" + ] + + attrs = + R.ffor inputAttrs (\as -> + (M.union + (M.fromList + [ ("onclick", onclickHandler) + , ("href", href) + ] + ) + as) + ) diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs new file mode 100644 index 0000000..420fe05 --- /dev/null +++ b/client/src/Model/Route.hs @@ -0,0 +1,9 @@ +module Model.Route + ( Route(..) + ) where + +data Route + = RootRoute + | IncomeRoute + | NotFoundRoute + deriving (Eq, Show) diff --git a/client/src/Util/Css.hs b/client/src/Util/Css.hs new file mode 100644 index 0000000..804b10f --- /dev/null +++ b/client/src/Util/Css.hs @@ -0,0 +1,9 @@ +module Util.Css + ( classes + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +classes :: [(Text, Bool)] -> Text +classes = T.unwords . map fst . filter snd diff --git a/client/src/Util/Router.hs b/client/src/Util/Router.hs new file mode 100644 index 0000000..e9d0a1a --- /dev/null +++ b/client/src/Util/Router.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Util.Router ( + -- == High-level routers + route + , route' + , partialPathRoute + + -- = Low-level URL bar access + , getLoc + , getURI + , getUrlText + , uriOrigin + , URI + + -- = History movement + , goForward + , goBack + ) where + +------------------------------------------------------------------------------ +import Control.Lens ((&), (.~), (^.)) +import Control.Monad.Fix (MonadFix) +import qualified Data.ByteString.Char8 as BS +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import GHCJS.DOM (currentDocumentUnchecked, + currentWindowUnchecked) +import GHCJS.DOM.Document (createEvent) +import GHCJS.DOM.Event (initEvent) +import GHCJS.DOM.EventM (on) +import GHCJS.DOM.EventTarget (dispatchEvent_) +import GHCJS.DOM.History (History, back, forward, + pushState) +import GHCJS.DOM.Location (getHref) +import GHCJS.DOM.PopStateEvent +import GHCJS.DOM.Types (Location (..), + PopStateEvent (..)) +import GHCJS.DOM.Types (MonadJSM, uncheckedCastTo) +import qualified GHCJS.DOM.Types as DOM +import GHCJS.DOM.Window (getHistory, getLocation) +import GHCJS.DOM.WindowEventHandlers (popState) +import GHCJS.Foreign (isFunction) +import GHCJS.Marshal.Pure (pFromJSVal) +import Language.Javascript.JSaddle (JSM, Object (..), ghcjsPure, + liftJSM) +import qualified Language.Javascript.JSaddle as JS +import Reflex.Dom.Core hiding (EventName, Window) +import qualified URI.ByteString as U +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------- +-- | Manipulate and track the URL 'GHCJS.DOM.Types.Location' for dynamic +-- routing of a widget +-- These sources of URL-bar change will be reflected in the output URI +-- - Input events to 'route' +-- - Browser Forward/Back button clicks +-- - forward/back javascript calls (or 'goForward'/'goBack') Haskell calls +-- - Any URL changes followed by a popState event +-- But external calls to pushState that don't manually fire a popState +-- won't be detected +route + :: forall t m. + ( MonadHold t m + , PostBuild t m + , TriggerEvent t m + , PerformEvent t m + , HasJSContext m + , HasJSContext (Performable m) + , MonadJSM m + , MonadJSM (Performable m)) + => Event t T.Text + -> m (Dynamic t (U.URIRef U.Absolute)) +route pushTo = do + loc0 <- getURI + + _ <- performEvent $ ffor pushTo $ \t -> do + let newState = Just t + withHistory $ \h -> pushState h (0 :: Double) ("" :: T.Text) (newState :: Maybe T.Text) + liftJSM dispatchEvent' + + locUpdates <- getPopState + holdDyn loc0 locUpdates + +route' + :: forall t m a b. + ( MonadHold t m + , PostBuild t m + , TriggerEvent t m + , PerformEvent t m + , HasJSContext m + , HasJSContext (Performable m) + , MonadJSM m + , MonadJSM (Performable m) + , MonadFix m) + => (URI -> a -> URI) + -> (URI -> b) + -> Event t a + -> m (Dynamic t b) +route' encode decode routeUpdate = do + rec rUri <- route (T.decodeUtf8 . U.serializeURIRef' <$> urlUpdates) + let urlUpdates = attachWith encode (current rUri) routeUpdate + return $ decode <$> rUri + + +------------------------------------------------------------------------------- +-- | Route a single page app according to the part of the path after +-- pathBase +partialPathRoute + :: forall t m. + ( MonadHold t m + , PostBuild t m + , DomBuilder t m + , TriggerEvent t m + , PerformEvent t m + , HasJSContext m + , HasJSContext (Performable m) + , MonadJSM m + , MonadJSM (Performable m) + , MonadFix m) + => T.Text -- ^ The path segments not related to SPA routing + -- (leading '/' will be added automaticaly) + -> Event t T.Text -- ^ Updates to the path segments used for routing + -- These values will be appended to the base path + -> m (Dynamic t [T.Text]) -- ^ Path segments used for routing +partialPathRoute pathBase pathUpdates = do + route' (flip updateUrl) parseParts pathUpdates + where + + rootPathBase :: T.Text + rootPathBase = + if T.null pathBase then + "" + else + "/" <> cleanT pathBase + + toPath :: T.Text -> BS.ByteString + toPath dynpath = T.encodeUtf8 $ rootPathBase <> "/" <> cleanT dynpath + + updateUrl :: T.Text -> URI -> URI + updateUrl updateParts u = u & U.pathL .~ toPath updateParts + + parseParts :: URI -> [T.Text] + parseParts u = + maybe (error $ pfxErr u pathBase) + (T.splitOn "/" . T.decodeUtf8 . cleanB) . + BS.stripPrefix (T.encodeUtf8 $ cleanT pathBase) $ + cleanB (u ^. U.pathL) + + cleanT = T.dropWhile (=='/') + cleanB = BS.dropWhile (== '/') + + +------------------------------------------------------------------------------- +uriOrigin :: U.URIRef U.Absolute -> T.Text +uriOrigin r = T.decodeUtf8 $ U.serializeURIRef' r' + where + r' = r { U.uriPath = mempty + , U.uriQuery = mempty + , U.uriFragment = mempty + } + + +------------------------------------------------------------------------------- +getPopState + :: forall t m. + ( MonadHold t m + , TriggerEvent t m + , MonadJSM m) => m (Event t URI) +getPopState = do + window <- currentWindowUnchecked + wrapDomEventMaybe window (`on` popState) $ do + loc <- getLocation window + locStr <- getHref loc + return . hush $ U.parseURI U.laxURIParserOptions (T.encodeUtf8 locStr) + + +------------------------------------------------------------------------------- +goForward :: (HasJSContext m, MonadJSM m) => m () +goForward = withHistory forward + + +------------------------------------------------------------------------------- +goBack :: (HasJSContext m, MonadJSM m) => m () +goBack = withHistory back + + +------------------------------------------------------------------------------- +withHistory :: (HasJSContext m, MonadJSM m) => (History -> m a) -> m a +withHistory act = do + w <- currentWindowUnchecked + h <- getHistory w + act h + + +------------------------------------------------------------------------------- +-- | (Unsafely) get the 'GHCJS.DOM.Location.Location' of a window +getLoc :: (HasJSContext m, MonadJSM m) => m Location +getLoc = do + win <- currentWindowUnchecked + loc <- getLocation win + return loc + + +------------------------------------------------------------------------------- +-- | (Unsafely) get the URL text of a window +getUrlText :: (HasJSContext m, MonadJSM m) => m T.Text +getUrlText = getLoc >>= getHref + + +------------------------------------------------------------------------------- +type URI = U.URIRef U.Absolute + + +------------------------------------------------------------------------------- +getURI :: (HasJSContext m, MonadJSM m) => m URI +getURI = do + l <- getUrlText + return $ either (error "No parse of window location") id . + U.parseURI U.laxURIParserOptions $ T.encodeUtf8 l + + +dispatchEvent' :: JSM () +dispatchEvent' = do + window <- currentWindowUnchecked + obj@(Object o) <- JS.create + JS.objSetPropertyByName obj ("cancelable" :: Text) True + JS.objSetPropertyByName obj ("bubbles" :: Text) True + JS.objSetPropertyByName obj ("view" :: Text) window + event <- JS.jsg ("PopStateEvent" :: Text) >>= ghcjsPure . isFunction >>= \case + True -> newPopStateEvent ("popstate" :: Text) $ Just $ pFromJSVal o + False -> do + doc <- currentDocumentUnchecked + event <- createEvent doc ("PopStateEvent" :: Text) + initEvent event ("popstate" :: Text) True True + JS.objSetPropertyByName obj ("view" :: Text) window + return $ uncheckedCastTo PopStateEvent event + + dispatchEvent_ window event + + +------------------------------------------------------------------------------- +hush :: Either e a -> Maybe a +hush (Right a) = Just a +hush _ = Nothing + + +------------------------------------------------------------------------------- +pfxErr :: URI -> T.Text -> String +pfxErr pn pathBase = + T.unpack $ "Encountered path (" <> T.decodeUtf8 (U.serializeURIRef' pn) + <> ") without expected prefix (" <> pathBase <> ")" diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 6435297..d853c7e 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -2,41 +2,84 @@ module View.App ( widget ) where -import Prelude hiding (error, init) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (InitResult (..)) -import qualified Common.Msg as Msg +import Common.Model (Init, InitResult (..)) +import qualified Common.Msg as Msg -import View.Header (HeaderIn (..)) -import qualified View.Header as Header -import View.Payment (PaymentIn (..)) -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn +import Model.Route (Route (..)) +import qualified Util.Router as Router +import View.Header (HeaderIn (..)) +import qualified View.Header as Header +import qualified View.NotFound as NotFound +import View.Payment (PaymentIn (..)) +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = R.mainWidget $ R.divClass "app" $ do + route <- getRoute + headerOut <- Header.view $ HeaderIn { _headerIn_initResult = initResult + , _headerIn_isInitSuccess = + case initResult of + InitSuccess _ -> True + _ -> False + , _headerIn_route = route } - let signOut = Header._headerOut_signOut headerOut + let signOut = + Header._headerOut_signOut headerOut + + mainContent = + case initResult of + InitSuccess init -> + signedWidget init route + + InitEmpty -> + SignIn.view SignIn.EmptyMessage - initialContent = case initResult of - InitSuccess initSuccess -> do - _ <- Payment.widget $ PaymentIn - { _paymentIn_init = initSuccess - } - return () - InitEmpty -> - SignIn.view SignIn.EmptyMessage - InitError error -> - SignIn.view (SignIn.ErrorMessage error) + InitError error -> + SignIn.view (SignIn.ErrorMessage error) - signOutContent = SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess) + signOutContent = + SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess) - _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) + _ <- R.widgetHold (mainContent) (signOutContent <$ signOut) R.blank + +signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () +signedWidget init route = do + R.dyn . R.ffor route $ \case + RootRoute -> + Payment.widget $ PaymentIn + { _paymentIn_init = init + } + + IncomeRoute -> + R.el "div" $ R.text "Incomes" + + NotFoundRoute -> + NotFound.view + + return () + +getRoute :: MonadWidget t m => m (Dynamic t Route) +getRoute = do + r <- Router.partialPathRoute "" . R.switchPromptlyDyn =<< R.holdDyn R.never R.never + return . R.ffor r $ \case + [""] -> + RootRoute + + ["income"] -> + IncomeRoute + + _ -> + NotFoundRoute diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 8f1fb78..9a4de89 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -4,40 +4,73 @@ module View.Header , HeaderOut(..) ) where -import qualified Data.Map as M -import Data.Time (NominalDiffTime) -import Prelude hiding (error, init) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Init (..), InitResult (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Component as Component -import Component.Button (ButtonIn (..)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (NominalDiffTime) +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init (..), InitResult (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import Component (ButtonIn (..)) +import qualified Component as Component import qualified Icon +import Model.Route (Route (..)) +import qualified Util.Css as CssUtil +import qualified Util.Reflex as ReflexUtil -data HeaderIn = HeaderIn - { _headerIn_initResult :: InitResult +data HeaderIn t = HeaderIn + { _headerIn_initResult :: InitResult + , _headerIn_isInitSuccess :: Bool + , _headerIn_route :: Dynamic t Route } data HeaderOut t = HeaderOut { _headerOut_signOut :: Event t () } -view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t) +view :: forall t m. MonadWidget t m => (HeaderIn t) -> m (HeaderOut t) view headerIn = R.el "header" $ do R.divClass "title" $ R.text $ Msg.get Msg.App_Title - signOut <- nameSignOut $ _headerIn_initResult headerIn + signOut <- R.el "div" $ do + rec + showLinks <- R.foldDyn const (_headerIn_isInitSuccess headerIn) (False <$ signOut) + ReflexUtil.visibleIfDyn showLinks R.blank (links $ _headerIn_route headerIn) + signOut <- nameSignOut $ _headerIn_initResult headerIn + return signOut return $ HeaderOut { _headerOut_signOut = signOut } +links :: forall t m. MonadWidget t m => Dynamic t Route -> m () +links route = do + Component.link + "/" + (R.ffor route (attrs RootRoute)) + (Msg.get Msg.Payment_Title) + + Component.link + "/income" + (R.ffor route (attrs IncomeRoute)) + (Msg.get Msg.Income_Title) + + where + attrs linkRoute currentRoute = + M.singleton "class" $ + CssUtil.classes + [ ("item", True) + , ("current", linkRoute == currentRoute) + ] + nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) nameSignOut initResult = case initResult of (InitSuccess init) -> do @@ -76,5 +109,5 @@ signOutButton = do where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool) askSignOut signOut = fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut + where xhrRequest = fmap (const $ R.postJson "/api/signOut" ()) signOut getResult = (== 200) . R._xhrResponse_status diff --git a/client/src/View/NotFound.hs b/client/src/View/NotFound.hs new file mode 100644 index 0000000..1d4e477 --- /dev/null +++ b/client/src/View/NotFound.hs @@ -0,0 +1,20 @@ +module View.NotFound + ( view + ) where + +import qualified Data.Map as M +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Msg as Msg +import qualified Component as Component + +view :: forall t m. MonadWidget t m => m () +view = + R.divClass "notfound" $ do + R.text (Msg.get Msg.NotFound_Message) + + Component.link + "/" + (R.constDyn $ M.singleton "class" "link") + (Msg.get Msg.NotFound_LinkMessage) diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f2a5071..1072a5e 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -1,7 +1,6 @@ module View.Payment ( widget , PaymentIn(..) - , PaymentOut(..) ) where import Data.Text (Text) @@ -26,11 +25,7 @@ data PaymentIn = PaymentIn { _paymentIn_init :: Init } -data PaymentOut = PaymentOut - { - } - -widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut +widget :: forall t m. MonadWidget t m => PaymentIn -> m () widget paymentIn = do R.elClass "main" "payment" $ do rec @@ -86,7 +81,7 @@ widget paymentIn = do ] } - pure $ PaymentOut {} + pure () debounceSearchName :: forall t m. MonadWidget t m diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index e7e319e..521c1a7 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -44,7 +44,7 @@ view input _ = let url = R.ffor (_input_payment input) (\id -> - T.concat ["/payment/", T.pack . show $ _payment_id id] + T.concat ["/api/payment/", T.pack . show $ _payment_id id] ) (result, waiting) <- WaitFor.waitFor diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 187b64b..7819836 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -143,7 +143,7 @@ view input = do }) (addPayment, waiting) <- WaitFor.waitFor - (ajax "/payment") + (ajax "/api/payment") (ValidationUtil.fireValidation payment confirm) return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index f8b985f..8c248bd 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -50,7 +50,7 @@ view signInMessage = let form = SignInForm <$> _inputOut_raw input (signInResult, waiting) <- WaitFor.waitFor - (Ajax.postJson "/askSignIn") + (Ajax.postJson "/api/askSignIn") (ValidationUtil.fireMaybe ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) -- cgit v1.2.3 From 04c59f08f100ba6a0658d1f2b357f7d8b1e14218 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 13 Oct 2019 22:38:35 +0200 Subject: Show income table --- client/client.cabal | 4 +- client/src/Component.hs | 1 + client/src/Component/Table.hs | 38 +++++++++ client/src/View/App.hs | 40 +++++----- client/src/View/Income/Income.hs | 68 ++++++++++++++++ client/src/View/Payment.hs | 154 ------------------------------------- client/src/View/Payment/Payment.hs | 154 +++++++++++++++++++++++++++++++++++++ client/src/View/Payment/Table.hs | 3 - 8 files changed, 286 insertions(+), 176 deletions(-) create mode 100644 client/src/Component/Table.hs create mode 100644 client/src/View/Income/Income.hs delete mode 100644 client/src/View/Payment.hs create mode 100644 client/src/View/Payment/Payment.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 55ba5e1..f8fe1e1 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -50,6 +50,7 @@ Executable client Component.Input Component.Link Component.Modal + Component.Table Component.Select Icon Util.Ajax @@ -62,8 +63,8 @@ Executable client Util.WaitFor View.App View.Header + View.Income.Income View.NotFound - View.Payment View.Payment.Add View.Payment.Clone View.Payment.Delete @@ -71,5 +72,6 @@ Executable client View.Payment.Form View.Payment.Header View.Payment.Pages + View.Payment.Payment View.Payment.Table View.SignIn diff --git a/client/src/Component.hs b/client/src/Component.hs index 7e0b151..97c250e 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -6,3 +6,4 @@ import Component.Input as X import Component.Link as X import Component.Modal as X import Component.Select as X +import Component.Table as X diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs new file mode 100644 index 0000000..a77a18d --- /dev/null +++ b/client/src/Component/Table.hs @@ -0,0 +1,38 @@ +module Component.Table + ( table + , TableIn(..) + , TableOut(..) + ) where + +import Data.Text (Text) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +data TableIn h r t = TableIn + { _tableIn_headerLabel :: h -> Text + , _tableIn_rows :: Dynamic t [r] + , _tableIn_cell :: h -> r -> Text + } + +data TableOut = TableOut + {} + +table :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => TableIn h r t -> m (TableOut) +table tableIn = do + R.divClass "table" $ do + + R.divClass "lines" $ do + R.divClass "header" $ do + flip mapM_ [minBound..] $ \header -> + R.divClass "cell" . R.text $ + _tableIn_headerLabel tableIn header + + R.simpleList (_tableIn_rows tableIn) $ \r -> + R.divClass "row" $ + flip mapM_ [minBound..] $ \h -> + R.divClass "cell name" $ + R.dynText $ + R.ffor r (_tableIn_cell tableIn h) + + return $ TableOut + {} diff --git a/client/src/View/App.hs b/client/src/View/App.hs index d853c7e..3292336 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -2,22 +2,24 @@ module View.App ( widget ) where -import qualified Data.Text as T -import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Init, InitResult (..)) -import qualified Common.Msg as Msg - -import Model.Route (Route (..)) -import qualified Util.Router as Router -import View.Header (HeaderIn (..)) -import qualified View.Header as Header -import qualified View.NotFound as NotFound -import View.Payment (PaymentIn (..)) -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init, InitResult (..)) +import qualified Common.Msg as Msg + +import Model.Route (Route (..)) +import qualified Util.Router as Router +import View.Header (HeaderIn (..)) +import qualified View.Header as Header +import View.Income.Income (IncomeIn (..)) +import qualified View.Income.Income as Income +import qualified View.NotFound as NotFound +import View.Payment.Payment (PaymentIn (..)) +import qualified View.Payment.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = @@ -59,12 +61,14 @@ signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () signedWidget init route = do R.dyn . R.ffor route $ \case RootRoute -> - Payment.widget $ PaymentIn + Payment.view $ PaymentIn { _paymentIn_init = init } IncomeRoute -> - R.el "div" $ R.text "Incomes" + Income.view $ IncomeIn + { _incomeIn_init = init + } NotFoundRoute -> NotFound.view diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs new file mode 100644 index 0000000..5e9ce1d --- /dev/null +++ b/client/src/View/Income/Income.hs @@ -0,0 +1,68 @@ +module View.Income.Income + ( view + , IncomeIn(..) + ) where + +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Income (..), Init (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format +import Component (TableIn (..)) +import qualified Component + +data IncomeIn = IncomeIn + { _incomeIn_init :: Init + } + +view :: forall t m. MonadWidget t m => IncomeIn -> m () +view incomeIn = + R.elClass "main" "income" $ do + + R.divClass "withMargin" $ + R.divClass "titleButton" $ + R.el "h1" $ + R.text $ + Msg.get Msg.Income_MonthlyNet + + Component.table $ TableIn + { _tableIn_headerLabel = headerLabel + , _tableIn_rows = + R.constDyn + . reverse + . L.sortOn _income_date + . _init_incomes + . _incomeIn_init + $ incomeIn + , _tableIn_cell = cell (_incomeIn_init incomeIn) + } + return () + +data Header + = UserHeader + | AmountHeader + | DateHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel UserHeader = Msg.get Msg.Income_Name +headerLabel DateHeader = Msg.get Msg.Income_Date +headerLabel AmountHeader = Msg.get Msg.Income_Amount + +cell :: Init -> Header -> Income -> Text +cell init header income = + case header of + UserHeader -> + Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init) + + DateHeader -> + Format.longDay . _income_date $ income + + AmountHeader -> + Format.price (_init_currency init) . _income_amount $ income diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs deleted file mode 100644 index 1072a5e..0000000 --- a/client/src/View/Payment.hs +++ /dev/null @@ -1,154 +0,0 @@ -module View.Payment - ( widget - , PaymentIn(..) - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime) -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Frequency, Init (..), Payment (..), - PaymentCategory (..), PaymentId, - SavedPayment (..)) -import qualified Common.Util.Text as T -import View.Payment.Header (HeaderIn (..), HeaderOut (..)) -import qualified View.Payment.Header as Header -import View.Payment.Pages (PagesIn (..), PagesOut (..)) -import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn (..), TableOut (..)) -import qualified View.Payment.Table as Table - -data PaymentIn = PaymentIn - { _paymentIn_init :: Init - } - -widget :: forall t m. MonadWidget t m => PaymentIn -> m () -widget paymentIn = do - R.elClass "main" "payment" $ do - rec - let init = _paymentIn_init paymentIn - - paymentsPerPage = 7 - - addPayment = R.leftmost - [ _headerOut_addPayment header - , _tableOut_addPayment table - ] - - payments <- reducePayments - (_init_payments init) - (_savedPayment_payment <$> addPayment) - (_savedPayment_payment <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) - - paymentCategories <- reducePaymentCategories - (_init_paymentCategories init) - payments - (_savedPayment_paymentCategory <$> addPayment) - (_savedPayment_paymentCategory <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) - - (searchNameEvent, searchName) <- - debounceSearchName (_headerOut_searchName header) - - let searchPayments = - getSearchPayments searchName (_headerOut_searchFrequency header) payments - - header <- Header.widget $ HeaderIn - { _headerIn_init = init - , _headerIn_payments = payments - , _headerIn_searchPayments = searchPayments - , _headerIn_paymentCategories = paymentCategories - } - - table <- Table.widget $ TableIn - { _tableIn_init = init - , _tableIn_currentPage = _pagesOut_currentPage pages - , _tableIn_payments = searchPayments - , _tableIn_perPage = paymentsPerPage - , _tableIn_paymentCategories = paymentCategories - } - - pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> searchPayments - , _pagesIn_perPage = paymentsPerPage - , _pagesIn_reset = R.leftmost $ - [ () <$ searchNameEvent - , () <$ _headerOut_addPayment header - ] - } - - pure () - -debounceSearchName - :: forall t m. MonadWidget t m - => Dynamic t Text - -> m (Event t Text, Dynamic t Text) -debounceSearchName searchName = do - event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) - dynamic <- R.holdDyn "" event - return (event, dynamic) - -reducePayments - :: forall t m. MonadWidget t m - => [Payment] - -> Event t Payment -- add payment - -> Event t Payment -- edit payment - -> Event t Payment -- delete payment - -> m (Dynamic t [Payment]) -reducePayments initPayments addPayment editPayment deletePayment = - R.foldDyn id initPayments $ R.leftmost - [ (:) <$> addPayment - , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) - , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) - ] - -reducePaymentCategories - :: forall t m. MonadWidget t m - => [PaymentCategory] - -> Dynamic t [Payment] -- payments - -> Event t PaymentCategory -- add payment category - -> Event t PaymentCategory -- edit payment category - -> Event t Payment -- delete payment - -> m (Dynamic t [PaymentCategory]) -reducePaymentCategories - initPaymentCategories - payments - addPaymentCategory - editPaymentCategory - deletePayment - = - R.foldDyn id initPaymentCategories $ R.leftmost - [ (:) <$> addPaymentCategory - , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) - , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) - ] - where - deletePaymentName = - R.attachWithMaybe - (\ps p -> - if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then - Nothing - else - Just (_payment_name p)) - (R.current payments) - deletePayment - lowerName = T.toLower . _payment_name - -getSearchPayments - :: forall t. Reflex t - => Dynamic t Text - -> Dynamic t Frequency - -> Dynamic t [Payment] - -> Dynamic t [Payment] -getSearchPayments name frequency payments = do - n <- name - f <- frequency - ps <- payments - pure $ flip filter ps (\p -> - ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) - && (_payment_frequency p == f) - )) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs new file mode 100644 index 0000000..cfdb441 --- /dev/null +++ b/client/src/View/Payment/Payment.hs @@ -0,0 +1,154 @@ +module View.Payment.Payment + ( view + , PaymentIn(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +import Common.Model (Frequency, Init (..), Payment (..), + PaymentCategory (..), PaymentId, + SavedPayment (..)) +import qualified Common.Util.Text as T +import View.Payment.Header (HeaderIn (..), HeaderOut (..)) +import qualified View.Payment.Header as Header +import View.Payment.Pages (PagesIn (..), PagesOut (..)) +import qualified View.Payment.Pages as Pages +import View.Payment.Table (TableIn (..), TableOut (..)) +import qualified View.Payment.Table as Table + +data PaymentIn = PaymentIn + { _paymentIn_init :: Init + } + +view :: forall t m. MonadWidget t m => PaymentIn -> m () +view paymentIn = do + R.elClass "main" "payment" $ do + rec + let init = _paymentIn_init paymentIn + + paymentsPerPage = 7 + + addPayment = R.leftmost + [ _headerOut_addPayment header + , _tableOut_addPayment table + ] + + payments <- reducePayments + (_init_payments init) + (_savedPayment_payment <$> addPayment) + (_savedPayment_payment <$> _tableOut_editPayment table) + (_tableOut_deletePayment table) + + paymentCategories <- reducePaymentCategories + (_init_paymentCategories init) + payments + (_savedPayment_paymentCategory <$> addPayment) + (_savedPayment_paymentCategory <$> _tableOut_editPayment table) + (_tableOut_deletePayment table) + + (searchNameEvent, searchName) <- + debounceSearchName (_headerOut_searchName header) + + let searchPayments = + getSearchPayments searchName (_headerOut_searchFrequency header) payments + + header <- Header.widget $ HeaderIn + { _headerIn_init = init + , _headerIn_payments = payments + , _headerIn_searchPayments = searchPayments + , _headerIn_paymentCategories = paymentCategories + } + + table <- Table.widget $ TableIn + { _tableIn_init = init + , _tableIn_currentPage = _pagesOut_currentPage pages + , _tableIn_payments = searchPayments + , _tableIn_perPage = paymentsPerPage + , _tableIn_paymentCategories = paymentCategories + } + + pages <- Pages.widget $ PagesIn + { _pagesIn_total = length <$> searchPayments + , _pagesIn_perPage = paymentsPerPage + , _pagesIn_reset = R.leftmost $ + [ () <$ searchNameEvent + , () <$ _headerOut_addPayment header + ] + } + + pure () + +debounceSearchName + :: forall t m. MonadWidget t m + => Dynamic t Text + -> m (Event t Text, Dynamic t Text) +debounceSearchName searchName = do + event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) + dynamic <- R.holdDyn "" event + return (event, dynamic) + +reducePayments + :: forall t m. MonadWidget t m + => [Payment] + -> Event t Payment -- add payment + -> Event t Payment -- edit payment + -> Event t Payment -- delete payment + -> m (Dynamic t [Payment]) +reducePayments initPayments addPayment editPayment deletePayment = + R.foldDyn id initPayments $ R.leftmost + [ (:) <$> addPayment + , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) + , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) + ] + +reducePaymentCategories + :: forall t m. MonadWidget t m + => [PaymentCategory] + -> Dynamic t [Payment] -- payments + -> Event t PaymentCategory -- add payment category + -> Event t PaymentCategory -- edit payment category + -> Event t Payment -- delete payment + -> m (Dynamic t [PaymentCategory]) +reducePaymentCategories + initPaymentCategories + payments + addPaymentCategory + editPaymentCategory + deletePayment + = + R.foldDyn id initPaymentCategories $ R.leftmost + [ (:) <$> addPaymentCategory + , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) + , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) + ] + where + deletePaymentName = + R.attachWithMaybe + (\ps p -> + if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then + Nothing + else + Just (_payment_name p)) + (R.current payments) + deletePayment + lowerName = T.toLower . _payment_name + +getSearchPayments + :: forall t. Reflex t + => Dynamic t Text + -> Dynamic t Frequency + -> Dynamic t [Payment] + -> Dynamic t [Payment] +getSearchPayments name frequency payments = do + n <- name + f <- frequency + ps <- payments + pure $ flip filter ps (\p -> + ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) + && (_payment_frequency p == f) + )) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 40bc864..bf6b604 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -30,9 +30,6 @@ import qualified View.Payment.Edit as Edit import qualified Icon import qualified Util.Reflex as ReflexUtil --- TODO: remove -import Debug.Trace (trace) - data TableIn t = TableIn { _tableIn_init :: Init , _tableIn_currentPage :: Dynamic t Int -- cgit v1.2.3 From 284214d3af39143fdbeca57ffa4864389e7d517a Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 14 Oct 2019 09:10:33 +0200 Subject: Show cumulative incomes per user in income page --- client/client.cabal | 1 + client/src/Util/Date.hs | 12 +++++++ client/src/View/Income/Income.hs | 71 ++++++++++++++++++++++++++++++---------- 3 files changed, 67 insertions(+), 17 deletions(-) create mode 100644 client/src/Util/Date.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index f8fe1e1..eeeb8be 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -55,6 +55,7 @@ Executable client Icon Util.Ajax Util.Css + Util.Date Util.Either Util.List Util.Reflex diff --git a/client/src/Util/Date.hs b/client/src/Util/Date.hs new file mode 100644 index 0000000..8fad881 --- /dev/null +++ b/client/src/Util/Date.hs @@ -0,0 +1,12 @@ +module Util.Date + ( utcToLocalDay + ) where + +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import qualified Data.Time.LocalTime as LocalTime + +utcToLocalDay :: UTCTime -> IO Day +utcToLocalDay time = do + timezone <- LocalTime.getCurrentTimeZone + return . LocalTime.localDay $ LocalTime.utcToLocalTime timezone time diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 5e9ce1d..d0c0a45 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -3,19 +3,22 @@ module View.Income.Income , IncomeIn(..) ) where -import qualified Data.List as L -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Income (..), Init (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format -import Component (TableIn (..)) +import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Time.Clock as Clock +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Income (..), Init (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format +import Component (TableIn (..)) import qualified Component +import qualified Util.Date as DateUtil data IncomeIn = IncomeIn { _incomeIn_init :: Init @@ -25,11 +28,7 @@ view :: forall t m. MonadWidget t m => IncomeIn -> m () view incomeIn = R.elClass "main" "income" $ do - R.divClass "withMargin" $ - R.divClass "titleButton" $ - R.el "h1" $ - R.text $ - Msg.get Msg.Income_MonthlyNet + header (_incomeIn_init incomeIn) Component.table $ TableIn { _tableIn_headerLabel = headerLabel @@ -42,8 +41,46 @@ view incomeIn = $ incomeIn , _tableIn_cell = cell (_incomeIn_init incomeIn) } + return () +header :: forall t m. MonadWidget t m => Init -> m () +header init = + R.divClass "withMargin" $ do + + currentTime <- liftIO Clock.getCurrentTime + + Maybe.fromMaybe R.blank $ + flip fmap useIncomesFrom $ \since -> + R.el "div" $ do + + R.el "h1" $ do + day <- liftIO $ DateUtil.utcToLocalDay since + R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day)) + + R.el "ul" $ + flip mapM_ (_init_users init) $ \user -> + R.el "li" $ + R.text $ do + let incomes = filter ((==) (_user_id user) . _income_userId) (_init_incomes init) + T.intercalate " " + [ _user_name user + , "−" + , Format.price (_init_currency init) $ + CM.cumulativeIncomesSince currentTime since incomes + ] + + R.divClass "titleButton" $ + R.el "h1" $ + R.text $ + Msg.get Msg.Income_MonthlyNet + + where + useIncomesFrom = CM.useIncomesFrom + (map _user_id $_init_users init) + (_init_incomes init) + (_init_payments init) + data Header = UserHeader | AmountHeader -- cgit v1.2.3 From 0b40b6b5583b5c437f83e61bf8913f2b4c447b24 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 19 Oct 2019 09:36:03 +0200 Subject: Include pages into table component --- client/client.cabal | 1 + client/src/Component.hs | 1 + client/src/Component/Pages.hs | 88 ++++++++++++++++++++++++++++++++++++++++ client/src/Component/Table.hs | 53 +++++++++++++++++------- client/src/View/Income/Income.hs | 2 + 5 files changed, 130 insertions(+), 15 deletions(-) create mode 100644 client/src/Component/Pages.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index eeeb8be..8c25da7 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -50,6 +50,7 @@ Executable client Component.Input Component.Link Component.Modal + Component.Pages Component.Table Component.Select Icon diff --git a/client/src/Component.hs b/client/src/Component.hs index 97c250e..4c51750 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -5,5 +5,6 @@ import Component.Form as X import Component.Input as X import Component.Link as X import Component.Modal as X +import Component.Pages as X import Component.Select as X import Component.Table as X diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs new file mode 100644 index 0000000..5611cb7 --- /dev/null +++ b/client/src/Component/Pages.hs @@ -0,0 +1,88 @@ +module Component.Pages + ( widget + , PagesIn(..) + , PagesOut(..) + ) where + +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Component.Button (ButtonIn (..), ButtonOut (..)) +import qualified Component.Button as Button + +import qualified Icon +import qualified Util.Reflex as ReflexUtil + +data PagesIn t = PagesIn + { _pagesIn_total :: Dynamic t Int + , _pagesIn_perPage :: Int + , _pagesIn_reset :: Event t () + } + +data PagesOut t = PagesOut + { _pagesOut_currentPage :: Dynamic t Int + } + +widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) +widget pagesIn = do + currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset + + return $ PagesOut + { _pagesOut_currentPage = currentPage + } + + where + total = _pagesIn_total pagesIn + perPage = _pagesIn_perPage pagesIn + reset = _pagesIn_reset pagesIn + +pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) +pageButtons total perPage reset = do + R.divClass "pages" $ do + rec + currentPage <- R.holdDyn 1 . R.leftmost $ + [ firstPageClic + , previousPageClic + , pageClic + , nextPageClic + , lastPageClic + , 1 <$ reset + ] + + firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar + + previousPageClic <- pageButton noCurrentPage (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft + + pageClic <- pageEvent <$> (R.simpleList (range <$> currentPage <*> maxPage) $ \p -> + pageButton (Just <$> currentPage) p (R.dynText $ fmap (T.pack . show) p)) + + nextPageClic <- pageButton noCurrentPage ((\c m -> min (c + 1) m) <$> currentPage <*> maxPage) Icon.doubleRight + + lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar + + return currentPage + + where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) + pageEvent = R.switch . R.current . fmap R.leftmost + noCurrentPage = R.constDyn Nothing + +range :: Int -> Int -> [Int] +range currentPage maxPage = [start..end] + where sidePages = 2 + start = max 1 (min (currentPage - sidePages) (maxPage - sidePages * 2)) + end = min maxPage (start + sidePages * 2) + +pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int) +pageButton currentPage page content = do + clic <- _buttonOut_clic <$> (Button.button $ ButtonIn + { _buttonIn_class = do + cp <- currentPage + p <- page + if cp == Just p then "page current" else "page" + , _buttonIn_content = content + , _buttonIn_waiting = R.never + , _buttonIn_tabIndex = Nothing + , _buttonIn_submit = False + }) + return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index a77a18d..b431c14 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -4,35 +4,58 @@ module Component.Table , TableOut(..) ) where -import Data.Text (Text) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Component.Pages (PagesIn (..), PagesOut (..)) +import qualified Component.Pages as Pages data TableIn h r t = TableIn { _tableIn_headerLabel :: h -> Text , _tableIn_rows :: Dynamic t [r] , _tableIn_cell :: h -> r -> Text + , _tableIn_perPage :: Int + , _tableIn_resetPage :: Event t () } data TableOut = TableOut {} table :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => TableIn h r t -> m (TableOut) -table tableIn = do +table tableIn = R.divClass "table" $ do + rec + R.divClass "lines" $ do + + R.divClass "header" $ + flip mapM_ [minBound..] $ \header -> + R.divClass "cell" . R.text $ + _tableIn_headerLabel tableIn header + + let rows = getRange + (_tableIn_perPage tableIn) + <$> (_pagesOut_currentPage pages) + <*> (_tableIn_rows tableIn) - R.divClass "lines" $ do - R.divClass "header" $ do - flip mapM_ [minBound..] $ \header -> - R.divClass "cell" . R.text $ - _tableIn_headerLabel tableIn header + R.simpleList rows $ \r -> + R.divClass "row" $ + flip mapM_ [minBound..] $ \h -> + R.divClass "cell name" $ + R.dynText $ + R.ffor r (_tableIn_cell tableIn h) - R.simpleList (_tableIn_rows tableIn) $ \r -> - R.divClass "row" $ - flip mapM_ [minBound..] $ \h -> - R.divClass "cell name" $ - R.dynText $ - R.ffor r (_tableIn_cell tableIn h) + pages <- Pages.widget $ PagesIn + { _pagesIn_total = length <$> (_tableIn_rows tableIn) + , _pagesIn_perPage = _tableIn_perPage tableIn + , _pagesIn_reset = _tableIn_resetPage tableIn + } + + return () return $ TableOut {} + +getRange :: forall a. Int -> Int -> [a] -> [a] +getRange perPage currentPage = + take perPage . drop ((currentPage - 1) * perPage) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index d0c0a45..0fdd7d3 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -40,6 +40,8 @@ view incomeIn = . _incomeIn_init $ incomeIn , _tableIn_cell = cell (_incomeIn_init incomeIn) + , _tableIn_perPage = 7 + , _tableIn_resetPage = R.never } return () -- cgit v1.2.3 From 6e9e34e92a244ab6c38d135d46f9f5bb01391906 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 09:51:52 +0200 Subject: Move income header and income table views into separate components --- client/client.cabal | 2 + client/src/View/Income/Header.hs | 60 +++++++++++++++++++++++ client/src/View/Income/Income.hs | 100 +++++---------------------------------- client/src/View/Income/Table.hs | 63 ++++++++++++++++++++++++ 4 files changed, 137 insertions(+), 88 deletions(-) create mode 100644 client/src/View/Income/Header.hs create mode 100644 client/src/View/Income/Table.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 8c25da7..06e77e0 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -65,7 +65,9 @@ Executable client Util.WaitFor View.App View.Header + View.Income.Header View.Income.Income + View.Income.Table View.NotFound View.Payment.Add View.Payment.Clone diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs new file mode 100644 index 0000000..b7170c9 --- /dev/null +++ b/client/src/View/Income/Header.hs @@ -0,0 +1,60 @@ +module View.Income.Header + ( view + , HeaderIn(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import qualified Data.Time.Clock as Clock +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Income (..), Init (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format +import qualified Util.Date as DateUtil + +data HeaderIn = HeaderIn + { _headerIn_init :: Init + } + +view :: forall t m. MonadWidget t m => HeaderIn -> m () +view headerIn = + R.divClass "withMargin" $ do + + currentTime <- liftIO Clock.getCurrentTime + + Maybe.fromMaybe R.blank $ + flip fmap useIncomesFrom $ \since -> + R.el "div" $ do + + R.el "h1" $ do + day <- liftIO $ DateUtil.utcToLocalDay since + R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day)) + + R.el "ul" $ + flip mapM_ (_init_users init) $ \user -> + R.el "li" $ + R.text $ do + let incomes = filter ((==) (_user_id user) . _income_userId) (_init_incomes init) + T.intercalate " " + [ _user_name user + , "−" + , Format.price (_init_currency init) $ + CM.cumulativeIncomesSince currentTime since incomes + ] + + R.divClass "titleButton" $ + R.el "h1" $ + R.text $ + Msg.get Msg.Income_MonthlyNet + + where + init = _headerIn_init headerIn + + useIncomesFrom = CM.useIncomesFrom + (map _user_id $_init_users init) + (_init_incomes init) + (_init_payments init) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 0fdd7d3..b0c6f0b 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -3,22 +3,14 @@ module View.Income.Income , IncomeIn(..) ) where -import Control.Monad.IO.Class (liftIO) -import qualified Data.List as L -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Time.Clock as Clock -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Income (..), Init (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format -import Component (TableIn (..)) -import qualified Component -import qualified Util.Date as DateUtil +import Common.Model (Init) +import View.Income.Header (HeaderIn (..)) +import qualified View.Income.Header as Header +import View.Income.Table (IncomeTableIn (..)) +import qualified View.Income.Table as Table data IncomeIn = IncomeIn { _incomeIn_init :: Init @@ -28,80 +20,12 @@ view :: forall t m. MonadWidget t m => IncomeIn -> m () view incomeIn = R.elClass "main" "income" $ do - header (_incomeIn_init incomeIn) + Header.view $ HeaderIn + { _headerIn_init = _incomeIn_init incomeIn + } - Component.table $ TableIn - { _tableIn_headerLabel = headerLabel - , _tableIn_rows = - R.constDyn - . reverse - . L.sortOn _income_date - . _init_incomes - . _incomeIn_init - $ incomeIn - , _tableIn_cell = cell (_incomeIn_init incomeIn) - , _tableIn_perPage = 7 - , _tableIn_resetPage = R.never + Table.view $ IncomeTableIn + { _tableIn_init = _incomeIn_init incomeIn } return () - -header :: forall t m. MonadWidget t m => Init -> m () -header init = - R.divClass "withMargin" $ do - - currentTime <- liftIO Clock.getCurrentTime - - Maybe.fromMaybe R.blank $ - flip fmap useIncomesFrom $ \since -> - R.el "div" $ do - - R.el "h1" $ do - day <- liftIO $ DateUtil.utcToLocalDay since - R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day)) - - R.el "ul" $ - flip mapM_ (_init_users init) $ \user -> - R.el "li" $ - R.text $ do - let incomes = filter ((==) (_user_id user) . _income_userId) (_init_incomes init) - T.intercalate " " - [ _user_name user - , "−" - , Format.price (_init_currency init) $ - CM.cumulativeIncomesSince currentTime since incomes - ] - - R.divClass "titleButton" $ - R.el "h1" $ - R.text $ - Msg.get Msg.Income_MonthlyNet - - where - useIncomesFrom = CM.useIncomesFrom - (map _user_id $_init_users init) - (_init_incomes init) - (_init_payments init) - -data Header - = UserHeader - | AmountHeader - | DateHeader - deriving (Eq, Show, Bounded, Enum) - -headerLabel :: Header -> Text -headerLabel UserHeader = Msg.get Msg.Income_Name -headerLabel DateHeader = Msg.get Msg.Income_Date -headerLabel AmountHeader = Msg.get Msg.Income_Amount - -cell :: Init -> Header -> Income -> Text -cell init header income = - case header of - UserHeader -> - Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init) - - DateHeader -> - Format.longDay . _income_date $ income - - AmountHeader -> - Format.price (_init_currency init) . _income_amount $ income diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs new file mode 100644 index 0000000..2e8f4e6 --- /dev/null +++ b/client/src/View/Income/Table.hs @@ -0,0 +1,63 @@ +module View.Income.Table + ( view + , IncomeTableIn(..) + ) where + +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Income (..), Init (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format +import Component (TableIn (..)) +import qualified Component + +data IncomeTableIn = IncomeTableIn + { _tableIn_init :: Init + } + +view :: forall t m. MonadWidget t m => IncomeTableIn -> m () +view tableIn = do + + Component.table $ TableIn + { _tableIn_headerLabel = headerLabel + , _tableIn_rows = + R.constDyn + . reverse + . L.sortOn _income_date + . _init_incomes + . _tableIn_init + $ tableIn + , _tableIn_cell = cell (_tableIn_init tableIn) + , _tableIn_perPage = 7 + , _tableIn_resetPage = R.never + } + + return () + +data Header + = UserHeader + | AmountHeader + | DateHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel UserHeader = Msg.get Msg.Income_Name +headerLabel DateHeader = Msg.get Msg.Income_Date +headerLabel AmountHeader = Msg.get Msg.Income_Amount + +cell :: Init -> Header -> Income -> Text +cell init header income = + case header of + UserHeader -> + Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init) + + DateHeader -> + Format.longDay . _income_date $ income + + AmountHeader -> + Format.price (_init_currency init) . _income_amount $ income -- cgit v1.2.3 From 7aadcc97f9df0e2daccbe8a8726d8bc6c63d67f4 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 12:02:21 +0200 Subject: Add income --- client/client.cabal | 2 + client/src/Component.hs | 1 - client/src/View/Income/Add.hs | 36 ++++++++++++ client/src/View/Income/Form.hs | 113 ++++++++++++++++++++++++++++++++++++++ client/src/View/Income/Header.hs | 55 ++++++++++++++----- client/src/View/Income/Income.hs | 21 +++++-- client/src/View/Income/Table.hs | 17 ++---- client/src/View/Payment/Delete.hs | 1 + client/src/View/Payment/Header.hs | 14 ++--- 9 files changed, 221 insertions(+), 39 deletions(-) create mode 100644 client/src/View/Income/Add.hs create mode 100644 client/src/View/Income/Form.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 06e77e0..bfcfc59 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -65,6 +65,8 @@ Executable client Util.WaitFor View.App View.Header + View.Income.Add + View.Income.Form View.Income.Header View.Income.Income View.Income.Table diff --git a/client/src/Component.hs b/client/src/Component.hs index 4c51750..b715a83 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -4,7 +4,6 @@ import Component.Button as X import Component.Form as X import Component.Input as X import Component.Link as X -import Component.Modal as X import Component.Pages as X import Component.Select as X import Component.Table as X diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs new file mode 100644 index 0000000..d83bb51 --- /dev/null +++ b/client/src/View/Income/Add.hs @@ -0,0 +1,36 @@ +module View.Income.Add + ( view + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Time.Clock as Time +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (CreateIncomeForm (..), Income) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import View.Income.Form (FormIn (..), FormOut (..)) +import qualified View.Income.Form as Form + +view :: forall t m. MonadWidget t m => Modal.Content t m Income +view cancel = do + + currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay + + form <- R.dyn $ + return $ Form.view $ FormIn + { _formIn_cancel = cancel + , _formIn_headerLabel = Msg.get Msg.Income_AddLong + , _formIn_amount = "" + , _formIn_date = currentDay + , _formIn_mkPayload = CreateIncomeForm + , _formIn_httpMethod = Form.Post + } + + hide <- ReflexUtil.flatten (_formOut_hide <$> form) + addIncome <- ReflexUtil.flatten (_formOut_addIncome <$> form) + + return (hide, addIncome) diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs new file mode 100644 index 0000000..b8a9094 --- /dev/null +++ b/client/src/View/Income/Form.hs @@ -0,0 +1,113 @@ +module View.Income.Form + ( view + , FormIn(..) + , HttpMethod(..) + , FormOut(..) + ) where + +import Data.Aeson (ToJSON) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import qualified Data.Validation as V +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Income) +import qualified Common.Msg as Msg +import qualified Common.Validation.Income as IncomeValidation +import Component (ButtonIn (..), InputIn (..), + InputOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor + +data FormIn t i = FormIn + { _formIn_cancel :: Event t () + , _formIn_headerLabel :: Text + , _formIn_amount :: Text + , _formIn_date :: Day + , _formIn_mkPayload :: Text -> Text -> i + , _formIn_httpMethod :: HttpMethod + } + +data HttpMethod = Put | Post + +data FormOut t = FormOut + { _formOut_hide :: Event t () + , _formOut_addIncome :: Event t Income + } + +view :: forall t m i. (MonadWidget t m, ToJSON i) => FormIn t i -> m (FormOut t) +view formIn = do + R.divClass "form" $ do + R.divClass "formHeader" $ + R.text (_formIn_headerLabel formIn) + + R.divClass "formContent" $ do + rec + let reset = R.leftmost + [ "" <$ cancel + , "" <$ addIncome + , "" <$ _formIn_cancel formIn + ] + + amount <- _inputOut_raw <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Income_Amount + , _inputIn_initialValue = _formIn_amount formIn + , _inputIn_validation = IncomeValidation.amount + }) + (_formIn_amount formIn <$ reset) + confirm) + + let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn + + date <- _inputOut_raw <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Income_Date + , _inputIn_initialValue = initialDate + , _inputIn_inputType = "date" + , _inputIn_hasResetButton = False + , _inputIn_validation = IncomeValidation.date + }) + (initialDate <$ reset) + confirm) + + let income = do + a <- amount + d <- date + return . V.Success $ (_formIn_mkPayload formIn) a d + + (addIncome, cancel, confirm) <- R.divClass "buttons" $ do + rec + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + confirm <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { _buttonIn_class = R.constDyn "confirm" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + }) + + (addIncome, waiting) <- WaitFor.waitFor + (ajax "/api/income") + (ValidationUtil.fireValidation income confirm) + + return (R.fmapMaybe EitherUtil.eitherToMaybe addIncome, cancel, confirm) + + return FormOut + { _formOut_hide = R.leftmost [ cancel, () <$ addIncome ] + , _formOut_addIncome = addIncome + } + + where + ajax = + case _formIn_httpMethod formIn of + Post -> Ajax.postJson + Put -> Ajax.putJson diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index b7170c9..e384161 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -1,33 +1,46 @@ module View.Income.Header ( view , HeaderIn(..) + , HeaderOut(..) ) where import Control.Monad.IO.Class (liftIO) import qualified Data.Maybe as Maybe import qualified Data.Text as T import qualified Data.Time.Clock as Clock -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Income (..), Init (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format +import Component (ButtonOut (..)) +import qualified Component +import qualified Component.Modal as Modal import qualified Util.Date as DateUtil +import qualified View.Income.Add as Add -data HeaderIn = HeaderIn - { _headerIn_init :: Init +data HeaderIn t = HeaderIn + { _headerIn_init :: Init + , _headerIn_incomes :: Dynamic t [Income] } -view :: forall t m. MonadWidget t m => HeaderIn -> m () +data HeaderOut t = HeaderOut + { _headerOut_addIncome :: Event t Income + } + +view :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) view headerIn = R.divClass "withMargin" $ do currentTime <- liftIO Clock.getCurrentTime - Maybe.fromMaybe R.blank $ - flip fmap useIncomesFrom $ \since -> + R.dyn . R.ffor useIncomesFrom $ \case + (Nothing, _) -> + R.blank + + (Just since, incomes) -> R.el "div" $ do R.el "h1" $ do @@ -38,23 +51,39 @@ view headerIn = flip mapM_ (_init_users init) $ \user -> R.el "li" $ R.text $ do - let incomes = filter ((==) (_user_id user) . _income_userId) (_init_incomes init) + let userIncomes = filter ((==) (_user_id user) . _income_userId) incomes T.intercalate " " [ _user_name user , "−" , Format.price (_init_currency init) $ - CM.cumulativeIncomesSince currentTime since incomes + CM.cumulativeIncomesSince currentTime since userIncomes ] - R.divClass "titleButton" $ + R.divClass "titleButton" $ do R.el "h1" $ R.text $ Msg.get Msg.Income_MonthlyNet + addIncome <- _buttonOut_clic <$> + (Component.button . Component.defaultButtonIn . R.text $ + Msg.get Msg.Income_AddLong) + + addIncome <- Modal.view $ Modal.Input + { Modal._input_show = addIncome + , Modal._input_content = Add.view + } + + return $ HeaderOut + { _headerOut_addIncome = addIncome + } + where init = _headerIn_init headerIn - useIncomesFrom = CM.useIncomesFrom - (map _user_id $_init_users init) - (_init_incomes init) - (_init_payments init) + useIncomesFrom = R.ffor (_headerIn_incomes headerIn) $ \incomes -> + ( CM.useIncomesFrom + (map _user_id $_init_users init) + incomes + (_init_payments init) + , incomes + ) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index b0c6f0b..167aedf 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -3,11 +3,11 @@ module View.Income.Income , IncomeIn(..) ) where -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init) -import View.Income.Header (HeaderIn (..)) +import Common.Model (Init (..)) +import View.Income.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Income.Header as Header import View.Income.Table (IncomeTableIn (..)) import qualified View.Income.Table as Table @@ -20,12 +20,21 @@ view :: forall t m. MonadWidget t m => IncomeIn -> m () view incomeIn = R.elClass "main" "income" $ do - Header.view $ HeaderIn - { _headerIn_init = _incomeIn_init incomeIn - } + rec + + incomes <- R.foldDyn + (:) + (_init_incomes . _incomeIn_init $ incomeIn) + (_headerOut_addIncome header) + + header <- Header.view $ HeaderIn + { _headerIn_init = _incomeIn_init incomeIn + , _headerIn_incomes = incomes + } Table.view $ IncomeTableIn { _tableIn_init = _incomeIn_init incomeIn + , _tableIn_incomes = incomes } return () diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 2e8f4e6..5363ca5 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -6,7 +6,7 @@ module View.Income.Table import qualified Data.List as L import qualified Data.Maybe as Maybe import Data.Text (Text) -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Income (..), Init (..), User (..)) @@ -16,22 +16,17 @@ import qualified Common.View.Format as Format import Component (TableIn (..)) import qualified Component -data IncomeTableIn = IncomeTableIn - { _tableIn_init :: Init +data IncomeTableIn t = IncomeTableIn + { _tableIn_init :: Init + , _tableIn_incomes :: Dynamic t [Income] } -view :: forall t m. MonadWidget t m => IncomeTableIn -> m () +view :: forall t m. MonadWidget t m => IncomeTableIn t -> m () view tableIn = do Component.table $ TableIn { _tableIn_headerLabel = headerLabel - , _tableIn_rows = - R.constDyn - . reverse - . L.sortOn _income_date - . _init_incomes - . _tableIn_init - $ tableIn + , _tableIn_rows = R.ffor (_tableIn_incomes tableIn) $ reverse . L.sortOn _income_date , _tableIn_cell = cell (_tableIn_init tableIn) , _tableIn_perPage = 7 , _tableIn_resetPage = R.never diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 521c1a7..dc7e395 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -13,6 +13,7 @@ import qualified Common.Msg as Msg import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component import qualified Component.Modal as Modal +import qualified Component.Modal as Modal import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil import qualified Util.WaitFor as WaitFor diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 6ed3b0e..9db4c7c 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -111,16 +111,14 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen R.dynText . R.ffor exceedingPayer $ \ep -> Format.price currency $ _exceedingPayer_amount ep - addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn - { _buttonIn_class = R.constDyn "addPayment" - , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add - , _buttonIn_waiting = R.never - , _buttonIn_tabIndex = Nothing - , _buttonIn_submit = False - }) + addPayment <- _buttonOut_clic <$> + (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Payment_Add)) + { _buttonIn_class = R.constDyn "addPayment" + }) Modal.view $ Modal.Input - { Modal._input_show = addPaymentClic + { Modal._input_show = addPayment , Modal._input_content = Add.view $ Add.Input { Add._input_categories = categories , Add._input_paymentCategories = paymentCategories -- cgit v1.2.3 From 602c52acfcfa494b07fec05c20b317b60ea8a6f3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 21:31:57 +0200 Subject: Load init data per page with AJAX --- client/client.cabal | 3 + client/src/Model/Loadable.hs | 51 ++++++++++++ client/src/Util/Ajax.hs | 21 +++-- client/src/View/App.hs | 16 ++-- client/src/View/Header.hs | 2 +- client/src/View/Income/Form.hs | 4 +- client/src/View/Income/Header.hs | 11 ++- client/src/View/Income/Income.hs | 73 +++++++++++----- client/src/View/Income/Init.hs | 11 +++ client/src/View/Income/Table.hs | 17 ++-- client/src/View/Payment/Form.hs | 4 +- client/src/View/Payment/Header.hs | 6 +- client/src/View/Payment/Init.hs | 13 +++ client/src/View/Payment/Payment.hs | 165 +++++++++++++++++++++++-------------- client/src/View/Payment/Table.hs | 21 +++-- client/src/View/SignIn.hs | 2 +- 16 files changed, 301 insertions(+), 119 deletions(-) create mode 100644 client/src/Model/Loadable.hs create mode 100644 client/src/View/Income/Init.hs create mode 100644 client/src/View/Payment/Init.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index bfcfc59..9a0d24e 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -54,6 +54,8 @@ Executable client Component.Table Component.Select Icon + Model.Loadable + Model.Route Util.Ajax Util.Css Util.Date @@ -77,6 +79,7 @@ Executable client View.Payment.Edit View.Payment.Form View.Payment.Header + View.Payment.Init View.Payment.Pages View.Payment.Payment View.Payment.Table diff --git a/client/src/Model/Loadable.hs b/client/src/Model/Loadable.hs new file mode 100644 index 0000000..3076b46 --- /dev/null +++ b/client/src/Model/Loadable.hs @@ -0,0 +1,51 @@ +module Model.Loadable + ( Loadable (..) + , fromEvent + , view + ) where + +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Data.Functor (Functor) +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +data Loadable t + = Loading + | Error Text + | Loaded t + +instance Functor Loadable where + fmap f Loading = Loading + fmap f (Error e) = Error e + fmap f (Loaded x) = Loaded (f x) + +instance Applicative Loadable where + pure x = Loaded x + + Loading <*> _ = Loading + (Error e) <*> _ = Error e + (Loaded f) <*> Loading = Loading + (Loaded f) <*> (Error e) = Error e + (Loaded f) <*> (Loaded x) = Loaded (f x) + +instance Monad Loadable where + Loading >>= f = Loading + (Error e) >>= f = Error e + (Loaded x) >>= f = f x + +fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a)) +fromEvent = + R.foldDyn + (\res _ -> case res of + Left err -> Error err + Right t -> Loaded t + ) + Loading + +view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m () +view _ (Loading) = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank +view _ (Error e) = R.text e +view f (Loaded x) = f x diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index a4f6a74..9cd5105 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -1,6 +1,7 @@ module Util.Ajax - ( postJson - , putJson + ( get + , post + , put , delete ) where @@ -20,21 +21,29 @@ import Reflex.Dom (Dynamic, Event, IsXhrPayload, XhrResponseHeaders (..)) import qualified Reflex.Dom as R -postJson +get + :: forall t m a. (MonadWidget t m, FromJSON a) + => Event t Text + -> m (Event t (Either Text a)) +get url = + fmap getJsonResult <$> + R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String "")) + +post :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) => Text -> Event t a -> m (Event t (Either Text b)) -postJson url input = +post url input = fmap getJsonResult <$> R.performRequestAsync (jsonRequest "POST" url <$> input) -putJson +put :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) => Text -> Event t a -> m (Event t (Either Text b)) -putJson url input = +put url input = fmap getJsonResult <$> R.performRequestAsync (jsonRequest "PUT" url <$> input) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 3292336..b468e56 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -7,7 +7,8 @@ import Prelude hiding (error, init) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init, InitResult (..)) +import Common.Model (Currency, Init (..), InitResult (..), + UserId) import qualified Common.Msg as Msg import Model.Route (Route (..)) @@ -60,14 +61,19 @@ widget initResult = signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () signedWidget init route = do R.dyn . R.ffor route $ \case - RootRoute -> + RootRoute -> do + paymentInit <- Payment.init Payment.view $ PaymentIn - { _paymentIn_init = init + { _paymentIn_currentUser = _init_currentUser init + , _paymentIn_currency = _init_currency init + , _paymentIn_init = paymentInit } - IncomeRoute -> + IncomeRoute -> do + incomeInit <- Income.init Income.view $ IncomeIn - { _incomeIn_init = init + { _incomeIn_currency = _init_currency init + , _incomeIn_init = incomeInit } NotFoundRoute -> diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 9a4de89..bd69e47 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -73,7 +73,7 @@ links route = do nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) nameSignOut initResult = case initResult of - (InitSuccess init) -> do + InitSuccess init -> do rec attr <- R.holdDyn (M.singleton "class" "nameSignOut") diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index b8a9094..2bfc23f 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -109,5 +109,5 @@ view formIn = do where ajax = case _formIn_httpMethod formIn of - Post -> Ajax.postJson - Put -> Ajax.putJson + Post -> Ajax.post + Put -> Ajax.put diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index e384161..4e08955 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -11,19 +11,22 @@ import qualified Data.Time.Clock as Clock import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Income (..), Init (..), User (..)) +import Common.Model (Currency, Income (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format + import Component (ButtonOut (..)) import qualified Component import qualified Component.Modal as Modal import qualified Util.Date as DateUtil import qualified View.Income.Add as Add +import View.Income.Init (Init (..)) data HeaderIn t = HeaderIn - { _headerIn_init :: Init - , _headerIn_incomes :: Dynamic t [Income] + { _headerIn_init :: Init + , _headerIn_currency :: Currency + , _headerIn_incomes :: Dynamic t [Income] } data HeaderOut t = HeaderOut @@ -55,7 +58,7 @@ view headerIn = T.intercalate " " [ _user_name user , "−" - , Format.price (_init_currency init) $ + , Format.price (_headerIn_currency headerIn) $ CM.cumulativeIncomesSince currentTime since userIncomes ] diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 167aedf..91682a0 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -1,40 +1,73 @@ module View.Income.Income - ( view + ( init + , view , IncomeIn(..) ) where +import Prelude hiding (init) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init (..)) +import Common.Model (Currency) + +import Model.Loadable (Loadable (..)) +import qualified Model.Loadable as Loadable +import qualified Util.Ajax as AjaxUtil import View.Income.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Income.Header as Header +import View.Income.Init (Init (..)) import View.Income.Table (IncomeTableIn (..)) import qualified View.Income.Table as Table -data IncomeIn = IncomeIn - { _incomeIn_init :: Init +data IncomeIn t = IncomeIn + { _incomeIn_currency :: Currency + , _incomeIn_init :: Dynamic t (Loadable Init) } -view :: forall t m. MonadWidget t m => IncomeIn -> m () -view incomeIn = - R.elClass "main" "income" $ do +init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) +init = do + postBuild <- R.getPostBuild + + usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild) + users <- Loadable.fromEvent usersEvent + + incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild) + incomes <- Loadable.fromEvent incomesEvent + + paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild) + payments <- Loadable.fromEvent paymentsEvent + + return $ do + us <- users + is <- incomes + ps <- payments + return $ Init <$> us <*> is <*> ps + +view :: forall t m. MonadWidget t m => IncomeIn t -> m () +view incomeIn = do + R.dyn . R.ffor (_incomeIn_init incomeIn) . Loadable.view $ \init -> + + R.elClass "main" "income" $ do + + rec - rec + incomes <- R.foldDyn + (:) + (_init_incomes init) + (_headerOut_addIncome header) - incomes <- R.foldDyn - (:) - (_init_incomes . _incomeIn_init $ incomeIn) - (_headerOut_addIncome header) + header <- Header.view $ HeaderIn + { _headerIn_init = init + , _headerIn_currency = _incomeIn_currency incomeIn + , _headerIn_incomes = incomes + } - header <- Header.view $ HeaderIn - { _headerIn_init = _incomeIn_init incomeIn - , _headerIn_incomes = incomes + Table.view $ IncomeTableIn + { _tableIn_init = init + , _tableIn_currency = _incomeIn_currency incomeIn + , _tableIn_incomes = incomes } - Table.view $ IncomeTableIn - { _tableIn_init = _incomeIn_init incomeIn - , _tableIn_incomes = incomes - } + return () - return () + return () diff --git a/client/src/View/Income/Init.hs b/client/src/View/Income/Init.hs new file mode 100644 index 0000000..4f3ef99 --- /dev/null +++ b/client/src/View/Income/Init.hs @@ -0,0 +1,11 @@ +module View.Income.Init + ( Init(..) + ) where + +import Common.Model (Income, Payment, User) + +data Init = Init + { _init_users :: [User] + , _init_incomes :: [Income] + , _init_payments :: [Payment] + } deriving (Show) diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 5363ca5..d42848b 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -9,16 +9,19 @@ import Data.Text (Text) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Income (..), Init (..), User (..)) +import Common.Model (Currency, Income (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format + import Component (TableIn (..)) import qualified Component +import View.Income.Init (Init (..)) data IncomeTableIn t = IncomeTableIn - { _tableIn_init :: Init - , _tableIn_incomes :: Dynamic t [Income] + { _tableIn_init :: Init + , _tableIn_currency :: Currency + , _tableIn_incomes :: Dynamic t [Income] } view :: forall t m. MonadWidget t m => IncomeTableIn t -> m () @@ -27,7 +30,7 @@ view tableIn = do Component.table $ TableIn { _tableIn_headerLabel = headerLabel , _tableIn_rows = R.ffor (_tableIn_incomes tableIn) $ reverse . L.sortOn _income_date - , _tableIn_cell = cell (_tableIn_init tableIn) + , _tableIn_cell = cell (_tableIn_init tableIn) (_tableIn_currency tableIn) , _tableIn_perPage = 7 , _tableIn_resetPage = R.never } @@ -45,8 +48,8 @@ headerLabel UserHeader = Msg.get Msg.Income_Name headerLabel DateHeader = Msg.get Msg.Income_Date headerLabel AmountHeader = Msg.get Msg.Income_Amount -cell :: Init -> Header -> Income -> Text -cell init header income = +cell :: Init -> Currency -> Header -> Income -> Text +cell init currency header income = case header of UserHeader -> Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init) @@ -55,4 +58,4 @@ cell init header income = Format.longDay . _income_date $ income AmountHeader -> - Format.price (_init_currency init) . _income_amount $ income + Format.price currency . _income_amount $ income diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 7819836..c817831 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -165,8 +165,8 @@ view input = do ajax = case _input_httpMethod input of - Post -> Ajax.postJson - Put -> Ajax.putJson + Post -> Ajax.post + Put -> Ajax.put findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId findCategory paymentName = diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 9db4c7c..9ad90a9 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -20,7 +20,7 @@ import qualified Reflex.Dom as R import Common.Model (Category, Currency, ExceedingPayer (..), Frequency (..), - Income (..), Init (..), Payment (..), + Income (..), Payment (..), PaymentCategory, SavedPayment (..), User (..)) import qualified Common.Model as CM @@ -34,9 +34,11 @@ import qualified Component as Component import qualified Component.Modal as Modal import qualified Util.List as L import qualified View.Payment.Add as Add +import View.Payment.Init (Init (..)) data HeaderIn t = HeaderIn { _headerIn_init :: Init + , _headerIn_currency :: Currency , _headerIn_payments :: Dynamic t [Payment] , _headerIn_searchPayments :: Dynamic t [Payment] , _headerIn_paymentCategories :: Dynamic t [PaymentCategory] @@ -78,7 +80,7 @@ widget headerIn = payments = _headerIn_payments headerIn users = _init_users init categories = _init_categories init - currency = _init_currency init + currency = _headerIn_currency headerIn paymentCategories = _headerIn_paymentCategories headerIn payerAndAdd diff --git a/client/src/View/Payment/Init.hs b/client/src/View/Payment/Init.hs new file mode 100644 index 0000000..d9f85c8 --- /dev/null +++ b/client/src/View/Payment/Init.hs @@ -0,0 +1,13 @@ +module View.Payment.Init + ( Init(..) + ) where + +import Common.Model (Category, Income, Payment, PaymentCategory, User) + +data Init = Init + { _init_users :: [User] + , _init_payments :: [Payment] + , _init_incomes :: [Income] + , _init_categories :: [Category] + , _init_paymentCategories :: [PaymentCategory] + } deriving (Show) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index cfdb441..ec350e2 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -1,5 +1,6 @@ module View.Payment.Payment - ( view + ( init + , view , PaymentIn(..) ) where @@ -10,78 +11,118 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Frequency, Init (..), Payment (..), - PaymentCategory (..), PaymentId, - SavedPayment (..)) +import Common.Model (Currency, Frequency, Income (..), + Payment (..), PaymentCategory (..), + PaymentId, SavedPayment (..), User, + UserId) import qualified Common.Util.Text as T + +import Model.Loadable (Loadable (..)) +import qualified Model.Loadable as Loadable +import qualified Util.Ajax as AjaxUtil import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header +import View.Payment.Init (Init (..)) import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages import View.Payment.Table (TableIn (..), TableOut (..)) import qualified View.Payment.Table as Table -data PaymentIn = PaymentIn - { _paymentIn_init :: Init +init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) +init = do + postBuild <- R.getPostBuild + + incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild) + incomes <- Loadable.fromEvent incomesEvent + + usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild) + users <- Loadable.fromEvent usersEvent + + paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild) + payments <- Loadable.fromEvent paymentsEvent + + paymentCategoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/paymentCategories") postBuild) + paymentCategories <- Loadable.fromEvent paymentCategoriesEvent + + categoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/categories") postBuild) + categories <- Loadable.fromEvent categoriesEvent + + return $ do + us <- users + ps <- payments + is <- incomes + cs <- categories + pcs <- paymentCategories + return $ Init <$> us <*> ps <*> is <*> cs <*> pcs + +data PaymentIn t = PaymentIn + { _paymentIn_currentUser :: UserId + , _paymentIn_currency :: Currency + , _paymentIn_init :: Dynamic t (Loadable Init) } -view :: forall t m. MonadWidget t m => PaymentIn -> m () +view :: forall t m. MonadWidget t m => PaymentIn t -> m () view paymentIn = do - R.elClass "main" "payment" $ do - rec - let init = _paymentIn_init paymentIn - - paymentsPerPage = 7 - - addPayment = R.leftmost - [ _headerOut_addPayment header - , _tableOut_addPayment table - ] - - payments <- reducePayments - (_init_payments init) - (_savedPayment_payment <$> addPayment) - (_savedPayment_payment <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) - - paymentCategories <- reducePaymentCategories - (_init_paymentCategories init) - payments - (_savedPayment_paymentCategory <$> addPayment) - (_savedPayment_paymentCategory <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) - - (searchNameEvent, searchName) <- - debounceSearchName (_headerOut_searchName header) - - let searchPayments = - getSearchPayments searchName (_headerOut_searchFrequency header) payments - - header <- Header.widget $ HeaderIn - { _headerIn_init = init - , _headerIn_payments = payments - , _headerIn_searchPayments = searchPayments - , _headerIn_paymentCategories = paymentCategories - } - - table <- Table.widget $ TableIn - { _tableIn_init = init - , _tableIn_currentPage = _pagesOut_currentPage pages - , _tableIn_payments = searchPayments - , _tableIn_perPage = paymentsPerPage - , _tableIn_paymentCategories = paymentCategories - } - - pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> searchPayments - , _pagesIn_perPage = paymentsPerPage - , _pagesIn_reset = R.leftmost $ - [ () <$ searchNameEvent - , () <$ _headerOut_addPayment header - ] - } - - pure () + R.dyn . R.ffor (_paymentIn_init paymentIn) . Loadable.view $ \init -> + + R.elClass "main" "payment" $ do + rec + let addPayment = R.leftmost + [ _headerOut_addPayment header + , _tableOut_addPayment table + ] + + paymentsPerPage = 7 + + payments <- reducePayments + (_init_payments init) + (_savedPayment_payment <$> addPayment) + (_savedPayment_payment <$> _tableOut_editPayment table) + (_tableOut_deletePayment table) + + paymentCategories <- reducePaymentCategories + (_init_paymentCategories init) + payments + (_savedPayment_paymentCategory <$> addPayment) + (_savedPayment_paymentCategory <$> _tableOut_editPayment table) + (_tableOut_deletePayment table) + + (searchNameEvent, searchName) <- + debounceSearchName (_headerOut_searchName header) + + let searchPayments = + getSearchPayments searchName (_headerOut_searchFrequency header) payments + + header <- Header.widget $ HeaderIn + { _headerIn_init = init + , _headerIn_currency = _paymentIn_currency paymentIn + , _headerIn_payments = payments + , _headerIn_searchPayments = searchPayments + , _headerIn_paymentCategories = paymentCategories + } + + table <- Table.widget $ TableIn + { _tableIn_init = init + , _tableIn_currency = _paymentIn_currency paymentIn + , _tableIn_currentUser = _paymentIn_currentUser paymentIn + , _tableIn_currentPage = _pagesOut_currentPage pages + , _tableIn_payments = searchPayments + , _tableIn_perPage = paymentsPerPage + , _tableIn_paymentCategories = paymentCategories + } + + pages <- Pages.widget $ PagesIn + { _pagesIn_total = length <$> searchPayments + , _pagesIn_perPage = paymentsPerPage + , _pagesIn_reset = R.leftmost $ + [ () <$ searchNameEvent + , () <$ _headerOut_addPayment header + ] + } + + pure () + + return () debounceSearchName :: forall t m. MonadWidget t m diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index bf6b604..5ffa037 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -13,10 +13,10 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Category (..), Frequency (Punctual), - Init (..), Payment (..), +import Common.Model (Category (..), Currency, + Frequency (Punctual), Payment (..), PaymentCategory (..), SavedPayment, - User (..)) + User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -26,12 +26,15 @@ import qualified Component.Modal as Modal import qualified View.Payment.Clone as Clone import qualified View.Payment.Delete as Delete import qualified View.Payment.Edit as Edit +import View.Payment.Init (Init (..)) import qualified Icon import qualified Util.Reflex as ReflexUtil data TableIn t = TableIn { _tableIn_init :: Init + , _tableIn_currency :: Currency + , _tableIn_currentUser :: UserId , _tableIn_currentPage :: Dynamic t Int , _tableIn_payments :: Dynamic t [Payment] , _tableIn_perPage :: Int @@ -61,7 +64,7 @@ widget tableIn = do R.divClass "cell" $ R.blank result <- - (R.simpleList paymentRange (paymentRow init paymentCategories)) + (R.simpleList paymentRange (paymentRow init currency currentUser paymentCategories)) return $ ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result @@ -80,6 +83,8 @@ widget tableIn = do where init = _tableIn_init tableIn + currency = _tableIn_currency tableIn + currentUser = _tableIn_currentUser tableIn currentPage = _tableIn_currentPage tableIn payments = _tableIn_payments tableIn paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage @@ -96,17 +101,19 @@ getPaymentRange perPage payments currentPage = paymentRow :: forall t m. MonadWidget t m => Init + -> Currency + -> UserId -> Dynamic t [PaymentCategory] -> Dynamic t Payment -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment) -paymentRow init paymentCategories payment = +paymentRow init currency currentUser paymentCategories payment = R.divClass "row" $ do R.divClass "cell name" $ R.dynText $ fmap _payment_name payment R.divClass "cell cost" $ - R.dynText $ fmap (Format.price (_init_currency init) . _payment_cost) payment + R.dynText $ fmap (Format.price currency . _payment_cost) payment let user = R.ffor payment (\p -> CM.findUser (_payment_user p) (_init_users init)) @@ -162,7 +169,7 @@ paymentRow init paymentCategories payment = let isFromCurrentUser = R.ffor payment - (\p -> _payment_user p == _init_currentUser init) + (\p -> _payment_user p == currentUser) editPayment <- R.divClass "cell button" $ diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 8c248bd..4fe495b 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -50,7 +50,7 @@ view signInMessage = let form = SignInForm <$> _inputOut_raw input (signInResult, waiting) <- WaitFor.waitFor - (Ajax.postJson "/api/askSignIn") + (Ajax.post "/api/askSignIn") (ValidationUtil.fireMaybe ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) -- cgit v1.2.3 From 33e78f2ebbf5bf7b40e7aa732cc7c019f6df3f12 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 22:08:31 +0200 Subject: Simplify page initialization --- client/client.cabal | 6 ++-- client/src/Component/Button.hs | 2 +- client/src/Component/Input.hs | 2 +- client/src/Component/Pages.hs | 2 +- client/src/Icon.hs | 71 -------------------------------------- client/src/Loadable.hs | 51 +++++++++++++++++++++++++++ client/src/Model/Loadable.hs | 51 --------------------------- client/src/Util/Ajax.hs | 11 +++++- client/src/View/Header.hs | 2 +- client/src/View/Icon.hs | 71 ++++++++++++++++++++++++++++++++++++++ client/src/View/Income/Income.hs | 19 ++++------ client/src/View/Payment/Pages.hs | 2 +- client/src/View/Payment/Payment.hs | 27 +++++---------- client/src/View/Payment/Table.hs | 2 +- 14 files changed, 155 insertions(+), 164 deletions(-) delete mode 100644 client/src/Icon.hs create mode 100644 client/src/Loadable.hs delete mode 100644 client/src/Model/Loadable.hs create mode 100644 client/src/View/Icon.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 9a0d24e..9e0a47e 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -51,10 +51,9 @@ Executable client Component.Link Component.Modal Component.Pages - Component.Table Component.Select - Icon - Model.Loadable + Component.Table + Loadable Model.Route Util.Ajax Util.Css @@ -67,6 +66,7 @@ Executable client Util.WaitFor View.App View.Header + View.Icon View.Income.Add View.Income.Form View.Income.Header diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 46c0afa..b1175d7 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -12,7 +12,7 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import qualified Icon +import qualified View.Icon as Icon data ButtonIn t m = ButtonIn { _buttonIn_class :: Dynamic t Text diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 0c84754..9ab4d58 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -19,7 +19,7 @@ import qualified Reflex.Dom as R import qualified Common.Util.Validation as ValidationUtil import Component.Button (ButtonIn (..), ButtonOut (..)) import qualified Component.Button as Button -import qualified Icon +import qualified View.Icon as Icon data InputIn a = InputIn { _inputIn_hasResetButton :: Bool diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs index 5611cb7..7843ef6 100644 --- a/client/src/Component/Pages.hs +++ b/client/src/Component/Pages.hs @@ -11,8 +11,8 @@ import qualified Reflex.Dom as R import Component.Button (ButtonIn (..), ButtonOut (..)) import qualified Component.Button as Button -import qualified Icon import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon data PagesIn t = PagesIn { _pagesIn_total :: Dynamic t Int diff --git a/client/src/Icon.hs b/client/src/Icon.hs deleted file mode 100644 index 1a45933..0000000 --- a/client/src/Icon.hs +++ /dev/null @@ -1,71 +0,0 @@ -module Icon - ( clone - , cross - , delete - , edit - , loading - , doubleLeft - , doubleLeftBar - , doubleRight - , doubleRightBar - , signOut - ) where - -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -clone :: forall t m. MonadWidget t m => m () -clone = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank - -cross :: forall t m. MonadWidget t m => m () -cross = - svgAttr "svg" (M.fromList [ ("width", "15"), ("height", "15"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M1490 1322q0 40-28 68l-136 136q-28 28-68 28t-68-28l-294-294-294 294q-28 28-68 28t-68-28l-136-136q-28-28-28-68t28-68l294-294-294-294q-28-28-28-68t28-68l136-136q28-28 68-28t68 28l294 294 294-294q28-28 68-28t68 28l136 136q28 28 28 68t-28 68l-294 294 294 294q28 28 28 68z")]) $ R.blank - -delete :: forall t m. MonadWidget t m => m () -delete = - svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M704 1376v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm-544-992h448l-48-117q-7-9-17-11h-317q-10 2-17 11zm928 32v64q0 14-9 23t-23 9h-96v948q0 83-47 143.5t-113 60.5h-832q-66 0-113-58.5t-47-141.5v-952h-96q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h309l70-167q15-37 54-63t79-26h320q40 0 79 26t54 63l70 167h309q14 0 23 9t9 23z")]) $ R.blank - -doubleLeft :: forall t m. MonadWidget t m => m () -doubleLeft = - svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M1683 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-8-9-13-19v710q0 26-13 32t-32-13l-710-710q-19-19-19-45t19-45l710-710q19-19 32-13t13 32v710q5-11 13-19z")]) $ R.blank - -doubleLeftBar :: forall t m. MonadWidget t m => m () -doubleLeftBar = - svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M1747 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-9-9-13-19v710q0 26-13 32t-32-13l-710-710q-9-9-13-19v678q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-1408q0-26 19-45t45-19h128q26 0 45 19t19 45v678q4-11 13-19l710-710q19-19 32-13t13 32v710q4-11 13-19z")]) $ R.blank - -doubleRight :: forall t m. MonadWidget t m => m () -doubleRight = - svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M109 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q19 19 19 45t-19 45l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank - -doubleRightBar :: forall t m. MonadWidget t m => m () -doubleRightBar = - svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M45 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q8 8 13 19v-678q0-26 19-45t45-19h128q26 0 45 19t19 45v1408q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-678q-5 10-13 19l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank - -edit :: forall t m. MonadWidget t m => m () -edit = - svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M491 1536l91-91-235-235-91 91v107h128v128h107zm523-928q0-22-22-22-10 0-17 7l-542 542q-7 7-7 17 0 22 22 22 10 0 17-7l542-542q7-7 7-17zm-54-192l416 416-832 832h-416v-416zm683 96q0 53-37 90l-166 166-416-416 166-165q36-38 90-38 53 0 91 38l235 234q37 39 37 91z")]) $ R.blank - -loading :: forall t m. MonadWidget t m => m () -loading = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader"), ("fill", "currentColor") ]) $ - svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank - -signOut :: forall t m. MonadWidget t m => m () -signOut = - svgAttr "svg" (M.fromList [ ("width", "30"), ("height", "30"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M1664 896q0 156-61 298t-164 245-245 164-298 61-298-61-245-164-164-245-61-298q0-182 80.5-343t226.5-270q43-32 95.5-25t83.5 50q32 42 24.5 94.5t-49.5 84.5q-98 74-151.5 181t-53.5 228q0 104 40.5 198.5t109.5 163.5 163.5 109.5 198.5 40.5 198.5-40.5 163.5-109.5 109.5-163.5 40.5-198.5q0-121-53.5-228t-151.5-181q-42-32-49.5-84.5t24.5-94.5q31-43 84-50t95 25q146 109 226.5 270t80.5 343zm-640-768v640q0 52-38 90t-90 38-90-38-38-90v-640q0-52 38-90t90-38 90 38 38 90z")]) $ R.blank - -svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a -svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs new file mode 100644 index 0000000..8714a4d --- /dev/null +++ b/client/src/Loadable.hs @@ -0,0 +1,51 @@ +module Loadable + ( Loadable (..) + , fromEvent + , view + ) where + +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Data.Functor (Functor) +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +data Loadable t + = Loading + | Error Text + | Loaded t + +instance Functor Loadable where + fmap f Loading = Loading + fmap f (Error e) = Error e + fmap f (Loaded x) = Loaded (f x) + +instance Applicative Loadable where + pure x = Loaded x + + Loading <*> _ = Loading + (Error e) <*> _ = Error e + (Loaded f) <*> Loading = Loading + (Loaded f) <*> (Error e) = Error e + (Loaded f) <*> (Loaded x) = Loaded (f x) + +instance Monad Loadable where + Loading >>= f = Loading + (Error e) >>= f = Error e + (Loaded x) >>= f = f x + +fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a)) +fromEvent = + R.foldDyn + (\res _ -> case res of + Left err -> Error err + Right t -> Loaded t + ) + Loading + +view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m () +view _ (Loading) = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank +view _ (Error e) = R.text e +view f (Loaded x) = f x diff --git a/client/src/Model/Loadable.hs b/client/src/Model/Loadable.hs deleted file mode 100644 index 3076b46..0000000 --- a/client/src/Model/Loadable.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Model.Loadable - ( Loadable (..) - , fromEvent - , view - ) where - -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -import Data.Functor (Functor) -import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -data Loadable t - = Loading - | Error Text - | Loaded t - -instance Functor Loadable where - fmap f Loading = Loading - fmap f (Error e) = Error e - fmap f (Loaded x) = Loaded (f x) - -instance Applicative Loadable where - pure x = Loaded x - - Loading <*> _ = Loading - (Error e) <*> _ = Error e - (Loaded f) <*> Loading = Loading - (Loaded f) <*> (Error e) = Error e - (Loaded f) <*> (Loaded x) = Loaded (f x) - -instance Monad Loadable where - Loading >>= f = Loading - (Error e) >>= f = Error e - (Loaded x) >>= f = f x - -fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a)) -fromEvent = - R.foldDyn - (\res _ -> case res of - Left err -> Error err - Right t -> Loaded t - ) - Loading - -view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m () -view _ (Loading) = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank -view _ (Error e) = R.text e -view f (Loaded x) = f x diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 9cd5105..47f4f3c 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -1,5 +1,6 @@ module Util.Ajax - ( get + ( getNow + , get , post , put , delete @@ -21,6 +22,14 @@ import Reflex.Dom (Dynamic, Event, IsXhrPayload, XhrResponseHeaders (..)) import qualified Reflex.Dom as R +import Loadable (Loadable) +import qualified Loadable + +getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a)) +getNow url = do + postBuild <- R.getPostBuild + get (R.tag (R.constant url) postBuild) >>= Loadable.fromEvent + get :: forall t m a. (MonadWidget t m, FromJSON a) => Event t Text diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index bd69e47..68329eb 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -18,10 +18,10 @@ import qualified Common.Model as CM import qualified Common.Msg as Msg import Component (ButtonIn (..)) import qualified Component as Component -import qualified Icon import Model.Route (Route (..)) import qualified Util.Css as CssUtil import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon data HeaderIn t = HeaderIn { _headerIn_initResult :: InitResult diff --git a/client/src/View/Icon.hs b/client/src/View/Icon.hs new file mode 100644 index 0000000..cc2ef3f --- /dev/null +++ b/client/src/View/Icon.hs @@ -0,0 +1,71 @@ +module View.Icon + ( clone + , cross + , delete + , edit + , loading + , doubleLeft + , doubleLeftBar + , doubleRight + , doubleRightBar + , signOut + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +clone :: forall t m. MonadWidget t m => m () +clone = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank + +cross :: forall t m. MonadWidget t m => m () +cross = + svgAttr "svg" (M.fromList [ ("width", "15"), ("height", "15"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1490 1322q0 40-28 68l-136 136q-28 28-68 28t-68-28l-294-294-294 294q-28 28-68 28t-68-28l-136-136q-28-28-28-68t28-68l294-294-294-294q-28-28-28-68t28-68l136-136q28-28 68-28t68 28l294 294 294-294q28-28 68-28t68 28l136 136q28 28 28 68t-28 68l-294 294 294 294q28 28 28 68z")]) $ R.blank + +delete :: forall t m. MonadWidget t m => m () +delete = + svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M704 1376v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm-544-992h448l-48-117q-7-9-17-11h-317q-10 2-17 11zm928 32v64q0 14-9 23t-23 9h-96v948q0 83-47 143.5t-113 60.5h-832q-66 0-113-58.5t-47-141.5v-952h-96q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h309l70-167q15-37 54-63t79-26h320q40 0 79 26t54 63l70 167h309q14 0 23 9t9 23z")]) $ R.blank + +doubleLeft :: forall t m. MonadWidget t m => m () +doubleLeft = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1683 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-8-9-13-19v710q0 26-13 32t-32-13l-710-710q-19-19-19-45t19-45l710-710q19-19 32-13t13 32v710q5-11 13-19z")]) $ R.blank + +doubleLeftBar :: forall t m. MonadWidget t m => m () +doubleLeftBar = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1747 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-9-9-13-19v710q0 26-13 32t-32-13l-710-710q-9-9-13-19v678q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-1408q0-26 19-45t45-19h128q26 0 45 19t19 45v678q4-11 13-19l710-710q19-19 32-13t13 32v710q4-11 13-19z")]) $ R.blank + +doubleRight :: forall t m. MonadWidget t m => m () +doubleRight = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M109 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q19 19 19 45t-19 45l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank + +doubleRightBar :: forall t m. MonadWidget t m => m () +doubleRightBar = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M45 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q8 8 13 19v-678q0-26 19-45t45-19h128q26 0 45 19t19 45v1408q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-678q-5 10-13 19l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank + +edit :: forall t m. MonadWidget t m => m () +edit = + svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M491 1536l91-91-235-235-91 91v107h128v128h107zm523-928q0-22-22-22-10 0-17 7l-542 542q-7 7-7 17 0 22 22 22 10 0 17-7l542-542q7-7 7-17zm-54-192l416 416-832 832h-416v-416zm683 96q0 53-37 90l-166 166-416-416 166-165q36-38 90-38 53 0 91 38l235 234q37 39 37 91z")]) $ R.blank + +loading :: forall t m. MonadWidget t m => m () +loading = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader"), ("fill", "currentColor") ]) $ + svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank + +signOut :: forall t m. MonadWidget t m => m () +signOut = + svgAttr "svg" (M.fromList [ ("width", "30"), ("height", "30"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1664 896q0 156-61 298t-164 245-245 164-298 61-298-61-245-164-164-245-61-298q0-182 80.5-343t226.5-270q43-32 95.5-25t83.5 50q32 42 24.5 94.5t-49.5 84.5q-98 74-151.5 181t-53.5 228q0 104 40.5 198.5t109.5 163.5 163.5 109.5 198.5 40.5 198.5-40.5 163.5-109.5 109.5-163.5 40.5-198.5q0-121-53.5-228t-151.5-181q-42-32-49.5-84.5t24.5-94.5q31-43 84-50t95 25q146 109 226.5 270t80.5 343zm-640-768v640q0 52-38 90t-90 38-90-38-38-90v-640q0-52 38-90t90-38 90 38 38 90z")]) $ R.blank + +svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a +svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 91682a0..18ebe7c 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -4,14 +4,15 @@ module View.Income.Income , IncomeIn(..) ) where +import Data.Aeson (FromJSON) import Prelude hiding (init) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Currency) -import Model.Loadable (Loadable (..)) -import qualified Model.Loadable as Loadable +import Loadable (Loadable (..)) +import qualified Loadable import qualified Util.Ajax as AjaxUtil import View.Income.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Income.Header as Header @@ -26,17 +27,9 @@ data IncomeIn t = IncomeIn init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) init = do - postBuild <- R.getPostBuild - - usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild) - users <- Loadable.fromEvent usersEvent - - incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild) - incomes <- Loadable.fromEvent incomesEvent - - paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild) - payments <- Loadable.fromEvent paymentsEvent - + users <- AjaxUtil.getNow "api/users" + incomes <- AjaxUtil.getNow "api/incomes" + payments <- AjaxUtil.getNow "api/payments" return $ do us <- users is <- incomes diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index 9247143..5681935 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -11,8 +11,8 @@ import qualified Reflex.Dom as R import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component -import qualified Icon import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon data PagesIn t = PagesIn { _pagesIn_total :: Dynamic t Int diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index ec350e2..5f0d03c 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -17,8 +17,8 @@ import Common.Model (Currency, Frequency, Income (..), UserId) import qualified Common.Util.Text as T -import Model.Loadable (Loadable (..)) -import qualified Model.Loadable as Loadable +import Loadable (Loadable (..)) +import qualified Loadable import qualified Util.Ajax as AjaxUtil import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header @@ -30,23 +30,11 @@ import qualified View.Payment.Table as Table init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) init = do - postBuild <- R.getPostBuild - - incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild) - incomes <- Loadable.fromEvent incomesEvent - - usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild) - users <- Loadable.fromEvent usersEvent - - paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild) - payments <- Loadable.fromEvent paymentsEvent - - paymentCategoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/paymentCategories") postBuild) - paymentCategories <- Loadable.fromEvent paymentCategoriesEvent - - categoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/categories") postBuild) - categories <- Loadable.fromEvent categoriesEvent - + users <- AjaxUtil.getNow "api/users" + payments <- AjaxUtil.getNow "api/payments" + incomes <- AjaxUtil.getNow "api/incomes" + categories <- AjaxUtil.getNow "api/categories" + paymentCategories <- AjaxUtil.getNow "api/paymentCategories" return $ do us <- users ps <- payments @@ -55,6 +43,7 @@ init = do pcs <- paymentCategories return $ Init <$> us <*> ps <*> is <*> cs <*> pcs + data PaymentIn t = PaymentIn { _paymentIn_currentUser :: UserId , _paymentIn_currency :: Currency diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 5ffa037..3a0a4bf 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -28,8 +28,8 @@ import qualified View.Payment.Delete as Delete import qualified View.Payment.Edit as Edit import View.Payment.Init (Init (..)) -import qualified Icon import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon data TableIn t = TableIn { _tableIn_init :: Init -- cgit v1.2.3 From 80f09e8b3a5c856e60922a73c9161a8c5392e4d4 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 22 Oct 2019 21:35:03 +0200 Subject: Create ModalForm component --- client/client.cabal | 1 + client/src/Component.hs | 15 +-- client/src/Component/ModalForm.hs | 70 +++++++++++++ client/src/View/Income/Add.hs | 3 +- client/src/View/Income/Form.hs | 138 +++++++++++-------------- client/src/View/Payment/Add.hs | 3 +- client/src/View/Payment/Clone.hs | 3 +- client/src/View/Payment/Edit.hs | 3 +- client/src/View/Payment/Form.hs | 205 +++++++++++++++++--------------------- 9 files changed, 234 insertions(+), 207 deletions(-) create mode 100644 client/src/Component/ModalForm.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 9e0a47e..a7d3751 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -20,6 +20,7 @@ Executable client MultiParamTypeClasses OverloadedStrings RecursiveDo + ScopedTypeVariables Build-depends: aeson diff --git a/client/src/Component.hs b/client/src/Component.hs index b715a83..fa4e4ea 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -1,9 +1,10 @@ module Component (module X) where -import Component.Button as X -import Component.Form as X -import Component.Input as X -import Component.Link as X -import Component.Pages as X -import Component.Select as X -import Component.Table as X +import Component.Button as X +import Component.Form as X +import Component.Input as X +import Component.Link as X +import Component.ModalForm as X +import Component.Pages as X +import Component.Select as X +import Component.Table as X diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs new file mode 100644 index 0000000..63cb1d2 --- /dev/null +++ b/client/src/Component/ModalForm.hs @@ -0,0 +1,70 @@ +module Component.ModalForm + ( modalForm + , ModalFormIn(..) + , ModalFormOut(..) + ) where + +import Data.Aeson (ToJSON) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import Data.Validation (Validation) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Msg as Msg +import Component.Button (ButtonIn (..)) +import qualified Component.Button as Button +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor + +data ModalFormIn m t a b e = ModalFormIn + { _modalFormIn_headerLabel :: Text + , _modalFormIn_form :: m (Dynamic t (Validation e a)) + , _modalFormIn_ajax :: Event t a -> m (Event t (Either Text b)) + } + +data ModalFormOut t a = ModalFormOut + { _modalFormOut_hide :: Event t () + , _modalFormOut_cancel :: Event t () + , _modalFormOut_confirm :: Event t () + , _modalFormOut_validate :: Event t a + } + +modalForm :: forall t m a b e. (MonadWidget t m, ToJSON a) => ModalFormIn m t a b e -> m (ModalFormOut t b) +modalForm modalFormIn = + R.divClass "form" $ do + R.divClass "formHeader" $ + R.text (_modalFormIn_headerLabel modalFormIn) + + R.divClass "formContent" $ do + rec + form <- _modalFormIn_form modalFormIn + + (validate, cancel, confirm) <- R.divClass "buttons" $ do + rec + cancel <- Button._buttonOut_clic <$> (Button.button $ + (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + confirm <- Button._buttonOut_clic <$> (Button.button $ + (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { _buttonIn_class = R.constDyn "confirm" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + }) + + (validate, waiting) <- WaitFor.waitFor + (_modalFormIn_ajax modalFormIn) + (ValidationUtil.fireValidation form confirm) + + return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm) + + return ModalFormOut + { _modalFormOut_hide = R.leftmost [ cancel, () <$ validate ] + , _modalFormOut_cancel = cancel + , _modalFormOut_confirm = confirm + , _modalFormOut_validate = validate + } diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs index d83bb51..0b1bd04 100644 --- a/client/src/View/Income/Add.hs +++ b/client/src/View/Income/Add.hs @@ -11,6 +11,7 @@ import Common.Model (CreateIncomeForm (..), Income) import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil import qualified Component.Modal as Modal +import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import View.Income.Form (FormIn (..), FormOut (..)) import qualified View.Income.Form as Form @@ -27,7 +28,7 @@ view cancel = do , _formIn_amount = "" , _formIn_date = currentDay , _formIn_mkPayload = CreateIncomeForm - , _formIn_httpMethod = Form.Post + , _formIn_ajax = Ajax.post } hide <- ReflexUtil.flatten (_formOut_hide <$> form) diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index 2bfc23f..824bb0a 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -1,113 +1,89 @@ module View.Income.Form ( view , FormIn(..) - , HttpMethod(..) , FormOut(..) ) where -import Data.Aeson (ToJSON) +import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar +import Data.Validation (Validation) import qualified Data.Validation as V -import Reflex.Dom (Event, MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Income) import qualified Common.Msg as Msg import qualified Common.Validation.Income as IncomeValidation -import Component (ButtonIn (..), InputIn (..), - InputOut (..)) +import Component (InputIn (..), InputOut (..), + ModalFormIn (..), ModalFormOut (..)) import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.Validation as ValidationUtil -import qualified Util.WaitFor as WaitFor -data FormIn t i = FormIn +data FormIn m t a = FormIn { _formIn_cancel :: Event t () , _formIn_headerLabel :: Text , _formIn_amount :: Text , _formIn_date :: Day - , _formIn_mkPayload :: Text -> Text -> i - , _formIn_httpMethod :: HttpMethod + , _formIn_mkPayload :: Text -> Text -> a + , _formIn_ajax :: Text -> Event t a -> m (Event t (Either Text Income)) } -data HttpMethod = Put | Post - data FormOut t = FormOut { _formOut_hide :: Event t () , _formOut_addIncome :: Event t Income } -view :: forall t m i. (MonadWidget t m, ToJSON i) => FormIn t i -> m (FormOut t) +view :: forall t m a. (MonadWidget t m, ToJSON a) => FormIn m t a -> m (FormOut t) view formIn = do - R.divClass "form" $ do - R.divClass "formHeader" $ - R.text (_formIn_headerLabel formIn) - - R.divClass "formContent" $ do - rec - let reset = R.leftmost - [ "" <$ cancel - , "" <$ addIncome - , "" <$ _formIn_cancel formIn - ] - - amount <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Income_Amount - , _inputIn_initialValue = _formIn_amount formIn - , _inputIn_validation = IncomeValidation.amount - }) - (_formIn_amount formIn <$ reset) - confirm) - - let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn - - date <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Income_Date - , _inputIn_initialValue = initialDate - , _inputIn_inputType = "date" - , _inputIn_hasResetButton = False - , _inputIn_validation = IncomeValidation.date - }) - (initialDate <$ reset) - confirm) - - let income = do - a <- amount - d <- date - return . V.Success $ (_formIn_mkPayload formIn) a d - - (addIncome, cancel, confirm) <- R.divClass "buttons" $ do - rec - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) - - confirm <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { _buttonIn_class = R.constDyn "confirm" - , _buttonIn_waiting = waiting - , _buttonIn_submit = True - }) - - (addIncome, waiting) <- WaitFor.waitFor - (ajax "/api/income") - (ValidationUtil.fireValidation income confirm) - - return (R.fmapMaybe EitherUtil.eitherToMaybe addIncome, cancel, confirm) - - return FormOut - { _formOut_hide = R.leftmost [ cancel, () <$ addIncome ] - , _formOut_addIncome = addIncome - } + rec + let reset = R.leftmost + [ "" <$ _modalFormOut_cancel modalForm + , "" <$ _modalFormOut_validate modalForm + , "" <$ _formIn_cancel formIn + ] + + modalForm <- Component.modalForm $ ModalFormIn + { _modalFormIn_headerLabel = _formIn_headerLabel formIn + , _modalFormIn_ajax = _formIn_ajax formIn "/api/income" + , _modalFormIn_form = form reset (_modalFormOut_confirm modalForm) + } + + return $ FormOut + { _formOut_hide = _modalFormOut_hide modalForm + , _formOut_addIncome = _modalFormOut_validate modalForm + } where - ajax = - case _formIn_httpMethod formIn of - Post -> Ajax.post - Put -> Ajax.put + form + :: Event t String + -> Event t () + -> m (Dynamic t (Validation Text a)) + form reset confirm = do + amount <- _inputOut_raw <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Income_Amount + , _inputIn_initialValue = _formIn_amount formIn + , _inputIn_validation = IncomeValidation.amount + }) + (_formIn_amount formIn <$ reset) + confirm) + + let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn + + date <- _inputOut_raw <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Income_Date + , _inputIn_initialValue = initialDate + , _inputIn_inputType = "date" + , _inputIn_hasResetButton = False + , _inputIn_validation = IncomeValidation.date + }) + (initialDate <$ reset) + confirm) + + return $ do + a <- amount + d <- date + return . V.Success $ (_formIn_mkPayload formIn) a d diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 28c0148..163a200 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -17,6 +17,7 @@ import Common.Model (Category (..), CreatePaymentForm (..), import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil import qualified Component.Modal as Modal +import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form @@ -45,7 +46,7 @@ view input cancel = do , Form._input_category = -1 , Form._input_frequency = frequency , Form._input_mkPayload = CreatePaymentForm - , Form._input_httpMethod = Form.Post + , Form._input_ajax = Ajax.post } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs index 60694ca..2fa27f3 100644 --- a/client/src/View/Payment/Clone.hs +++ b/client/src/View/Payment/Clone.hs @@ -17,6 +17,7 @@ import Common.Model (Category (..), CategoryId, import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil import qualified Component.Modal as Modal +import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form @@ -48,7 +49,7 @@ view input cancel = do , Form._input_category = category , Form._input_frequency = _payment_frequency payment , Form._input_mkPayload = CreatePaymentForm - , Form._input_httpMethod = Form.Post + , Form._input_ajax = Ajax.post } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs index 0361602..77841ce 100644 --- a/client/src/View/Payment/Edit.hs +++ b/client/src/View/Payment/Edit.hs @@ -14,6 +14,7 @@ import Common.Model (Category (..), CategoryId, SavedPayment (..)) import qualified Common.Msg as Msg import qualified Component.Modal as Modal +import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form @@ -43,7 +44,7 @@ view input cancel = do , Form._input_category = category , Form._input_frequency = _payment_frequency payment , Form._input_mkPayload = EditPaymentForm (_payment_id payment) - , Form._input_httpMethod = Form.Put + , Form._input_ajax = Ajax.put } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index c817831..1f068fd 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -1,23 +1,21 @@ module View.Payment.Form ( view , Input(..) - , HttpMethod(..) , Output(..) ) where -import Control.Monad (join) -import Control.Monad.IO.Class (liftIO) import Data.Aeson (ToJSON) import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as M import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar +import Data.Validation (Validation) import qualified Data.Validation as V -import Reflex.Dom (Dynamic, Event, MonadHold, - MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import qualified Text.Read as T @@ -27,16 +25,13 @@ import Common.Model (Category (..), CategoryId, SavedPayment (..)) import qualified Common.Msg as Msg import qualified Common.Validation.Payment as PaymentValidation -import Component (ButtonIn (..), InputIn (..), - InputOut (..), SelectIn (..), - SelectOut (..)) +import Component (InputIn (..), InputOut (..), + ModalFormIn (..), ModalFormOut (..), + SelectIn (..), SelectOut (..)) import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil import qualified Util.Validation as ValidationUtil -import qualified Util.WaitFor as WaitFor -data Input t p = Input +data Input m t a = Input { _input_cancel :: Event t () , _input_headerLabel :: Text , _input_categories :: [Category] @@ -46,114 +41,99 @@ data Input t p = Input , _input_date :: Day , _input_category :: CategoryId , _input_frequency :: Frequency - , _input_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> p - , _input_httpMethod :: HttpMethod + , _input_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> a + , _input_ajax :: Text -> Event t a -> m (Event t (Either Text SavedPayment)) } -data HttpMethod = Put | Post - data Output t = Output { _output_hide :: Event t () , _output_addPayment :: Event t SavedPayment } -view :: forall t m p. (MonadWidget t m, ToJSON p) => Input t p -> m (Output t) +view :: forall t m a. (MonadWidget t m, ToJSON a) => Input m t a -> m (Output t) view input = do - R.divClass "form" $ do - R.divClass "formHeader" $ - R.text (_input_headerLabel input) - - R.divClass "formContent" $ do - rec - let reset = R.leftmost - [ "" <$ cancel - , "" <$ addPayment - , "" <$ _input_cancel input - ] - - name <- Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Name - , _inputIn_initialValue = _input_name input - , _inputIn_validation = PaymentValidation.name - }) - (_input_name input <$ reset) - confirm - - cost <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Cost - , _inputIn_initialValue = _input_cost input - , _inputIn_validation = PaymentValidation.cost - }) - (_input_cost input <$ reset) - confirm) - - let initialDate = T.pack . Calendar.showGregorian . _input_date $ input - - date <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Date - , _inputIn_initialValue = initialDate - , _inputIn_inputType = "date" - , _inputIn_hasResetButton = False - , _inputIn_validation = PaymentValidation.date - }) - (initialDate <$ reset) - confirm) - - let setCategory = - R.fmapMaybe id . R.updated $ - R.ffor (_inputOut_raw name) $ \name -> - findCategory name (_input_paymentCategories input) - - category <- _selectOut_value <$> (Component.select $ SelectIn - { _selectIn_label = Msg.get Msg.Payment_Category - , _selectIn_initialValue = _input_category input - , _selectIn_value = setCategory - , _selectIn_values = R.constDyn categories - , _selectIn_reset = _input_category input <$ reset - , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input) - , _selectIn_validate = confirm - }) - - let payment = do - n <- _inputOut_value name - c <- cost - d <- date - cat <- category - return ((_input_mkPayload input) - <$> ValidationUtil.nelError n - <*> V.Success c - <*> V.Success d - <*> ValidationUtil.nelError cat - <*> V.Success (_input_frequency input)) - - (addPayment, cancel, confirm) <- R.divClass "buttons" $ do - rec - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) - - confirm <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { _buttonIn_class = R.constDyn "confirm" - , _buttonIn_waiting = waiting - , _buttonIn_submit = True - }) - - (addPayment, waiting) <- WaitFor.waitFor - (ajax "/api/payment") - (ValidationUtil.fireValidation payment confirm) - - return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) - - return Output - { _output_hide = R.leftmost [ cancel, () <$ addPayment ] - , _output_addPayment = addPayment - } + rec + let reset = R.leftmost + [ "" <$ _modalFormOut_cancel modalForm + , "" <$ _modalFormOut_validate modalForm + , "" <$ _input_cancel input + ] + + modalForm <- Component.modalForm $ ModalFormIn + { _modalFormIn_headerLabel = _input_headerLabel input + , _modalFormIn_ajax = _input_ajax input "/api/payment" + , _modalFormIn_form = form reset (_modalFormOut_confirm modalForm) + } + + return $ Output + { _output_hide = _modalFormOut_hide modalForm + , _output_addPayment = _modalFormOut_validate modalForm + } where + form + :: Event t String + -> Event t () + -> m (Dynamic t (Validation (NonEmpty Text) a)) + form reset confirm = do + name <- Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Name + , _inputIn_initialValue = _input_name input + , _inputIn_validation = PaymentValidation.name + }) + (_input_name input <$ reset) + confirm + + cost <- _inputOut_raw <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Cost + , _inputIn_initialValue = _input_cost input + , _inputIn_validation = PaymentValidation.cost + }) + (_input_cost input <$ reset) + confirm) + + let initialDate = T.pack . Calendar.showGregorian . _input_date $ input + + date <- _inputOut_raw <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Date + , _inputIn_initialValue = initialDate + , _inputIn_inputType = "date" + , _inputIn_hasResetButton = False + , _inputIn_validation = PaymentValidation.date + }) + (initialDate <$ reset) + confirm) + + let setCategory = + R.fmapMaybe id . R.updated $ + R.ffor (_inputOut_raw name) $ \name -> + findCategory name (_input_paymentCategories input) + + category <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Category + , _selectIn_initialValue = _input_category input + , _selectIn_value = setCategory + , _selectIn_values = R.constDyn categories + , _selectIn_reset = _input_category input <$ reset + , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input) + , _selectIn_validate = confirm + }) + + return $ do + n <- _inputOut_value name + c <- cost + d <- date + cat <- category + return ((_input_mkPayload input) + <$> ValidationUtil.nelError n + <*> V.Success c + <*> V.Success d + <*> ValidationUtil.nelError cat + <*> V.Success (_input_frequency input)) + frequencies = M.fromList [ (Punctual, Msg.get Msg.Payment_PunctualMale) @@ -163,11 +143,6 @@ view input = do categories = M.fromList . flip map (_input_categories input) $ \c -> (_category_id c, _category_name c) - ajax = - case _input_httpMethod input of - Post -> Ajax.post - Put -> Ajax.put - findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId findCategory paymentName = fmap _paymentCategory_category -- cgit v1.2.3 From 613ffccac4b3ab25c6d4c631fab757da0b35acf6 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 22 Oct 2019 22:26:38 +0200 Subject: Harmonize view component code style --- client/client.cabal | 1 - client/src/Component.hs | 10 --- client/src/Component/Button.hs | 56 ++++++++-------- client/src/Component/Form.hs | 6 +- client/src/Component/Input.hs | 79 +++++++++++------------ client/src/Component/Link.hs | 6 +- client/src/Component/Modal.hs | 14 ++-- client/src/Component/ModalForm.hs | 61 +++++++++--------- client/src/Component/Pages.hs | 45 +++++++------ client/src/Component/Select.hs | 56 ++++++++-------- client/src/Component/Table.hs | 45 +++++++------ client/src/View/App.hs | 27 ++++---- client/src/View/Header.hs | 82 +++++++++++------------ client/src/View/Income/Add.hs | 19 +++--- client/src/View/Income/Form.hs | 83 ++++++++++++------------ client/src/View/Income/Header.hs | 43 ++++++------- client/src/View/Income/Income.hs | 34 +++++----- client/src/View/Income/Table.hs | 29 ++++----- client/src/View/NotFound.hs | 12 ++-- client/src/View/Payment/Add.hs | 40 ++++++------ client/src/View/Payment/Clone.hs | 46 ++++++------- client/src/View/Payment/Delete.hs | 57 ++++++++-------- client/src/View/Payment/Edit.hs | 46 ++++++------- client/src/View/Payment/Form.hs | 129 ++++++++++++++++++------------------- client/src/View/Payment/Header.hs | 96 ++++++++++++++------------- client/src/View/Payment/Pages.hs | 57 ++++++++-------- client/src/View/Payment/Payment.hs | 75 +++++++++++---------- client/src/View/Payment/Table.hs | 121 +++++++++++++++++----------------- client/src/View/SignIn.hs | 28 ++++---- 29 files changed, 685 insertions(+), 718 deletions(-) delete mode 100644 client/src/Component.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index a7d3751..c78ed87 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -45,7 +45,6 @@ Executable client , uri-bytestring other-modules: - Component Component.Button Component.Form Component.Input diff --git a/client/src/Component.hs b/client/src/Component.hs deleted file mode 100644 index fa4e4ea..0000000 --- a/client/src/Component.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Component (module X) where - -import Component.Button as X -import Component.Form as X -import Component.Input as X -import Component.Link as X -import Component.ModalForm as X -import Component.Pages as X -import Component.Select as X -import Component.Table as X diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index b1175d7..6faecef 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -1,8 +1,8 @@ module Component.Button - ( ButtonIn(..) - , ButtonOut(..) - , button - , defaultButtonIn + ( In(..) + , Out(..) + , view + , defaultIn ) where import qualified Data.Map as M @@ -14,44 +14,44 @@ import qualified Reflex.Dom as R import qualified View.Icon as Icon -data ButtonIn t m = ButtonIn - { _buttonIn_class :: Dynamic t Text - , _buttonIn_content :: m () - , _buttonIn_waiting :: Event t Bool - , _buttonIn_tabIndex :: Maybe Int - , _buttonIn_submit :: Bool +data In t m = In + { _in_class :: Dynamic t Text + , _in_content :: m () + , _in_waiting :: Event t Bool + , _in_tabIndex :: Maybe Int + , _in_submit :: Bool } -defaultButtonIn :: MonadWidget t m => m () -> ButtonIn t m -defaultButtonIn content = ButtonIn - { _buttonIn_class = R.constDyn "" - , _buttonIn_content = content - , _buttonIn_waiting = R.never - , _buttonIn_tabIndex = Nothing - , _buttonIn_submit = False +defaultIn :: MonadWidget t m => m () -> In t m +defaultIn content = In + { _in_class = R.constDyn "" + , _in_content = content + , _in_waiting = R.never + , _in_tabIndex = Nothing + , _in_submit = False } -data ButtonOut t = ButtonOut - { _buttonOut_clic :: Event t () +data Out t = Out + { _out_clic :: Event t () } -button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) -button buttonIn = do - dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn +view :: forall t m. MonadWidget t m => In t m -> m (Out t) +view input = do + dynWaiting <- R.holdDyn False $ _in_waiting input let attr = do - buttonClass <- _buttonIn_class buttonIn + buttonClass <- _in_class input waiting <- dynWaiting return . M.fromList . catMaybes $ - [ Just ("type", if _buttonIn_submit buttonIn then "submit" else "button") - , (\i -> ("tabindex", T.pack . show $ i)) <$> _buttonIn_tabIndex buttonIn + [ Just ("type", if _in_submit input then "submit" else "button") + , (\i -> ("tabindex", T.pack . show $ i)) <$> _in_tabIndex input , Just ("class", T.intercalate " " [ buttonClass, if waiting then "waiting" else "" ]) ] (e, _) <- R.elDynAttr' "button" attr $ do Icon.loading - R.divClass "content" $ _buttonIn_content buttonIn + R.divClass "content" $ _in_content input - return $ ButtonOut - { _buttonOut_clic = R.domEvent R.Click e + return $ Out + { _out_clic = R.domEvent R.Click e } diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs index 6ea02fa..6878e68 100644 --- a/client/src/Component/Form.hs +++ b/client/src/Component/Form.hs @@ -1,12 +1,12 @@ module Component.Form - ( form + ( view ) where import qualified Data.Map as M import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -form :: forall t m a. MonadWidget t m => m a -> m a -form content = +view :: forall t m a. MonadWidget t m => m a -> m a +view content = R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $ content diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 9ab4d58..37020da 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -1,8 +1,8 @@ module Component.Input - ( InputIn(..) - , InputOut(..) - , input - , defaultInputIn + ( In(..) + , Out(..) + , view + , defaultIn ) where import qualified Data.Map as M @@ -17,40 +17,39 @@ import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex, import qualified Reflex.Dom as R import qualified Common.Util.Validation as ValidationUtil -import Component.Button (ButtonIn (..), ButtonOut (..)) import qualified Component.Button as Button import qualified View.Icon as Icon -data InputIn a = InputIn - { _inputIn_hasResetButton :: Bool - , _inputIn_label :: Text - , _inputIn_initialValue :: Text - , _inputIn_inputType :: Text - , _inputIn_validation :: Text -> Validation Text a +data In a = In + { _in_hasResetButton :: Bool + , _in_label :: Text + , _in_initialValue :: Text + , _in_inputType :: Text + , _in_validation :: Text -> Validation Text a } -defaultInputIn :: InputIn Text -defaultInputIn = InputIn - { _inputIn_hasResetButton = True - , _inputIn_label = "" - , _inputIn_initialValue = "" - , _inputIn_inputType = "text" - , _inputIn_validation = V.Success +defaultIn :: In Text +defaultIn = In + { _in_hasResetButton = True + , _in_label = "" + , _in_initialValue = "" + , _in_inputType = "text" + , _in_validation = V.Success } -data InputOut t a = InputOut - { _inputOut_raw :: Dynamic t Text - , _inputOut_value :: Dynamic t (Validation Text a) - , _inputOut_enter :: Event t () +data Out t a = Out + { _out_raw :: Dynamic t Text + , _out_value :: Dynamic t (Validation Text a) + , _out_enter :: Event t () } -input +view :: forall t m a b. MonadWidget t m - => InputIn a + => In a -> Event t Text -- reset -> Event t b -- validate - -> m (InputOut t a) -input inputIn reset validate = do + -> m (Out t a) +view input reset validate = do rec let resetValue = R.leftmost [ reset @@ -58,7 +57,7 @@ input inputIn reset validate = do ] inputAttr = R.ffor value (\v -> - if T.null v && _inputIn_inputType inputIn /= "date" + if T.null v && _in_inputType input /= "date" then M.empty else M.singleton "class" "filled") @@ -70,7 +69,7 @@ input inputIn reset validate = do , if Maybe.isJust e then "error" else "" ]) - let valueWithValidation = R.ffor value (\v -> (v, _inputIn_validation inputIn $ v)) + let valueWithValidation = R.ffor value (\v -> (v, _in_validation input $ v)) inputError <- getInputError valueWithValidation validate (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do @@ -79,21 +78,21 @@ input inputIn reset validate = do textInput <- R.textInput $ R.def & R.attributes .~ inputAttr & R.setValue .~ resetValue - & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) - & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn) + & R.textInputConfig_initialValue .~ (_in_initialValue input) + & R.textInputConfig_inputType .~ (_in_inputType input) R.divClass "label" $ - R.text (_inputIn_label inputIn) + R.text (_in_label input) return textInput resetClic <- - if _inputIn_hasResetButton inputIn + if _in_hasResetButton input then - _buttonOut_clic <$> (Button.button $ - (Button.defaultButtonIn Icon.cross) - { _buttonIn_class = R.constDyn "reset" - , _buttonIn_tabIndex = Just (-1) + Button._out_clic <$> (Button.view $ + (Button.defaultIn Icon.cross) + { Button._in_class = R.constDyn "reset" + , Button._in_tabIndex = Just (-1) }) else return R.never @@ -105,10 +104,10 @@ input inputIn reset validate = do let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput - return $ InputOut - { _inputOut_raw = value - , _inputOut_value = fmap snd valueWithValidation - , _inputOut_enter = enter + return $ Out + { _out_raw = value + , _out_value = fmap snd valueWithValidation + , _out_enter = enter } getInputError diff --git a/client/src/Component/Link.hs b/client/src/Component/Link.hs index 7e8558b..1fd620e 100644 --- a/client/src/Component/Link.hs +++ b/client/src/Component/Link.hs @@ -1,5 +1,5 @@ module Component.Link - ( link + ( view ) where import Data.Map (Map) @@ -9,8 +9,8 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -link :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> Text -> m () -link href inputAttrs content = +view :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> Text -> m () +view href inputAttrs content = R.elDynAttr "a" attrs (R.text content) where diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index 96c2679..50af469 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -1,5 +1,5 @@ module Component.Modal - ( Input(..) + ( In(..) , Content , view ) where @@ -22,15 +22,15 @@ import qualified Util.Reflex as ReflexUtil -- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent) type Content t m a = Event t () -> m (Event t (), Event t a) -data Input t m a = Input - { _input_show :: Event t () - , _input_content :: Content t m a +data In t m a = In + { _in_show :: Event t () + , _in_content :: Content t m a } -view :: forall t m a. MonadWidget t m => Input t m a -> m (Event t a) +view :: forall t m a. MonadWidget t m => In t m a -> m (Event t a) view input = do rec - let show = Show <$ (_input_show input) + let show = Show <$ (_in_show input) startHiding = R.attachWithMaybe @@ -61,7 +61,7 @@ view input = do (do (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank let curtainClick = R.domEvent R.Click curtain - (hide, content) <- R.divClass "g-Modal__Content" (_input_content input curtainClick) + (hide, content) <- R.divClass "g-Modal__Content" (_in_content input curtainClick) return (curtainClick, hide, content)) diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs index 63cb1d2..ea53beb 100644 --- a/client/src/Component/ModalForm.hs +++ b/client/src/Component/ModalForm.hs @@ -1,7 +1,7 @@ module Component.ModalForm - ( modalForm - , ModalFormIn(..) - , ModalFormOut(..) + ( view + , In(..) + , Out(..) ) where import Data.Aeson (ToJSON) @@ -14,57 +14,56 @@ import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import qualified Common.Msg as Msg -import Component.Button (ButtonIn (..)) import qualified Component.Button as Button import qualified Util.Either as EitherUtil import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor -data ModalFormIn m t a b e = ModalFormIn - { _modalFormIn_headerLabel :: Text - , _modalFormIn_form :: m (Dynamic t (Validation e a)) - , _modalFormIn_ajax :: Event t a -> m (Event t (Either Text b)) +data In m t a b e = In + { _in_headerLabel :: Text + , _in_form :: m (Dynamic t (Validation e a)) + , _in_ajax :: Event t a -> m (Event t (Either Text b)) } -data ModalFormOut t a = ModalFormOut - { _modalFormOut_hide :: Event t () - , _modalFormOut_cancel :: Event t () - , _modalFormOut_confirm :: Event t () - , _modalFormOut_validate :: Event t a +data Out t a = Out + { _out_hide :: Event t () + , _out_cancel :: Event t () + , _out_confirm :: Event t () + , _out_validate :: Event t a } -modalForm :: forall t m a b e. (MonadWidget t m, ToJSON a) => ModalFormIn m t a b e -> m (ModalFormOut t b) -modalForm modalFormIn = +view :: forall t m a b e. (MonadWidget t m, ToJSON a) => In m t a b e -> m (Out t b) +view input = R.divClass "form" $ do R.divClass "formHeader" $ - R.text (_modalFormIn_headerLabel modalFormIn) + R.text (_in_headerLabel input) R.divClass "formContent" $ do rec - form <- _modalFormIn_form modalFormIn + form <- _in_form input (validate, cancel, confirm) <- R.divClass "buttons" $ do rec - cancel <- Button._buttonOut_clic <$> (Button.button $ - (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) + cancel <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) + { Button._in_class = R.constDyn "undo" }) - confirm <- Button._buttonOut_clic <$> (Button.button $ - (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { _buttonIn_class = R.constDyn "confirm" - , _buttonIn_waiting = waiting - , _buttonIn_submit = True + confirm <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { Button._in_class = R.constDyn "confirm" + , Button._in_waiting = waiting + , Button._in_submit = True }) (validate, waiting) <- WaitFor.waitFor - (_modalFormIn_ajax modalFormIn) + (_in_ajax input) (ValidationUtil.fireValidation form confirm) return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm) - return ModalFormOut - { _modalFormOut_hide = R.leftmost [ cancel, () <$ validate ] - , _modalFormOut_cancel = cancel - , _modalFormOut_confirm = confirm - , _modalFormOut_validate = validate + return Out + { _out_hide = R.leftmost [ cancel, () <$ validate ] + , _out_cancel = cancel + , _out_confirm = confirm + , _out_validate = validate } diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs index 7843ef6..7284a36 100644 --- a/client/src/Component/Pages.hs +++ b/client/src/Component/Pages.hs @@ -1,41 +1,40 @@ module Component.Pages - ( widget - , PagesIn(..) - , PagesOut(..) + ( view + , In(..) + , Out(..) ) where import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Component.Button (ButtonIn (..), ButtonOut (..)) import qualified Component.Button as Button import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon -data PagesIn t = PagesIn - { _pagesIn_total :: Dynamic t Int - , _pagesIn_perPage :: Int - , _pagesIn_reset :: Event t () +data In t = In + { _in_total :: Dynamic t Int + , _in_perPage :: Int + , _in_reset :: Event t () } -data PagesOut t = PagesOut - { _pagesOut_currentPage :: Dynamic t Int +data Out t = Out + { _out_currentPage :: Dynamic t Int } -widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) -widget pagesIn = do +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset - return $ PagesOut - { _pagesOut_currentPage = currentPage + return $ Out + { _out_currentPage = currentPage } where - total = _pagesIn_total pagesIn - perPage = _pagesIn_perPage pagesIn - reset = _pagesIn_reset pagesIn + total = _in_total input + perPage = _in_perPage input + reset = _in_reset input pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) pageButtons total perPage reset = do @@ -75,14 +74,14 @@ range currentPage maxPage = [start..end] pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int) pageButton currentPage page content = do - clic <- _buttonOut_clic <$> (Button.button $ ButtonIn - { _buttonIn_class = do + clic <- Button._out_clic <$> (Button.view $ Button.In + { Button._in_class = do cp <- currentPage p <- page if cp == Just p then "page current" else "page" - , _buttonIn_content = content - , _buttonIn_waiting = R.never - , _buttonIn_tabIndex = Nothing - , _buttonIn_submit = False + , Button._in_content = content + , Button._in_waiting = R.never + , Button._in_tabIndex = Nothing + , Button._in_submit = False }) return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 102f554..375ae06 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -1,7 +1,7 @@ module Component.Select - ( SelectIn(..) - , SelectOut(..) - , select + ( view + , In(..) + , Out(..) ) where import Data.Map (Map) @@ -15,58 +15,58 @@ import qualified Reflex.Dom as R import qualified Util.Validation as ValidationUtil -data (Reflex t) => SelectIn t a b c = SelectIn - { _selectIn_label :: Text - , _selectIn_initialValue :: a - , _selectIn_value :: Event t a - , _selectIn_values :: Dynamic t (Map a Text) - , _selectIn_reset :: Event t b - , _selectIn_isValid :: a -> Validation Text a - , _selectIn_validate :: Event t c +data (Reflex t) => In t a b c = In + { _in_label :: Text + , _in_initialValue :: a + , _in_value :: Event t a + , _in_values :: Dynamic t (Map a Text) + , _in_reset :: Event t b + , _in_isValid :: a -> Validation Text a + , _in_validate :: Event t c } -data SelectOut t a = SelectOut - { _selectOut_raw :: Dynamic t a - , _selectOut_value :: Dynamic t (Validation Text a) +data Out t a = Out + { _out_raw :: Dynamic t a + , _out_value :: Dynamic t (Validation Text a) } -select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a) -select selectIn = do +view :: forall t m a b c. (Ord a, MonadWidget t m) => In t a b c -> m (Out t a) +view input = do rec let containerAttr = R.ffor showedError (\e -> M.singleton "class" $ T.intercalate " " - [ "selectInput" + [ "input" , if Maybe.isJust e then "error" else "" ]) validatedValue = - fmap (_selectIn_isValid selectIn) value + fmap (_in_isValid input) value maybeError = fmap ValidationUtil.maybeError validatedValue showedError <- R.holdDyn Nothing $ R.leftmost - [ Nothing <$ _selectIn_reset selectIn + [ Nothing <$ _in_reset input , R.updated maybeError - , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn) + , R.attachWith const (R.current maybeError) (_in_validate input) ] value <- R.elDynAttr "div" containerAttr $ do - let initialValue = _selectIn_initialValue selectIn + let initialValue = _in_initialValue input let setValue = R.leftmost - [ initialValue <$ (_selectIn_reset selectIn) - , _selectIn_value selectIn + [ initialValue <$ (_in_reset input) + , _in_value input ] value <- R.el "label" $ do R.divClass "label" $ - R.text (_selectIn_label selectIn) + R.text (_in_label input) R._dropdown_value <$> R.dropdown initialValue - (_selectIn_values selectIn) + (_in_values input) (R.def { R._dropdownConfig_setValue = setValue }) R.divClass "errorMessage" . R.dynText $ @@ -74,7 +74,7 @@ select selectIn = do return value - return SelectOut - { _selectOut_raw = value - , _selectOut_value = validatedValue + return Out + { _out_raw = value + , _out_value = validatedValue } diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index b431c14..bf76566 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -1,29 +1,28 @@ module Component.Table - ( table - , TableIn(..) - , TableOut(..) + ( view + , In(..) + , Out(..) ) where import Data.Text (Text) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Component.Pages (PagesIn (..), PagesOut (..)) import qualified Component.Pages as Pages -data TableIn h r t = TableIn - { _tableIn_headerLabel :: h -> Text - , _tableIn_rows :: Dynamic t [r] - , _tableIn_cell :: h -> r -> Text - , _tableIn_perPage :: Int - , _tableIn_resetPage :: Event t () +data In h r t = In + { _in_headerLabel :: h -> Text + , _in_rows :: Dynamic t [r] + , _in_cell :: h -> r -> Text + , _in_perPage :: Int + , _in_resetPage :: Event t () } -data TableOut = TableOut +data Out = Out {} -table :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => TableIn h r t -> m (TableOut) -table tableIn = +view :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => In h r t -> m (Out) +view input = R.divClass "table" $ do rec R.divClass "lines" $ do @@ -31,29 +30,29 @@ table tableIn = R.divClass "header" $ flip mapM_ [minBound..] $ \header -> R.divClass "cell" . R.text $ - _tableIn_headerLabel tableIn header + _in_headerLabel input header let rows = getRange - (_tableIn_perPage tableIn) - <$> (_pagesOut_currentPage pages) - <*> (_tableIn_rows tableIn) + (_in_perPage input) + <$> (Pages._out_currentPage pages) + <*> (_in_rows input) R.simpleList rows $ \r -> R.divClass "row" $ flip mapM_ [minBound..] $ \h -> R.divClass "cell name" $ R.dynText $ - R.ffor r (_tableIn_cell tableIn h) + R.ffor r (_in_cell input h) - pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> (_tableIn_rows tableIn) - , _pagesIn_perPage = _tableIn_perPage tableIn - , _pagesIn_reset = _tableIn_resetPage tableIn + pages <- Pages.view $ Pages.In + { Pages._in_total = length <$> (_in_rows input) + , Pages._in_perPage = _in_perPage input + , Pages._in_reset = _in_resetPage input } return () - return $ TableOut + return $ Out {} getRange :: forall a. Int -> Int -> [a] -> [a] diff --git a/client/src/View/App.hs b/client/src/View/App.hs index b468e56..e0a52e2 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -13,12 +13,9 @@ import qualified Common.Msg as Msg import Model.Route (Route (..)) import qualified Util.Router as Router -import View.Header (HeaderIn (..)) import qualified View.Header as Header -import View.Income.Income (IncomeIn (..)) import qualified View.Income.Income as Income import qualified View.NotFound as NotFound -import View.Payment.Payment (PaymentIn (..)) import qualified View.Payment.Payment as Payment import qualified View.SignIn as SignIn @@ -28,17 +25,17 @@ widget initResult = route <- getRoute - headerOut <- Header.view $ HeaderIn - { _headerIn_initResult = initResult - , _headerIn_isInitSuccess = + header <- Header.view $ Header.In + { Header._in_initResult = initResult + , Header._in_isInitSuccess = case initResult of InitSuccess _ -> True _ -> False - , _headerIn_route = route + , Header._in_route = route } let signOut = - Header._headerOut_signOut headerOut + Header._out_signOut header mainContent = case initResult of @@ -63,17 +60,17 @@ signedWidget init route = do R.dyn . R.ffor route $ \case RootRoute -> do paymentInit <- Payment.init - Payment.view $ PaymentIn - { _paymentIn_currentUser = _init_currentUser init - , _paymentIn_currency = _init_currency init - , _paymentIn_init = paymentInit + Payment.view $ Payment.In + { Payment._in_currentUser = _init_currentUser init + , Payment._in_currency = _init_currency init + , Payment._in_init = paymentInit } IncomeRoute -> do incomeInit <- Income.init - Income.view $ IncomeIn - { _incomeIn_currency = _init_currency init - , _incomeIn_init = incomeInit + Income.view $ Income.In + { Income._in_currency = _init_currency init + , Income._in_init = incomeInit } NotFoundRoute -> diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 68329eb..3f58dd5 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -1,40 +1,40 @@ module View.Header ( view - , HeaderIn(..) - , HeaderOut(..) + , In(..) + , Out(..) ) where -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (NominalDiffTime) -import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Init (..), InitResult (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import Component (ButtonIn (..)) -import qualified Component as Component -import Model.Route (Route (..)) -import qualified Util.Css as CssUtil -import qualified Util.Reflex as ReflexUtil -import qualified View.Icon as Icon - -data HeaderIn t = HeaderIn - { _headerIn_initResult :: InitResult - , _headerIn_isInitSuccess :: Bool - , _headerIn_route :: Dynamic t Route +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (NominalDiffTime) +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init (..), InitResult (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Component.Button as Button +import qualified Component.Link as Link +import Model.Route (Route (..)) +import qualified Util.Css as CssUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon + +data In t = In + { _in_initResult :: InitResult + , _in_isInitSuccess :: Bool + , _in_route :: Dynamic t Route } -data HeaderOut t = HeaderOut - { _headerOut_signOut :: Event t () +data Out t = Out + { _out_signOut :: Event t () } -view :: forall t m. MonadWidget t m => (HeaderIn t) -> m (HeaderOut t) -view headerIn = +view :: forall t m. MonadWidget t m => (In t) -> m (Out t) +view input = R.el "header" $ do R.divClass "title" $ @@ -42,23 +42,23 @@ view headerIn = signOut <- R.el "div" $ do rec - showLinks <- R.foldDyn const (_headerIn_isInitSuccess headerIn) (False <$ signOut) - ReflexUtil.visibleIfDyn showLinks R.blank (links $ _headerIn_route headerIn) - signOut <- nameSignOut $ _headerIn_initResult headerIn + showLinks <- R.foldDyn const (_in_isInitSuccess input) (False <$ signOut) + ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input) + signOut <- nameSignOut $ _in_initResult input return signOut - return $ HeaderOut - { _headerOut_signOut = signOut + return $ Out + { _out_signOut = signOut } links :: forall t m. MonadWidget t m => Dynamic t Route -> m () links route = do - Component.link + Link.view "/" (R.ffor route (attrs RootRoute)) (Msg.get Msg.Payment_Title) - Component.link + Link.view "/income" (R.ffor route (attrs IncomeRoute)) (Msg.get Msg.Income_Title) @@ -92,12 +92,12 @@ nameSignOut initResult = case initResult of signOutButton :: forall t m. MonadWidget t m => m (Event t ()) signOutButton = do rec - signOut <- Component.button $ - (Component.defaultButtonIn Icon.signOut) - { _buttonIn_class = R.constDyn "signOut item" - , _buttonIn_waiting = waiting + signOut <- Button.view $ + (Button.defaultIn Icon.signOut) + { Button._in_class = R.constDyn "signOut item" + , Button._in_waiting = waiting } - let signOutClic = Component._buttonOut_clic signOut + let signOutClic = Button._out_clic signOut waiting = R.leftmost [ fmap (const True) signOutClic , fmap (const False) signOutSuccess diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs index 0b1bd04..f8f107f 100644 --- a/client/src/View/Income/Add.hs +++ b/client/src/View/Income/Add.hs @@ -13,7 +13,6 @@ import qualified Common.Util.Time as TimeUtil import qualified Component.Modal as Modal import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil -import View.Income.Form (FormIn (..), FormOut (..)) import qualified View.Income.Form as Form view :: forall t m. MonadWidget t m => Modal.Content t m Income @@ -22,16 +21,16 @@ view cancel = do currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay form <- R.dyn $ - return $ Form.view $ FormIn - { _formIn_cancel = cancel - , _formIn_headerLabel = Msg.get Msg.Income_AddLong - , _formIn_amount = "" - , _formIn_date = currentDay - , _formIn_mkPayload = CreateIncomeForm - , _formIn_ajax = Ajax.post + return $ Form.view $ Form.In + { Form._in_cancel = cancel + , Form._in_headerLabel = Msg.get Msg.Income_AddLong + , Form._in_amount = "" + , Form._in_date = currentDay + , Form._in_mkPayload = CreateIncomeForm + , Form._in_ajax = Ajax.post } - hide <- ReflexUtil.flatten (_formOut_hide <$> form) - addIncome <- ReflexUtil.flatten (_formOut_addIncome <$> form) + hide <- ReflexUtil.flatten (Form._out_hide <$> form) + addIncome <- ReflexUtil.flatten (Form._out_addIncome <$> form) return (hide, addIncome) diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index 824bb0a..917edf1 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -1,7 +1,7 @@ module View.Income.Form ( view - , FormIn(..) - , FormOut(..) + , In(..) + , Out(..) ) where import Data.Aeson (FromJSON, ToJSON) @@ -17,42 +17,41 @@ import qualified Reflex.Dom as R import Common.Model (Income) import qualified Common.Msg as Msg import qualified Common.Validation.Income as IncomeValidation -import Component (InputIn (..), InputOut (..), - ModalFormIn (..), ModalFormOut (..)) -import qualified Component as Component +import qualified Component.Input as Input +import qualified Component.ModalForm as ModalForm -data FormIn m t a = FormIn - { _formIn_cancel :: Event t () - , _formIn_headerLabel :: Text - , _formIn_amount :: Text - , _formIn_date :: Day - , _formIn_mkPayload :: Text -> Text -> a - , _formIn_ajax :: Text -> Event t a -> m (Event t (Either Text Income)) +data In m t a = In + { _in_cancel :: Event t () + , _in_headerLabel :: Text + , _in_amount :: Text + , _in_date :: Day + , _in_mkPayload :: Text -> Text -> a + , _in_ajax :: Text -> Event t a -> m (Event t (Either Text Income)) } -data FormOut t = FormOut - { _formOut_hide :: Event t () - , _formOut_addIncome :: Event t Income +data Out t = Out + { _out_hide :: Event t () + , _out_addIncome :: Event t Income } -view :: forall t m a. (MonadWidget t m, ToJSON a) => FormIn m t a -> m (FormOut t) -view formIn = do +view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t) +view input = do rec let reset = R.leftmost - [ "" <$ _modalFormOut_cancel modalForm - , "" <$ _modalFormOut_validate modalForm - , "" <$ _formIn_cancel formIn + [ "" <$ ModalForm._out_cancel modalForm + , "" <$ ModalForm._out_validate modalForm + , "" <$ _in_cancel input ] - modalForm <- Component.modalForm $ ModalFormIn - { _modalFormIn_headerLabel = _formIn_headerLabel formIn - , _modalFormIn_ajax = _formIn_ajax formIn "/api/income" - , _modalFormIn_form = form reset (_modalFormOut_confirm modalForm) + modalForm <- ModalForm.view $ ModalForm.In + { ModalForm._in_headerLabel = _in_headerLabel input + , ModalForm._in_ajax = _in_ajax input "/api/income" + , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) } - return $ FormOut - { _formOut_hide = _modalFormOut_hide modalForm - , _formOut_addIncome = _modalFormOut_validate modalForm + return $ Out + { _out_hide = ModalForm._out_hide modalForm + , _out_addIncome = ModalForm._out_validate modalForm } where @@ -61,24 +60,24 @@ view formIn = do -> Event t () -> m (Dynamic t (Validation Text a)) form reset confirm = do - amount <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Income_Amount - , _inputIn_initialValue = _formIn_amount formIn - , _inputIn_validation = IncomeValidation.amount + amount <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Income_Amount + , Input._in_initialValue = _in_amount input + , Input._in_validation = IncomeValidation.amount }) - (_formIn_amount formIn <$ reset) + (_in_amount input <$ reset) confirm) - let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn + let initialDate = T.pack . Calendar.showGregorian . _in_date $ input - date <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Income_Date - , _inputIn_initialValue = initialDate - , _inputIn_inputType = "date" - , _inputIn_hasResetButton = False - , _inputIn_validation = IncomeValidation.date + date <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Income_Date + , Input._in_initialValue = initialDate + , Input._in_inputType = "date" + , Input._in_hasResetButton = False + , Input._in_validation = IncomeValidation.date }) (initialDate <$ reset) confirm) @@ -86,4 +85,4 @@ view formIn = do return $ do a <- amount d <- date - return . V.Success $ (_formIn_mkPayload formIn) a d + return . V.Success $ (_in_mkPayload input) a d diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 4e08955..ae1174a 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -1,7 +1,7 @@ module View.Income.Header ( view - , HeaderIn(..) - , HeaderOut(..) + , In(..) + , Out(..) ) where import Control.Monad.IO.Class (liftIO) @@ -16,25 +16,24 @@ import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import Component (ButtonOut (..)) -import qualified Component +import qualified Component.Button as Button import qualified Component.Modal as Modal import qualified Util.Date as DateUtil import qualified View.Income.Add as Add import View.Income.Init (Init (..)) -data HeaderIn t = HeaderIn - { _headerIn_init :: Init - , _headerIn_currency :: Currency - , _headerIn_incomes :: Dynamic t [Income] +data In t = In + { _in_init :: Init + , _in_currency :: Currency + , _in_incomes :: Dynamic t [Income] } -data HeaderOut t = HeaderOut - { _headerOut_addIncome :: Event t Income +data Out t = Out + { _out_addIncome :: Event t Income } -view :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) -view headerIn = +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = R.divClass "withMargin" $ do currentTime <- liftIO Clock.getCurrentTime @@ -58,7 +57,7 @@ view headerIn = T.intercalate " " [ _user_name user , "−" - , Format.price (_headerIn_currency headerIn) $ + , Format.price (_in_currency input) $ CM.cumulativeIncomesSince currentTime since userIncomes ] @@ -67,23 +66,23 @@ view headerIn = R.text $ Msg.get Msg.Income_MonthlyNet - addIncome <- _buttonOut_clic <$> - (Component.button . Component.defaultButtonIn . R.text $ + addIncome <- Button._out_clic <$> + (Button.view . Button.defaultIn . R.text $ Msg.get Msg.Income_AddLong) - addIncome <- Modal.view $ Modal.Input - { Modal._input_show = addIncome - , Modal._input_content = Add.view + addIncome <- Modal.view $ Modal.In + { Modal._in_show = addIncome + , Modal._in_content = Add.view } - return $ HeaderOut - { _headerOut_addIncome = addIncome + return $ Out + { _out_addIncome = addIncome } where - init = _headerIn_init headerIn + init = _in_init input - useIncomesFrom = R.ffor (_headerIn_incomes headerIn) $ \incomes -> + useIncomesFrom = R.ffor (_in_incomes input) $ \incomes -> ( CM.useIncomesFrom (map _user_id $_init_users init) incomes diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 18ebe7c..f8359bb 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -1,7 +1,7 @@ module View.Income.Income ( init , view - , IncomeIn(..) + , In(..) ) where import Data.Aeson (FromJSON) @@ -14,15 +14,13 @@ import Common.Model (Currency) import Loadable (Loadable (..)) import qualified Loadable import qualified Util.Ajax as AjaxUtil -import View.Income.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Income.Header as Header import View.Income.Init (Init (..)) -import View.Income.Table (IncomeTableIn (..)) import qualified View.Income.Table as Table -data IncomeIn t = IncomeIn - { _incomeIn_currency :: Currency - , _incomeIn_init :: Dynamic t (Loadable Init) +data In t = In + { _in_currency :: Currency + , _in_init :: Dynamic t (Loadable Init) } init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) @@ -36,9 +34,9 @@ init = do ps <- payments return $ Init <$> us <*> is <*> ps -view :: forall t m. MonadWidget t m => IncomeIn t -> m () -view incomeIn = do - R.dyn . R.ffor (_incomeIn_init incomeIn) . Loadable.view $ \init -> +view :: forall t m. MonadWidget t m => In t -> m () +view input = do + R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> R.elClass "main" "income" $ do @@ -47,18 +45,18 @@ view incomeIn = do incomes <- R.foldDyn (:) (_init_incomes init) - (_headerOut_addIncome header) + (Header._out_addIncome header) - header <- Header.view $ HeaderIn - { _headerIn_init = init - , _headerIn_currency = _incomeIn_currency incomeIn - , _headerIn_incomes = incomes + header <- Header.view $ Header.In + { Header._in_init = init + , Header._in_currency = _in_currency input + , Header._in_incomes = incomes } - Table.view $ IncomeTableIn - { _tableIn_init = init - , _tableIn_currency = _incomeIn_currency incomeIn - , _tableIn_incomes = incomes + Table.view $ Table.In + { Table._in_init = init + , Table._in_currency = _in_currency input + , Table._in_incomes = incomes } return () diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index d42848b..9cb705f 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -1,6 +1,6 @@ module View.Income.Table ( view - , IncomeTableIn(..) + , In(..) ) where import qualified Data.List as L @@ -14,25 +14,24 @@ import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import Component (TableIn (..)) -import qualified Component +import qualified Component.Table as Table import View.Income.Init (Init (..)) -data IncomeTableIn t = IncomeTableIn - { _tableIn_init :: Init - , _tableIn_currency :: Currency - , _tableIn_incomes :: Dynamic t [Income] +data In t = In + { _in_init :: Init + , _in_currency :: Currency + , _in_incomes :: Dynamic t [Income] } -view :: forall t m. MonadWidget t m => IncomeTableIn t -> m () -view tableIn = do +view :: forall t m. MonadWidget t m => In t -> m () +view input = do - Component.table $ TableIn - { _tableIn_headerLabel = headerLabel - , _tableIn_rows = R.ffor (_tableIn_incomes tableIn) $ reverse . L.sortOn _income_date - , _tableIn_cell = cell (_tableIn_init tableIn) (_tableIn_currency tableIn) - , _tableIn_perPage = 7 - , _tableIn_resetPage = R.never + Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date + , Table._in_cell = cell (_in_init input) (_in_currency input) + , Table._in_perPage = 7 + , Table._in_resetPage = R.never } return () diff --git a/client/src/View/NotFound.hs b/client/src/View/NotFound.hs index 1d4e477..1597849 100644 --- a/client/src/View/NotFound.hs +++ b/client/src/View/NotFound.hs @@ -2,19 +2,19 @@ module View.NotFound ( view ) where -import qualified Data.Map as M -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Msg as Msg -import qualified Component as Component +import qualified Common.Msg as Msg +import qualified Component.Link as Link view :: forall t m. MonadWidget t m => m () view = R.divClass "notfound" $ do R.text (Msg.get Msg.NotFound_Message) - Component.link + Link.view "/" (R.constDyn $ M.singleton "class" "link") (Msg.get Msg.NotFound_LinkMessage) diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 163a200..e983465 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -1,6 +1,6 @@ module View.Payment.Add ( view - , Input(..) + , In(..) ) where import Control.Monad (join) @@ -21,32 +21,32 @@ import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form -data Input t = Input - { _input_categories :: [Category] - , _input_paymentCategories :: Dynamic t [PaymentCategory] - , _input_frequency :: Dynamic t Frequency +data In t = In + { _in_categories :: [Category] + , _in_paymentCategories :: Dynamic t [PaymentCategory] + , _in_frequency :: Dynamic t Frequency } -view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment +view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment view input cancel = do currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay formOutput <- R.dyn $ do - paymentCategories <- _input_paymentCategories input - frequency <- _input_frequency input - return $ Form.view $ Form.Input - { Form._input_cancel = cancel - , Form._input_headerLabel = Msg.get Msg.Payment_Add - , Form._input_categories = _input_categories input - , Form._input_paymentCategories = paymentCategories - , Form._input_name = "" - , Form._input_cost = "" - , Form._input_date = currentDay - , Form._input_category = -1 - , Form._input_frequency = frequency - , Form._input_mkPayload = CreatePaymentForm - , Form._input_ajax = Ajax.post + paymentCategories <- _in_paymentCategories input + frequency <- _in_frequency input + return $ Form.view $ Form.In + { Form._in_cancel = cancel + , Form._in_headerLabel = Msg.get Msg.Payment_Add + , Form._in_categories = _in_categories input + , Form._in_paymentCategories = paymentCategories + , Form._in_name = "" + , Form._in_cost = "" + , Form._in_date = currentDay + , Form._in_category = -1 + , Form._in_frequency = frequency + , Form._in_mkPayload = CreatePaymentForm + , Form._in_ajax = Ajax.post } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs index 2fa27f3..56a33d9 100644 --- a/client/src/View/Payment/Clone.hs +++ b/client/src/View/Payment/Clone.hs @@ -1,5 +1,5 @@ module View.Payment.Clone - ( Input(..) + ( In(..) , view ) where @@ -21,35 +21,35 @@ import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form -data Input t = Input - { _input_show :: Event t () - , _input_categories :: [Category] - , _input_paymentCategories :: Dynamic t [PaymentCategory] - , _input_payment :: Dynamic t Payment - , _input_category :: Dynamic t CategoryId +data In t = In + { _in_show :: Event t () + , _in_categories :: [Category] + , _in_paymentCategories :: Dynamic t [PaymentCategory] + , _in_payment :: Dynamic t Payment + , _in_category :: Dynamic t CategoryId } -view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment +view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment view input cancel = do currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay formOutput <- R.dyn $ do - paymentCategories <- _input_paymentCategories input - payment <- _input_payment input - category <- _input_category input - return . Form.view $ Form.Input - { Form._input_cancel = cancel - , Form._input_headerLabel = Msg.get Msg.Payment_CloneLong - , Form._input_categories = _input_categories input - , Form._input_paymentCategories = paymentCategories - , Form._input_name = _payment_name payment - , Form._input_cost = T.pack . show . _payment_cost $ payment - , Form._input_date = currentDay - , Form._input_category = category - , Form._input_frequency = _payment_frequency payment - , Form._input_mkPayload = CreatePaymentForm - , Form._input_ajax = Ajax.post + paymentCategories <- _in_paymentCategories input + payment <- _in_payment input + category <- _in_category input + return . Form.view $ Form.In + { Form._in_cancel = cancel + , Form._in_headerLabel = Msg.get Msg.Payment_CloneLong + , Form._in_categories = _in_categories input + , Form._in_paymentCategories = paymentCategories + , Form._in_name = _payment_name payment + , Form._in_cost = T.pack . show . _payment_cost $ payment + , Form._in_date = currentDay + , Form._in_category = category + , Form._in_frequency = _payment_frequency payment + , Form._in_mkPayload = CreatePaymentForm + , Form._in_ajax = Ajax.post } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index dc7e395..471463c 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -1,28 +1,27 @@ module View.Payment.Delete - ( Input(..) + ( In(..) , view ) where -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Payment (..)) -import qualified Common.Msg as Msg -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component -import qualified Component.Modal as Modal -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.WaitFor as WaitFor - -data Input t = Input - { _input_payment :: Dynamic t Payment +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Payment (..)) +import qualified Common.Msg as Msg +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified Component.Modal as Modal +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.WaitFor as WaitFor + +data In t = In + { _in_payment :: Dynamic t Payment } -view :: forall t m. MonadWidget t m => (Input t) -> Modal.Content t m Payment +view :: forall t m. MonadWidget t m => (In t) -> Modal.Content t m Payment view input _ = R.divClass "delete" $ do R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm @@ -31,20 +30,20 @@ view input _ = (confirm, cancel) <- R.divClass "buttons" $ do - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) + cancel <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) + { Button._in_class = R.constDyn "undo" }) rec - confirm <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { _buttonIn_class = R.constDyn "confirm" - , _buttonIn_submit = True - , _buttonIn_waiting = waiting + confirm <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { Button._in_class = R.constDyn "confirm" + , Button._in_submit = True + , Button._in_waiting = waiting }) let url = - R.ffor (_input_payment input) (\id -> + R.ffor (_in_payment input) (\id -> T.concat ["/api/payment/", T.pack . show $ _payment_id id] ) @@ -56,5 +55,5 @@ view input _ = return $ ( R.leftmost [ cancel, () <$ confirm ] - , R.tag (R.current $ _input_payment input) confirm + , R.tag (R.current $ _in_payment input) confirm ) diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs index 77841ce..5cb4537 100644 --- a/client/src/View/Payment/Edit.hs +++ b/client/src/View/Payment/Edit.hs @@ -1,5 +1,5 @@ module View.Payment.Edit - ( Input(..) + ( In(..) , view ) where @@ -18,33 +18,33 @@ import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form -data Input t = Input - { _input_show :: Event t () - , _input_categories :: [Category] - , _input_paymentCategories :: Dynamic t [PaymentCategory] - , _input_payment :: Dynamic t Payment - , _input_category :: Dynamic t CategoryId +data In t = In + { _in_show :: Event t () + , _in_categories :: [Category] + , _in_paymentCategories :: Dynamic t [PaymentCategory] + , _in_payment :: Dynamic t Payment + , _in_category :: Dynamic t CategoryId } -view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment +view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment view input cancel = do formOutput <- R.dyn $ do - paymentCategories <- _input_paymentCategories input - payment <- _input_payment input - category <- _input_category input - return . Form.view $ Form.Input - { Form._input_cancel = cancel - , Form._input_headerLabel = Msg.get Msg.Payment_EditLong - , Form._input_categories = _input_categories input - , Form._input_paymentCategories = paymentCategories - , Form._input_name = _payment_name payment - , Form._input_cost = T.pack . show . _payment_cost $ payment - , Form._input_date = _payment_date payment - , Form._input_category = category - , Form._input_frequency = _payment_frequency payment - , Form._input_mkPayload = EditPaymentForm (_payment_id payment) - , Form._input_ajax = Ajax.put + paymentCategories <- _in_paymentCategories input + payment <- _in_payment input + category <- _in_category input + return . Form.view $ Form.In + { Form._in_cancel = cancel + , Form._in_headerLabel = Msg.get Msg.Payment_EditLong + , Form._in_categories = _in_categories input + , Form._in_paymentCategories = paymentCategories + , Form._in_name = _payment_name payment + , Form._in_cost = T.pack . show . _payment_cost $ payment + , Form._in_date = _payment_date payment + , Form._in_category = category + , Form._in_frequency = _payment_frequency payment + , Form._in_mkPayload = EditPaymentForm (_payment_id payment) + , Form._in_ajax = Ajax.put } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 1f068fd..29768aa 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -1,7 +1,7 @@ module View.Payment.Form ( view - , Input(..) - , Output(..) + , In(..) + , Out(..) ) where import Data.Aeson (ToJSON) @@ -25,49 +25,48 @@ import Common.Model (Category (..), CategoryId, SavedPayment (..)) import qualified Common.Msg as Msg import qualified Common.Validation.Payment as PaymentValidation -import Component (InputIn (..), InputOut (..), - ModalFormIn (..), ModalFormOut (..), - SelectIn (..), SelectOut (..)) -import qualified Component as Component +import qualified Component.Input as Input +import qualified Component.ModalForm as ModalForm +import qualified Component.Select as Select import qualified Util.Validation as ValidationUtil -data Input m t a = Input - { _input_cancel :: Event t () - , _input_headerLabel :: Text - , _input_categories :: [Category] - , _input_paymentCategories :: [PaymentCategory] - , _input_name :: Text - , _input_cost :: Text - , _input_date :: Day - , _input_category :: CategoryId - , _input_frequency :: Frequency - , _input_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> a - , _input_ajax :: Text -> Event t a -> m (Event t (Either Text SavedPayment)) +data In m t a = In + { _in_cancel :: Event t () + , _in_headerLabel :: Text + , _in_categories :: [Category] + , _in_paymentCategories :: [PaymentCategory] + , _in_name :: Text + , _in_cost :: Text + , _in_date :: Day + , _in_category :: CategoryId + , _in_frequency :: Frequency + , _in_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> a + , _in_ajax :: Text -> Event t a -> m (Event t (Either Text SavedPayment)) } -data Output t = Output +data Out t = Out { _output_hide :: Event t () , _output_addPayment :: Event t SavedPayment } -view :: forall t m a. (MonadWidget t m, ToJSON a) => Input m t a -> m (Output t) +view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t) view input = do rec let reset = R.leftmost - [ "" <$ _modalFormOut_cancel modalForm - , "" <$ _modalFormOut_validate modalForm - , "" <$ _input_cancel input + [ "" <$ ModalForm._out_cancel modalForm + , "" <$ ModalForm._out_validate modalForm + , "" <$ _in_cancel input ] - modalForm <- Component.modalForm $ ModalFormIn - { _modalFormIn_headerLabel = _input_headerLabel input - , _modalFormIn_ajax = _input_ajax input "/api/payment" - , _modalFormIn_form = form reset (_modalFormOut_confirm modalForm) + modalForm <- ModalForm.view $ ModalForm.In + { ModalForm._in_headerLabel = _in_headerLabel input + , ModalForm._in_ajax = _in_ajax input "/api/payment" + , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) } - return $ Output - { _output_hide = _modalFormOut_hide modalForm - , _output_addPayment = _modalFormOut_validate modalForm + return $ Out + { _output_hide = ModalForm._out_hide modalForm + , _output_addPayment = ModalForm._out_validate modalForm } where @@ -76,63 +75,63 @@ view input = do -> Event t () -> m (Dynamic t (Validation (NonEmpty Text) a)) form reset confirm = do - name <- Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Name - , _inputIn_initialValue = _input_name input - , _inputIn_validation = PaymentValidation.name + name <- Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Name + , Input._in_initialValue = _in_name input + , Input._in_validation = PaymentValidation.name }) - (_input_name input <$ reset) + (_in_name input <$ reset) confirm - cost <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Cost - , _inputIn_initialValue = _input_cost input - , _inputIn_validation = PaymentValidation.cost + cost <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Cost + , Input._in_initialValue = _in_cost input + , Input._in_validation = PaymentValidation.cost }) - (_input_cost input <$ reset) + (_in_cost input <$ reset) confirm) - let initialDate = T.pack . Calendar.showGregorian . _input_date $ input + let initialDate = T.pack . Calendar.showGregorian . _in_date $ input - date <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Date - , _inputIn_initialValue = initialDate - , _inputIn_inputType = "date" - , _inputIn_hasResetButton = False - , _inputIn_validation = PaymentValidation.date + date <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Date + , Input._in_initialValue = initialDate + , Input._in_inputType = "date" + , Input._in_hasResetButton = False + , Input._in_validation = PaymentValidation.date }) (initialDate <$ reset) confirm) let setCategory = R.fmapMaybe id . R.updated $ - R.ffor (_inputOut_raw name) $ \name -> - findCategory name (_input_paymentCategories input) - - category <- _selectOut_value <$> (Component.select $ SelectIn - { _selectIn_label = Msg.get Msg.Payment_Category - , _selectIn_initialValue = _input_category input - , _selectIn_value = setCategory - , _selectIn_values = R.constDyn categories - , _selectIn_reset = _input_category input <$ reset - , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input) - , _selectIn_validate = confirm + R.ffor (Input._out_raw name) $ \name -> + findCategory name (_in_paymentCategories input) + + category <- Select._out_value <$> (Select.view $ Select.In + { Select._in_label = Msg.get Msg.Payment_Category + , Select._in_initialValue = _in_category input + , Select._in_value = setCategory + , Select._in_values = R.constDyn categories + , Select._in_reset = _in_category input <$ reset + , Select._in_isValid = PaymentValidation.category (map _category_id $ _in_categories input) + , Select._in_validate = confirm }) return $ do - n <- _inputOut_value name + n <- Input._out_value name c <- cost d <- date cat <- category - return ((_input_mkPayload input) + return ((_in_mkPayload input) <$> ValidationUtil.nelError n <*> V.Success c <*> V.Success d <*> ValidationUtil.nelError cat - <*> V.Success (_input_frequency input)) + <*> V.Success (_in_frequency input)) frequencies = M.fromList @@ -140,7 +139,7 @@ view input = do , (Monthly, Msg.get Msg.Payment_MonthlyMale) ] - categories = M.fromList . flip map (_input_categories input) $ \c -> + categories = M.fromList . flip map (_in_categories input) $ \c -> (_category_id c, _category_name c) findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 9ad90a9..00987a3 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -1,7 +1,7 @@ module View.Payment.Header - ( widget - , HeaderIn(..) - , HeaderOut(..) + ( view + , In(..) + , Out(..) ) where import Control.Monad (forM_) @@ -27,31 +27,30 @@ import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import Component (ButtonIn (..), ButtonOut (..), - InputIn (..), InputOut (..), - SelectIn (..), SelectOut (..)) -import qualified Component as Component +import qualified Component.Button as Button +import qualified Component.Input as Input import qualified Component.Modal as Modal +import qualified Component.Select as Select import qualified Util.List as L import qualified View.Payment.Add as Add import View.Payment.Init (Init (..)) -data HeaderIn t = HeaderIn - { _headerIn_init :: Init - , _headerIn_currency :: Currency - , _headerIn_payments :: Dynamic t [Payment] - , _headerIn_searchPayments :: Dynamic t [Payment] - , _headerIn_paymentCategories :: Dynamic t [PaymentCategory] +data In t = In + { _in_init :: Init + , _in_currency :: Currency + , _in_payments :: Dynamic t [Payment] + , _in_searchPayments :: Dynamic t [Payment] + , _in_paymentCategories :: Dynamic t [PaymentCategory] } -data HeaderOut t = HeaderOut - { _headerOut_searchName :: Dynamic t Text - , _headerOut_searchFrequency :: Dynamic t Frequency - , _headerOut_addPayment :: Event t SavedPayment +data Out t = Out + { _out_searchName :: Dynamic t Text + , _out_searchFrequency :: Dynamic t Frequency + , _out_addPayment :: Event t SavedPayment } -widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) -widget headerIn = +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = R.divClass "header" $ do rec addPayment <- @@ -66,22 +65,22 @@ widget headerIn = let resetSearchName = fmap (const ()) $ addPayment (searchName, searchFrequency) <- searchLine resetSearchName - infos (_headerIn_searchPayments headerIn) users currency + infos (_in_searchPayments input) users currency - return $ HeaderOut - { _headerOut_searchName = searchName - , _headerOut_searchFrequency = searchFrequency - , _headerOut_addPayment = addPayment + return $ Out + { _out_searchName = searchName + , _out_searchFrequency = searchFrequency + , _out_addPayment = addPayment } where - init = _headerIn_init headerIn + init = _in_init input incomes = _init_incomes init initPayments = _init_payments init - payments = _headerIn_payments headerIn + payments = _in_payments input users = _init_users init categories = _init_categories init - currency = _headerIn_currency headerIn - paymentCategories = _headerIn_paymentCategories headerIn + currency = _in_currency input + paymentCategories = _in_paymentCategories input payerAndAdd :: forall t m. MonadWidget t m @@ -113,18 +112,18 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen R.dynText . R.ffor exceedingPayer $ \ep -> Format.price currency $ _exceedingPayer_amount ep - addPayment <- _buttonOut_clic <$> - (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Payment_Add)) - { _buttonIn_class = R.constDyn "addPayment" + addPayment <- Button._out_clic <$> + (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add)) + { Button._in_class = R.constDyn "addPayment" }) - Modal.view $ Modal.Input - { Modal._input_show = addPayment - , Modal._input_content = Add.view $ Add.Input - { Add._input_categories = categories - , Add._input_paymentCategories = paymentCategories - , Add._input_frequency = frequency + Modal.view $ Modal.In + { Modal._in_show = addPayment + , Modal._in_content = Add.view $ Add.In + { Add._in_categories = categories + , Add._in_paymentCategories = paymentCategories + , Add._in_frequency = frequency } } @@ -134,8 +133,8 @@ searchLine -> m (Dynamic t Text, Dynamic t Frequency) searchLine reset = do R.divClass "searchLine" $ do - searchName <- _inputOut_raw <$> (Component.input - ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name }) + searchName <- Input._out_raw <$> (Input.view + ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) ("" <$ reset) R.never) @@ -144,15 +143,14 @@ searchLine reset = do , (Monthly, Msg.get Msg.Payment_MonthlyMale) ] - searchFrequency <- _selectOut_raw <$> (Component.select $ - SelectIn - { _selectIn_label = "" - , _selectIn_initialValue = Punctual - , _selectIn_value = R.never - , _selectIn_values = R.constDyn frequencies - , _selectIn_reset = R.never - , _selectIn_isValid = V.Success - , _selectIn_validate = R.never + searchFrequency <- Select._out_raw <$> (Select.view $ Select.In + { Select._in_label = "" + , Select._in_initialValue = Punctual + , Select._in_value = R.never + , Select._in_values = R.constDyn frequencies + , Select._in_reset = R.never + , Select._in_isValid = V.Success + , Select._in_validate = R.never }) return (searchName, searchFrequency) diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index 5681935..9a1902c 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -1,41 +1,40 @@ module View.Payment.Pages - ( widget - , PagesIn(..) - , PagesOut(..) + ( view + , In(..) + , Out(..) ) where -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component +import qualified Component.Button as Button -import qualified Util.Reflex as ReflexUtil -import qualified View.Icon as Icon +import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon -data PagesIn t = PagesIn - { _pagesIn_total :: Dynamic t Int - , _pagesIn_perPage :: Int - , _pagesIn_reset :: Event t () +data In t = In + { _in_total :: Dynamic t Int + , _in_perPage :: Int + , _in_reset :: Event t () } -data PagesOut t = PagesOut - { _pagesOut_currentPage :: Dynamic t Int +data Out t = Out + { _out_currentPage :: Dynamic t Int } -widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) -widget pagesIn = do +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset - return $ PagesOut - { _pagesOut_currentPage = currentPage + return $ Out + { _out_currentPage = currentPage } where - total = _pagesIn_total pagesIn - perPage = _pagesIn_perPage pagesIn - reset = _pagesIn_reset pagesIn + total = _in_total input + perPage = _in_perPage input + reset = _in_reset input pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) pageButtons total perPage reset = do @@ -75,14 +74,14 @@ range currentPage maxPage = [start..end] pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int) pageButton currentPage page content = do - clic <- _buttonOut_clic <$> (Component.button $ ButtonIn - { _buttonIn_class = do + clic <- Button._out_clic <$> (Button.view $ Button.In + { Button._in_class = do cp <- currentPage p <- page if cp == Just p then "page current" else "page" - , _buttonIn_content = content - , _buttonIn_waiting = R.never - , _buttonIn_tabIndex = Nothing - , _buttonIn_submit = False + , Button._in_content = content + , Button._in_waiting = R.never + , Button._in_tabIndex = Nothing + , Button._in_submit = False }) return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index 5f0d03c..f86acd8 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -1,7 +1,7 @@ module View.Payment.Payment ( init , view - , PaymentIn(..) + , In(..) ) where import Data.Text (Text) @@ -20,12 +20,9 @@ import qualified Common.Util.Text as T import Loadable (Loadable (..)) import qualified Loadable import qualified Util.Ajax as AjaxUtil -import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header import View.Payment.Init (Init (..)) -import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn (..), TableOut (..)) import qualified View.Payment.Table as Table init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) @@ -44,21 +41,21 @@ init = do return $ Init <$> us <*> ps <*> is <*> cs <*> pcs -data PaymentIn t = PaymentIn - { _paymentIn_currentUser :: UserId - , _paymentIn_currency :: Currency - , _paymentIn_init :: Dynamic t (Loadable Init) +data In t = In + { _in_currentUser :: UserId + , _in_currency :: Currency + , _in_init :: Dynamic t (Loadable Init) } -view :: forall t m. MonadWidget t m => PaymentIn t -> m () -view paymentIn = do - R.dyn . R.ffor (_paymentIn_init paymentIn) . Loadable.view $ \init -> +view :: forall t m. MonadWidget t m => In t -> m () +view input = do + R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> R.elClass "main" "payment" $ do rec let addPayment = R.leftmost - [ _headerOut_addPayment header - , _tableOut_addPayment table + [ Header._out_addPayment header + , Table._out_addPayment table ] paymentsPerPage = 7 @@ -66,46 +63,46 @@ view paymentIn = do payments <- reducePayments (_init_payments init) (_savedPayment_payment <$> addPayment) - (_savedPayment_payment <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) + (_savedPayment_payment <$> Table._out_editPayment table) + (Table._out_deletePayment table) paymentCategories <- reducePaymentCategories (_init_paymentCategories init) payments (_savedPayment_paymentCategory <$> addPayment) - (_savedPayment_paymentCategory <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) + (_savedPayment_paymentCategory <$> Table._out_editPayment table) + (Table._out_deletePayment table) (searchNameEvent, searchName) <- - debounceSearchName (_headerOut_searchName header) + debounceSearchName (Header._out_searchName header) let searchPayments = - getSearchPayments searchName (_headerOut_searchFrequency header) payments - - header <- Header.widget $ HeaderIn - { _headerIn_init = init - , _headerIn_currency = _paymentIn_currency paymentIn - , _headerIn_payments = payments - , _headerIn_searchPayments = searchPayments - , _headerIn_paymentCategories = paymentCategories + getSearchPayments searchName (Header._out_searchFrequency header) payments + + header <- Header.view $ Header.In + { Header._in_init = init + , Header._in_currency = _in_currency input + , Header._in_payments = payments + , Header._in_searchPayments = searchPayments + , Header._in_paymentCategories = paymentCategories } - table <- Table.widget $ TableIn - { _tableIn_init = init - , _tableIn_currency = _paymentIn_currency paymentIn - , _tableIn_currentUser = _paymentIn_currentUser paymentIn - , _tableIn_currentPage = _pagesOut_currentPage pages - , _tableIn_payments = searchPayments - , _tableIn_perPage = paymentsPerPage - , _tableIn_paymentCategories = paymentCategories + table <- Table.view $ Table.In + { Table._in_init = init + , Table._in_currency = _in_currency input + , Table._in_currentUser = _in_currentUser input + , Table._in_currentPage = Pages._out_currentPage pages + , Table._in_payments = searchPayments + , Table._in_perPage = paymentsPerPage + , Table._in_paymentCategories = paymentCategories } - pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> searchPayments - , _pagesIn_perPage = paymentsPerPage - , _pagesIn_reset = R.leftmost $ + pages <- Pages.view $ Pages.In + { Pages._in_total = length <$> searchPayments + , Pages._in_perPage = paymentsPerPage + , Pages._in_reset = R.leftmost $ [ () <$ searchNameEvent - , () <$ _headerOut_addPayment header + , () <$ Header._out_addPayment header ] } diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 3a0a4bf..0793836 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -1,7 +1,7 @@ module View.Payment.Table - ( widget - , TableIn(..) - , TableOut(..) + ( view + , In(..) + , Out(..) ) where import qualified Data.List as L @@ -20,8 +20,7 @@ import Common.Model (Category (..), Currency, import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component +import qualified Component.Button as Button import qualified Component.Modal as Modal import qualified View.Payment.Clone as Clone import qualified View.Payment.Delete as Delete @@ -31,25 +30,25 @@ import View.Payment.Init (Init (..)) import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon -data TableIn t = TableIn - { _tableIn_init :: Init - , _tableIn_currency :: Currency - , _tableIn_currentUser :: UserId - , _tableIn_currentPage :: Dynamic t Int - , _tableIn_payments :: Dynamic t [Payment] - , _tableIn_perPage :: Int - , _tableIn_paymentCategories :: Dynamic t [PaymentCategory] - , _tableIn_categories :: [Category] +data In t = In + { _in_init :: Init + , _in_currency :: Currency + , _in_currentUser :: UserId + , _in_currentPage :: Dynamic t Int + , _in_payments :: Dynamic t [Payment] + , _in_perPage :: Int + , _in_paymentCategories :: Dynamic t [PaymentCategory] + , _in_categories :: [Category] } -data TableOut t = TableOut - { _tableOut_addPayment :: Event t SavedPayment - , _tableOut_editPayment :: Event t SavedPayment - , _tableOut_deletePayment :: Event t Payment +data Out t = Out + { _out_addPayment :: Event t SavedPayment + , _out_editPayment :: Event t SavedPayment + , _out_deletePayment :: Event t Payment } -widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) -widget tableIn = do +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do R.divClass "table" $ do (addPayment, editPayment, deletePayment) <- R.divClass "lines" $ do @@ -75,20 +74,20 @@ widget tableIn = do ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty - return $ TableOut - { _tableOut_addPayment = addPayment - , _tableOut_editPayment = editPayment - , _tableOut_deletePayment = deletePayment + return $ Out + { _out_addPayment = addPayment + , _out_editPayment = editPayment + , _out_deletePayment = deletePayment } where - init = _tableIn_init tableIn - currency = _tableIn_currency tableIn - currentUser = _tableIn_currentUser tableIn - currentPage = _tableIn_currentPage tableIn - payments = _tableIn_payments tableIn - paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage - paymentCategories = _tableIn_paymentCategories tableIn + init = _in_init input + currency = _in_currency input + currentUser = _in_currentUser input + currentPage = _in_currentPage input + payments = _in_payments input + paymentRange = getPaymentRange (_in_perPage input) <$> payments <*> currentPage + paymentCategories = _in_paymentCategories input getPaymentRange :: Int -> [Payment] -> Int -> [Payment] getPaymentRange perPage payments currentPage = @@ -150,19 +149,19 @@ paymentRow init currency currentUser paymentCategories payment = clonePayment <- R.divClass "cell button" $ - _buttonOut_clic <$> (Component.button $ - Component.defaultButtonIn Icon.clone) + Button._out_clic <$> (Button.view $ + Button.defaultIn Icon.clone) paymentCloned <- - Modal.view $ Modal.Input - { Modal._input_show = clonePayment - , Modal._input_content = - Clone.view $ Clone.Input - { Clone._input_show = clonePayment - , Clone._input_categories = _init_categories init - , Clone._input_paymentCategories = paymentCategories - , Clone._input_payment = payment - , Clone._input_category = categoryId + Modal.view $ Modal.In + { Modal._in_show = clonePayment + , Modal._in_content = + Clone.view $ Clone.In + { Clone._in_show = clonePayment + , Clone._in_categories = _init_categories init + , Clone._in_paymentCategories = paymentCategories + , Clone._in_payment = payment + , Clone._in_category = categoryId } } @@ -174,36 +173,36 @@ paymentRow init currency currentUser paymentCategories payment = editPayment <- R.divClass "cell button" $ ReflexUtil.divVisibleIf isFromCurrentUser $ - _buttonOut_clic <$> (Component.button $ - Component.defaultButtonIn Icon.edit) + Button._out_clic <$> (Button.view $ + Button.defaultIn Icon.edit) paymentEdited <- - Modal.view $ Modal.Input - { Modal._input_show = editPayment - , Modal._input_content = - Edit.view $ Edit.Input - { Edit._input_show = editPayment - , Edit._input_categories = _init_categories init - , Edit._input_paymentCategories = paymentCategories - , Edit._input_payment = payment - , Edit._input_category = categoryId + Modal.view $ Modal.In + { Modal._in_show = editPayment + , Modal._in_content = + Edit.view $ Edit.In + { Edit._in_show = editPayment + , Edit._in_categories = _init_categories init + , Edit._in_paymentCategories = paymentCategories + , Edit._in_payment = payment + , Edit._in_category = categoryId } } deletePayment <- R.divClass "cell button" $ ReflexUtil.divVisibleIf isFromCurrentUser $ - _buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn Icon.delete) - { _buttonIn_class = R.constDyn "deletePayment" + Button._out_clic <$> (Button.view $ + (Button.defaultIn Icon.delete) + { Button._in_class = R.constDyn "deletePayment" }) paymentDeleted <- - Modal.view $ Modal.Input - { Modal._input_show = deletePayment - , Modal._input_content = - Delete.view $ Delete.Input - { Delete._input_payment = payment + Modal.view $ Modal.In + { Modal._in_show = deletePayment + , Modal._in_content = + Delete.view $ Delete.In + { Delete._in_payment = payment } } diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 4fe495b..a589fc3 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -15,9 +15,9 @@ import Common.Model (SignInForm (SignInForm)) import qualified Common.Msg as Msg import qualified Common.Validation.SignIn as SignInValidation -import Component (ButtonIn (..), ButtonOut (..), - InputIn (..), InputOut (..)) -import qualified Component as Component +import qualified Component.Button as Button +import qualified Component.Form as Form +import qualified Component.Input as Input import qualified Util.Ajax as Ajax import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor @@ -30,24 +30,24 @@ data SignInMessage = view :: forall t m. MonadWidget t m => SignInMessage -> m () view signInMessage = R.divClass "signIn" $ - Component.form $ do + Form.view $ do rec - input <- (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.SignIn_EmailLabel - , _inputIn_validation = SignInValidation.email + input <- (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.SignIn_EmailLabel + , Input._in_validation = SignInValidation.email }) ("" <$ R.ffilter Either.isRight signInResult) validate) - validate <- _buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button)) - { _buttonIn_class = R.constDyn "validate" - , _buttonIn_waiting = waiting - , _buttonIn_submit = True + validate <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.SignIn_Button)) + { Button._in_class = R.constDyn "validate" + , Button._in_waiting = waiting + , Button._in_submit = True }) - let form = SignInForm <$> _inputOut_raw input + let form = SignInForm <$> Input._out_raw input (signInResult, waiting) <- WaitFor.waitFor (Ajax.post "/api/askSignIn") -- cgit v1.2.3 From 61ff1443c42def5a09f624e3df2e2520e97610d0 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 22 Oct 2019 23:25:05 +0200 Subject: Clone incomes --- client/src/Component/Table.hs | 54 +++++++++++++++++++++++++++++----------- client/src/View/Income/Add.hs | 20 ++++++++++----- client/src/View/Income/Header.hs | 2 +- client/src/View/Income/Income.hs | 17 +++++++------ client/src/View/Income/Table.hs | 32 ++++++++++++++++-------- client/src/View/Payment/Clone.hs | 6 ++--- 6 files changed, 90 insertions(+), 41 deletions(-) (limited to 'client') diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index bf76566..5819f45 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -4,56 +4,82 @@ module Component.Table , Out(..) ) where -import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Component.Pages as Pages +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified Component.Pages as Pages +import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon -data In h r t = In +data In m t h r a = In { _in_headerLabel :: h -> Text , _in_rows :: Dynamic t [r] , _in_cell :: h -> r -> Text , _in_perPage :: Int , _in_resetPage :: Event t () + , _in_cloneModal :: Dynamic t r -> Modal.Content t m a } -data Out = Out - {} +data Out t a = Out + { _out_add :: Event t a + } -view :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => In h r t -> m (Out) +view :: forall t m h r a. (MonadWidget t m, Bounded h, Enum h) => In m t h r a -> m (Out t a) view input = R.divClass "table" $ do rec - R.divClass "lines" $ do + result <- R.divClass "lines" $ do - R.divClass "header" $ + R.divClass "header" $ do flip mapM_ [minBound..] $ \header -> R.divClass "cell" . R.text $ _in_headerLabel input header + R.divClass "cell" $ R.blank + let rows = getRange (_in_perPage input) <$> (Pages._out_currentPage pages) <*> (_in_rows input) R.simpleList rows $ \r -> - R.divClass "row" $ + R.divClass "row" $ do flip mapM_ [minBound..] $ \h -> - R.divClass "cell name" $ + R.divClass "cell" $ R.dynText $ R.ffor r (_in_cell input h) + clone <- + R.divClass "cell button" $ + Button._out_clic <$> (Button.view $ + Button.defaultIn Icon.clone) + + cloned <- + Modal.view $ Modal.In + { Modal._in_show = clone + , Modal._in_content = _in_cloneModal input r + } + + return cloned + pages <- Pages.view $ Pages.In { Pages._in_total = length <$> (_in_rows input) , Pages._in_perPage = _in_perPage input , Pages._in_reset = _in_resetPage input } - return () + -- return $ + -- ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result + -- , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result + -- , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result + -- ) return $ Out - {} + { _out_add = R.switch . R.current . fmap R.leftmost $ result + } getRange :: forall a. Int -> Int -> [a] -> [a] getRange perPage currentPage = diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs index f8f107f..d07bd45 100644 --- a/client/src/View/Income/Add.hs +++ b/client/src/View/Income/Add.hs @@ -1,13 +1,16 @@ module View.Income.Add ( view + , In(..) ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T import qualified Data.Time.Clock as Time -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (CreateIncomeForm (..), Income) +import Common.Model (CreateIncomeForm (..), Income (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil import qualified Component.Modal as Modal @@ -15,16 +18,21 @@ import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Income.Form as Form -view :: forall t m. MonadWidget t m => Modal.Content t m Income -view cancel = do +data In t = In + { _in_income :: Dynamic t (Maybe Income) + } + +view :: forall t m. MonadWidget t m => In t -> Modal.Content t m Income +view input cancel = do currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - form <- R.dyn $ + form <- R.dyn $ do + income <- _in_income input return $ Form.view $ Form.In { Form._in_cancel = cancel , Form._in_headerLabel = Msg.get Msg.Income_AddLong - , Form._in_amount = "" + , Form._in_amount = Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> income) , Form._in_date = currentDay , Form._in_mkPayload = CreateIncomeForm , Form._in_ajax = Ajax.post diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index ae1174a..0360d1f 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -72,7 +72,7 @@ view input = addIncome <- Modal.view $ Modal.In { Modal._in_show = addIncome - , Modal._in_content = Add.view + , Modal._in_content = Add.view $ Add.In { Add._in_income = R.constDyn Nothing } } return $ Out diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index f8359bb..b97613d 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -41,11 +41,14 @@ view input = do R.elClass "main" "income" $ do rec - + let addIncome = R.leftmost + [ Header._out_addIncome header + , Table._out_addIncome table + ] incomes <- R.foldDyn (:) (_init_incomes init) - (Header._out_addIncome header) + addIncome header <- Header.view $ Header.In { Header._in_init = init @@ -53,11 +56,11 @@ view input = do , Header._in_incomes = incomes } - Table.view $ Table.In - { Table._in_init = init - , Table._in_currency = _in_currency input - , Table._in_incomes = incomes - } + table <- Table.view $ Table.In + { Table._in_init = init + , Table._in_currency = _in_currency input + , Table._in_incomes = incomes + } return () diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 9cb705f..358cb17 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -1,12 +1,13 @@ module View.Income.Table ( view , In(..) + , Out(..) ) where import qualified Data.List as L import qualified Data.Maybe as Maybe import Data.Text (Text) -import Reflex.Dom (Dynamic, MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Currency, Income (..), User (..)) @@ -15,6 +16,7 @@ import qualified Common.Msg as Msg import qualified Common.View.Format as Format import qualified Component.Table as Table +import qualified View.Income.Add as Add import View.Income.Init (Init (..)) data In t = In @@ -23,18 +25,28 @@ data In t = In , _in_incomes :: Dynamic t [Income] } -view :: forall t m. MonadWidget t m => In t -> m () +data Out t = Out + { _out_addIncome :: Event t Income + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) view input = do - Table.view $ Table.In - { Table._in_headerLabel = headerLabel - , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date - , Table._in_cell = cell (_in_init input) (_in_currency input) - , Table._in_perPage = 7 - , Table._in_resetPage = R.never - } + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date + , Table._in_cell = cell (_in_init input) (_in_currency input) + , Table._in_perPage = 7 + , Table._in_resetPage = R.never + , Table._in_cloneModal = \income -> + Add.view $ Add.In + { Add._in_income = Just <$> income + } + } - return () + return $ Out + { _out_addIncome = Table._out_add table + } data Header = UserHeader diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs index 56a33d9..82b0c27 100644 --- a/client/src/View/Payment/Clone.hs +++ b/client/src/View/Payment/Clone.hs @@ -34,7 +34,7 @@ view input cancel = do currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - formOutput <- R.dyn $ do + form <- R.dyn $ do paymentCategories <- _in_paymentCategories input payment <- _in_payment input category <- _in_category input @@ -52,8 +52,8 @@ view input cancel = do , Form._in_ajax = Ajax.post } - hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) - clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) + hide <- ReflexUtil.flatten (Form._output_hide <$> form) + clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> form) return $ ( hide -- cgit v1.2.3 From f968c8ce63e1aec119b1e6f414cf27e2c0294bcb Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 23 Oct 2019 21:09:54 +0200 Subject: Delete income --- client/client.cabal | 1 + client/src/Component/ConfirmDialog.hs | 49 +++++++++++++++++++++++++++++++ client/src/Component/Table.hs | 42 ++++++++++++++++++++------- client/src/Util/Reflex.hs | 8 ++++++ client/src/View/App.hs | 3 +- client/src/View/Income/Add.hs | 22 +++++++------- client/src/View/Income/Header.hs | 6 ++-- client/src/View/Income/Income.hs | 33 +++++++++++++++------ client/src/View/Income/Table.hs | 54 +++++++++++++++++++++++------------ client/src/View/Payment/Delete.hs | 1 - 10 files changed, 164 insertions(+), 55 deletions(-) create mode 100644 client/src/Component/ConfirmDialog.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index c78ed87..6163ab0 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -46,6 +46,7 @@ Executable client other-modules: Component.Button + Component.ConfirmDialog Component.Form Component.Input Component.Link diff --git a/client/src/Component/ConfirmDialog.hs b/client/src/Component/ConfirmDialog.hs new file mode 100644 index 0000000..50e30ed --- /dev/null +++ b/client/src/Component/ConfirmDialog.hs @@ -0,0 +1,49 @@ +module Component.ConfirmDialog + ( In(..) + , view + ) where + +import Data.Text (Text) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Msg as Msg +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified Util.Either as EitherUtil +import qualified Util.WaitFor as WaitFor + +data In t m a = In + { _in_header :: Text + , _in_confirm :: Event t () -> m (Event t a) + } + +view :: forall t m a. MonadWidget t m => (In t m a) -> Modal.Content t m a +view input _ = + R.divClass "confirm" $ do + R.divClass "confirmHeader" $ + R.text $ _in_header input + + R.divClass "confirmContent" $ do + (confirm, cancel) <- R.divClass "buttons" $ do + + cancel <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) + { Button._in_class = R.constDyn "undo" }) + + rec + confirm <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { Button._in_class = R.constDyn "confirm" + , Button._in_submit = True + , Button._in_waiting = waiting + }) + + (result, waiting) <- WaitFor.waitFor (_in_confirm input) confirm + + return (result, cancel) + + return $ + ( R.leftmost [ cancel, () <$ confirm ] + , confirm + ) diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index 5819f45..b3c70a0 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -20,11 +20,14 @@ data In m t h r a = In , _in_cell :: h -> r -> Text , _in_perPage :: Int , _in_resetPage :: Event t () - , _in_cloneModal :: Dynamic t r -> Modal.Content t m a + , _in_cloneModal :: r -> Modal.Content t m a + , _in_deleteModal :: r -> Modal.Content t m a + , _in_isOwner :: r -> Bool } data Out t a = Out - { _out_add :: Event t a + { _out_add :: Event t a + , _out_delete :: Event t a } view :: forall t m h r a. (MonadWidget t m, Bounded h, Enum h) => In m t h r a -> m (Out t a) @@ -39,6 +42,7 @@ view input = _in_headerLabel input header R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank let rows = getRange (_in_perPage input) @@ -60,25 +64,41 @@ view input = cloned <- Modal.view $ Modal.In { Modal._in_show = clone - , Modal._in_content = _in_cloneModal input r + , Modal._in_content = \curtainClick -> + (R.dyn . R.ffor r $ \r2 -> _in_cloneModal input r2 curtainClick) + >>= ReflexUtil.flattenTuple + } + + let isOwner = R.ffor r (_in_isOwner input) + + delete <- + R.divClass "cell button" $ + ReflexUtil.divVisibleIf isOwner $ + Button._out_clic <$> (Button.view $ + Button.defaultIn Icon.delete) + + deleted <- + Modal.view $ Modal.In + { Modal._in_show = delete + , Modal._in_content = \curtainClick -> + (R.dyn . R.ffor r $ \r2 -> _in_deleteModal input r2 curtainClick) + >>= ReflexUtil.flattenTuple } - return cloned + return (cloned, deleted) pages <- Pages.view $ Pages.In - { Pages._in_total = length <$> (_in_rows input) + { Pages._in_total = length <$> _in_rows input , Pages._in_perPage = _in_perPage input , Pages._in_reset = _in_resetPage input } - -- return $ - -- ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result - -- , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result - -- , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result - -- ) + let add = R.switch . R.current . fmap (R.leftmost . map fst) $ result + delete = R.switch . R.current . fmap (R.leftmost . map snd) $ result return $ Out - { _out_add = R.switch . R.current . fmap R.leftmost $ result + { _out_add = add + , _out_delete = delete } getRange :: forall a. Int -> Int -> [a] -> [a] diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs index c14feeb..9f51c5c 100644 --- a/client/src/Util/Reflex.hs +++ b/client/src/Util/Reflex.hs @@ -4,6 +4,7 @@ module Util.Reflex , divVisibleIf , divClassVisibleIf , flatten + , flattenTuple , getBody ) where @@ -44,6 +45,13 @@ flatten e = do dyn <- R.holdDyn R.never e return $ R.switchDyn dyn + +flattenTuple + :: forall t m a b. MonadWidget t m + => Event t (Event t a, Event t b) + -> m (Event t a, Event t b) +flattenTuple e = (,) <$> (flatten $ fmap fst e) <*> (flatten $ fmap snd e) + getBody :: forall t m. MonadWidget t m => m Element getBody = do document <- Dom.currentDocumentUnchecked diff --git a/client/src/View/App.hs b/client/src/View/App.hs index e0a52e2..1e26417 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -69,7 +69,8 @@ signedWidget init route = do IncomeRoute -> do incomeInit <- Income.init Income.view $ Income.In - { Income._in_currency = _init_currency init + { Income._in_currentUser = _init_currentUser init + , Income._in_currency = _init_currency init , Income._in_init = incomeInit } diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs index d07bd45..7780d73 100644 --- a/client/src/View/Income/Add.hs +++ b/client/src/View/Income/Add.hs @@ -7,19 +7,18 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Maybe as Maybe import qualified Data.Text as T import qualified Data.Time.Clock as Time -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R +import Reflex.Dom (MonadWidget) import Common.Model (CreateIncomeForm (..), Income (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil +import qualified Component.Form import qualified Component.Modal as Modal import qualified Util.Ajax as Ajax -import qualified Util.Reflex as ReflexUtil import qualified View.Income.Form as Form data In t = In - { _in_income :: Dynamic t (Maybe Income) + { _in_income :: Maybe Income } view :: forall t m. MonadWidget t m => In t -> Modal.Content t m Income @@ -27,18 +26,17 @@ view input cancel = do currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - form <- R.dyn $ do - income <- _in_income input - return $ Form.view $ Form.In + let amount = + Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> (_in_income input)) + + form <- + Component.Form.view $ Form.view $ Form.In { Form._in_cancel = cancel , Form._in_headerLabel = Msg.get Msg.Income_AddLong - , Form._in_amount = Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> income) + , Form._in_amount = amount , Form._in_date = currentDay , Form._in_mkPayload = CreateIncomeForm , Form._in_ajax = Ajax.post } - hide <- ReflexUtil.flatten (Form._out_hide <$> form) - addIncome <- ReflexUtil.flatten (Form._out_addIncome <$> form) - - return (hide, addIncome) + return (Form._out_hide form, Form._out_addIncome form) diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 0360d1f..f17e774 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -29,7 +29,7 @@ data In t = In } data Out t = Out - { _out_addIncome :: Event t Income + { _out_add :: Event t Income } view :: forall t m. MonadWidget t m => In t -> m (Out t) @@ -72,11 +72,11 @@ view input = addIncome <- Modal.view $ Modal.In { Modal._in_show = addIncome - , Modal._in_content = Add.view $ Add.In { Add._in_income = R.constDyn Nothing } + , Modal._in_content = Add.view $ Add.In { Add._in_income = Nothing } } return $ Out - { _out_addIncome = addIncome + { _out_add = addIncome } where diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index b97613d..2784cac 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -6,10 +6,10 @@ module View.Income.Income import Data.Aeson (FromJSON) import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Currency) +import Common.Model (Currency, Income (..), UserId) import Loadable (Loadable (..)) import qualified Loadable @@ -19,8 +19,9 @@ import View.Income.Init (Init (..)) import qualified View.Income.Table as Table data In t = In - { _in_currency :: Currency - , _in_init :: Dynamic t (Loadable Init) + { _in_currentUser :: UserId + , _in_currency :: Currency + , _in_init :: Dynamic t (Loadable Init) } init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) @@ -42,13 +43,14 @@ view input = do rec let addIncome = R.leftmost - [ Header._out_addIncome header - , Table._out_addIncome table + [ Header._out_add header + , Table._out_add table ] - incomes <- R.foldDyn - (:) + + incomes <- reduceIncomes (_init_incomes init) addIncome + (Table._out_delete table) header <- Header.view $ Header.In { Header._in_init = init @@ -57,7 +59,8 @@ view input = do } table <- Table.view $ Table.In - { Table._in_init = init + { Table._in_currentUser = _in_currentUser input + , Table._in_init = init , Table._in_currency = _in_currency input , Table._in_incomes = incomes } @@ -65,3 +68,15 @@ view input = do return () return () + +reduceIncomes + :: forall t m. MonadWidget t m + => [Income] + -> Event t Income -- add income + -> Event t Income -- delete income + -> m (Dynamic t [Income]) +reduceIncomes initIncomes add delete = + R.foldDyn id initIncomes $ R.leftmost + [ (:) <$> add + , R.ffor delete (\p -> filter ((/= (_income_id p)) . _income_id)) + ] diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 358cb17..16ebf7c 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -4,29 +4,36 @@ module View.Income.Table , Out(..) ) where -import qualified Data.List as L -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Currency, Income (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format +import Common.Model (Currency, Income (..), User (..), + UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format -import qualified Component.Table as Table -import qualified View.Income.Add as Add -import View.Income.Init (Init (..)) +import qualified Component.ConfirmDialog as ConfirmDialog +import qualified Component.Table as Table +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Income.Add as Add +import View.Income.Init (Init (..)) data In t = In - { _in_init :: Init - , _in_currency :: Currency - , _in_incomes :: Dynamic t [Income] + { _in_currentUser :: UserId + , _in_init :: Init + , _in_currency :: Currency + , _in_incomes :: Dynamic t [Income] } data Out t = Out - { _out_addIncome :: Event t Income + { _out_add :: Event t Income + , _out_delete :: Event t Income } view :: forall t m. MonadWidget t m => In t -> m (Out t) @@ -40,12 +47,23 @@ view input = do , Table._in_resetPage = R.never , Table._in_cloneModal = \income -> Add.view $ Add.In - { Add._in_income = Just <$> income + { Add._in_income = Just income } + , Table._in_deleteModal = \income -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Income_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/income/", T.pack . show $ _income_id income]) + e + return $ income <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_isOwner = (== (_in_currentUser input)) . _income_userId } return $ Out - { _out_addIncome = Table._out_add table + { _out_add = Table._out_add table + , _out_delete = Table._out_delete table } data Header diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 471463c..e5e7219 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -12,7 +12,6 @@ import Common.Model (Payment (..)) import qualified Common.Msg as Msg import qualified Component.Button as Button import qualified Component.Modal as Modal -import qualified Component.Modal as Modal import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil import qualified Util.WaitFor as WaitFor -- cgit v1.2.3 From e4b32ce15f8c92f3b477d3f3d4d301ba08f9b5e3 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 23 Oct 2019 22:35:27 +0200 Subject: Edit an income --- client/client.cabal | 2 +- client/src/Component/ModalForm.hs | 50 +++++++++++----------- client/src/Component/Table.hs | 25 +++++++++-- client/src/View/Income/Add.hs | 42 ------------------ client/src/View/Income/Form.hs | 89 +++++++++++++++++++++++++++------------ client/src/View/Income/Header.hs | 7 +-- client/src/View/Income/Income.hs | 9 ++-- client/src/View/Income/Table.hs | 17 +++++--- 8 files changed, 132 insertions(+), 109 deletions(-) delete mode 100644 client/src/View/Income/Add.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 6163ab0..9a212e8 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -51,6 +51,7 @@ Executable client Component.Input Component.Link Component.Modal + Component.ModalForm Component.Pages Component.Select Component.Table @@ -68,7 +69,6 @@ Executable client View.App View.Header View.Icon - View.Income.Add View.Income.Form View.Income.Header View.Income.Income diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs index ea53beb..f5bf287 100644 --- a/client/src/Component/ModalForm.hs +++ b/client/src/Component/ModalForm.hs @@ -15,6 +15,7 @@ import qualified Reflex.Dom as R import qualified Common.Msg as Msg import qualified Component.Button as Button +import qualified Component.Form as Form import qualified Util.Either as EitherUtil import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor @@ -38,32 +39,33 @@ view input = R.divClass "formHeader" $ R.text (_in_headerLabel input) - R.divClass "formContent" $ do - rec - form <- _in_form input + Form.view $ + R.divClass "formContent" $ do + rec + form <- _in_form input - (validate, cancel, confirm) <- R.divClass "buttons" $ do - rec - cancel <- Button._out_clic <$> (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) - { Button._in_class = R.constDyn "undo" }) + (validate, cancel, confirm) <- R.divClass "buttons" $ do + rec + cancel <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) + { Button._in_class = R.constDyn "undo" }) - confirm <- Button._out_clic <$> (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { Button._in_class = R.constDyn "confirm" - , Button._in_waiting = waiting - , Button._in_submit = True - }) + confirm <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { Button._in_class = R.constDyn "confirm" + , Button._in_waiting = waiting + , Button._in_submit = True + }) - (validate, waiting) <- WaitFor.waitFor - (_in_ajax input) - (ValidationUtil.fireValidation form confirm) + (validate, waiting) <- WaitFor.waitFor + (_in_ajax input) + (ValidationUtil.fireValidation form confirm) - return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm) + return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm) - return Out - { _out_hide = R.leftmost [ cancel, () <$ validate ] - , _out_cancel = cancel - , _out_confirm = confirm - , _out_validate = validate - } + return Out + { _out_hide = R.leftmost [ cancel, () <$ validate ] + , _out_cancel = cancel + , _out_confirm = confirm + , _out_validate = validate + } diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index b3c70a0..a02eaa7 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -21,12 +21,14 @@ data In m t h r a = In , _in_perPage :: Int , _in_resetPage :: Event t () , _in_cloneModal :: r -> Modal.Content t m a + , _in_editModal :: r -> Modal.Content t m a , _in_deleteModal :: r -> Modal.Content t m a , _in_isOwner :: r -> Bool } data Out t a = Out { _out_add :: Event t a + , _out_edit :: Event t a , _out_delete :: Event t a } @@ -43,6 +45,7 @@ view input = R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank let rows = getRange (_in_perPage input) @@ -71,6 +74,20 @@ view input = let isOwner = R.ffor r (_in_isOwner input) + edit <- + R.divClass "cell button" $ + ReflexUtil.divVisibleIf isOwner $ + Button._out_clic <$> (Button.view $ + Button.defaultIn Icon.edit) + + edited <- + Modal.view $ Modal.In + { Modal._in_show = edit + , Modal._in_content = \curtainClick -> + (R.dyn . R.ffor r $ \r2 -> _in_editModal input r2 curtainClick) + >>= ReflexUtil.flattenTuple + } + delete <- R.divClass "cell button" $ ReflexUtil.divVisibleIf isOwner $ @@ -85,7 +102,7 @@ view input = >>= ReflexUtil.flattenTuple } - return (cloned, deleted) + return (cloned, edited, deleted) pages <- Pages.view $ Pages.In { Pages._in_total = length <$> _in_rows input @@ -93,11 +110,13 @@ view input = , Pages._in_reset = _in_resetPage input } - let add = R.switch . R.current . fmap (R.leftmost . map fst) $ result - delete = R.switch . R.current . fmap (R.leftmost . map snd) $ result + let add = R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result + edit = R.switch . R.current . fmap (R.leftmost . map (\(_, a, _) -> a)) $ result + delete = R.switch . R.current . fmap (R.leftmost . map (\(_, _, a) -> a)) $ result return $ Out { _out_add = add + , _out_edit = edit , _out_delete = delete } diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs deleted file mode 100644 index 7780d73..0000000 --- a/client/src/View/Income/Add.hs +++ /dev/null @@ -1,42 +0,0 @@ -module View.Income.Add - ( view - , In(..) - ) where - -import Control.Monad.IO.Class (liftIO) -import qualified Data.Maybe as Maybe -import qualified Data.Text as T -import qualified Data.Time.Clock as Time -import Reflex.Dom (MonadWidget) - -import Common.Model (CreateIncomeForm (..), Income (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as TimeUtil -import qualified Component.Form -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified View.Income.Form as Form - -data In t = In - { _in_income :: Maybe Income - } - -view :: forall t m. MonadWidget t m => In t -> Modal.Content t m Income -view input cancel = do - - currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - - let amount = - Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> (_in_income input)) - - form <- - Component.Form.view $ Form.view $ Form.In - { Form._in_cancel = cancel - , Form._in_headerLabel = Msg.get Msg.Income_AddLong - , Form._in_amount = amount - , Form._in_date = currentDay - , Form._in_mkPayload = CreateIncomeForm - , Form._in_ajax = Ajax.post - } - - return (Form._out_hide form, Form._out_addIncome form) diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index 917edf1..5f354a2 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -1,60 +1,59 @@ module View.Income.Form ( view , In(..) - , Out(..) + , Operation(..) ) where -import Data.Aeson (FromJSON, ToJSON) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (ToJSON) +import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Time import Data.Validation (Validation) import qualified Data.Validation as V import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Income) +import Common.Model (EditIncomeForm (..), Income (..)) import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil import qualified Common.Validation.Income as IncomeValidation import qualified Component.Input as Input +import qualified Component.Modal as Modal import qualified Component.ModalForm as ModalForm +import qualified Util.Ajax as Ajax -data In m t a = In - { _in_cancel :: Event t () - , _in_headerLabel :: Text - , _in_amount :: Text - , _in_date :: Day - , _in_mkPayload :: Text -> Text -> a - , _in_ajax :: Text -> Event t a -> m (Event t (Either Text Income)) +data In t a = In + { _in_operation :: Operation a } -data Out t = Out - { _out_hide :: Event t () - , _out_addIncome :: Event t Income - } +data Operation a + = New (Text -> Text -> a) + | Clone (Text -> Text -> a) Income + | Edit (Text -> Text -> a) Income + +view :: forall t m a. (MonadWidget t m, ToJSON a) => In t a -> Modal.Content t m Income +view input cancel = do -view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t) -view input = do rec let reset = R.leftmost [ "" <$ ModalForm._out_cancel modalForm , "" <$ ModalForm._out_validate modalForm - , "" <$ _in_cancel input + , "" <$ cancel ] modalForm <- ModalForm.view $ ModalForm.In - { ModalForm._in_headerLabel = _in_headerLabel input - , ModalForm._in_ajax = _in_ajax input "/api/income" + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/income" , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) } - return $ Out - { _out_hide = ModalForm._out_hide modalForm - , _out_addIncome = ModalForm._out_validate modalForm - } + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) where + form :: Event t String -> Event t () @@ -63,13 +62,15 @@ view input = do amount <- Input._out_raw <$> (Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.Income_Amount - , Input._in_initialValue = _in_amount input + , Input._in_initialValue = amount , Input._in_validation = IncomeValidation.amount }) - (_in_amount input <$ reset) + (amount <$ reset) confirm) - let initialDate = T.pack . Calendar.showGregorian . _in_date $ input + currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay + + let initialDate = T.pack . Calendar.showGregorian $ date currentDay date <- Input._out_raw <$> (Input.view (Input.defaultIn @@ -85,4 +86,36 @@ view input = do return $ do a <- amount d <- date - return . V.Success $ (_in_mkPayload input) a d + return . V.Success $ mkPayload a d + + op = _in_operation input + + amount = + case op of + New _ -> "" + Clone _ income -> T.pack . show . _income_amount $ income + Edit _ income -> T.pack . show . _income_amount $ income + + date currentDay = + case op of + New _ -> currentDay + Clone _ _ -> currentDay + Edit _ income -> _income_date income + + ajax = + case op of + New _ -> Ajax.post + Clone _ _ -> Ajax.post + Edit _ _ -> Ajax.put + + headerLabel = + case op of + New _ -> Msg.get Msg.Income_AddLong + Clone _ _ -> Msg.get Msg.Income_AddLong + Edit _ _ -> Msg.get Msg.Income_Edit + + mkPayload = + case op of + New f -> f + Clone f _ -> f + Edit f _ -> f diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index f17e774..182db33 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -11,7 +11,8 @@ import qualified Data.Time.Clock as Clock import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Currency, Income (..), User (..)) +import Common.Model (CreateIncomeForm (..), Currency, + Income (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -19,7 +20,7 @@ import qualified Common.View.Format as Format import qualified Component.Button as Button import qualified Component.Modal as Modal import qualified Util.Date as DateUtil -import qualified View.Income.Add as Add +import qualified View.Income.Form as Form import View.Income.Init (Init (..)) data In t = In @@ -72,7 +73,7 @@ view input = addIncome <- Modal.view $ Modal.In { Modal._in_show = addIncome - , Modal._in_content = Add.view $ Add.In { Add._in_income = Nothing } + , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New CreateIncomeForm } } return $ Out diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 2784cac..90f1fde 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -50,6 +50,7 @@ view input = do incomes <- reduceIncomes (_init_incomes init) addIncome + (Table._out_edit table) (Table._out_delete table) header <- Header.view $ Header.In @@ -72,11 +73,13 @@ view input = do reduceIncomes :: forall t m. MonadWidget t m => [Income] - -> Event t Income -- add income - -> Event t Income -- delete income + -> Event t Income -- add + -> Event t Income -- edit + -> Event t Income -- delete -> m (Dynamic t [Income]) -reduceIncomes initIncomes add delete = +reduceIncomes initIncomes add edit delete = R.foldDyn id initIncomes $ R.leftmost [ (:) <$> add + , R.ffor edit (\p -> (p:) . filter ((/= (_income_id p)) . _income_id)) , R.ffor delete (\p -> filter ((/= (_income_id p)) . _income_id)) ] diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 16ebf7c..f865fd9 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -11,8 +11,9 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Currency, Income (..), User (..), - UserId) +import Common.Model (CreateIncomeForm (..), Currency, + EditIncomeForm (..), Income (..), + User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -21,7 +22,7 @@ import qualified Component.ConfirmDialog as ConfirmDialog import qualified Component.Table as Table import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil -import qualified View.Income.Add as Add +import qualified View.Income.Form as Form import View.Income.Init (Init (..)) data In t = In @@ -33,6 +34,7 @@ data In t = In data Out t = Out { _out_add :: Event t Income + , _out_edit :: Event t Income , _out_delete :: Event t Income } @@ -46,8 +48,12 @@ view input = do , Table._in_perPage = 7 , Table._in_resetPage = R.never , Table._in_cloneModal = \income -> - Add.view $ Add.In - { Add._in_income = Just income + Form.view $ Form.In + { Form._in_operation = Form.Clone CreateIncomeForm income + } + , Table._in_editModal = \income -> + Form.view $ Form.In + { Form._in_operation = Form.Edit (EditIncomeForm $ _income_id income) income } , Table._in_deleteModal = \income -> ConfirmDialog.view $ ConfirmDialog.In @@ -63,6 +69,7 @@ view input = do return $ Out { _out_add = Table._out_add table + , _out_edit = Table._out_edit table , _out_delete = Table._out_delete table } -- cgit v1.2.3 From c53198a7dd46f1575a33f823c29fa02126429e8f Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 23 Oct 2019 22:41:51 +0200 Subject: Go to initial page after adding an income --- client/src/View/Income/Income.hs | 1 + client/src/View/Income/Table.hs | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) (limited to 'client') diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 90f1fde..2f0b8f5 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -64,6 +64,7 @@ view input = do , Table._in_init = init , Table._in_currency = _in_currency input , Table._in_incomes = incomes + , Table._in_resetPage = () <$ addIncome } return () diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index f865fd9..c754a77 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -30,6 +30,7 @@ data In t = In , _in_init :: Init , _in_currency :: Currency , _in_incomes :: Dynamic t [Income] + , _in_resetPage :: Event t () } data Out t = Out @@ -46,7 +47,7 @@ view input = do , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date , Table._in_cell = cell (_in_init input) (_in_currency input) , Table._in_perPage = 7 - , Table._in_resetPage = R.never + , Table._in_resetPage = _in_resetPage input , Table._in_cloneModal = \income -> Form.view $ Form.In { Form._in_operation = Form.Clone CreateIncomeForm income -- cgit v1.2.3 From 8ef4d96644bce59bbb736af6359e644743e5610a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 27 Oct 2019 17:02:43 +0100 Subject: Refactor income form component concerning payload creation --- client/src/View/Income/Form.hs | 48 +++++++++++++++++++--------------------- client/src/View/Income/Header.hs | 5 ++--- client/src/View/Income/Table.hs | 9 ++++---- 3 files changed, 29 insertions(+), 33 deletions(-) (limited to 'client') diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index 5f354a2..a4f7de8 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -5,7 +5,8 @@ module View.Income.Form ) where import Control.Monad.IO.Class (liftIO) -import Data.Aeson (ToJSON) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T @@ -16,7 +17,8 @@ import qualified Data.Validation as V import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (EditIncomeForm (..), Income (..)) +import Common.Model (CreateIncomeForm (..), + EditIncomeForm (..), Income (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil import qualified Common.Validation.Income as IncomeValidation @@ -25,16 +27,16 @@ import qualified Component.Modal as Modal import qualified Component.ModalForm as ModalForm import qualified Util.Ajax as Ajax -data In t a = In - { _in_operation :: Operation a +data In t = In + { _in_operation :: Operation } -data Operation a - = New (Text -> Text -> a) - | Clone (Text -> Text -> a) Income - | Edit (Text -> Text -> a) Income +data Operation + = New + | Clone Income + | Edit Income -view :: forall t m a. (MonadWidget t m, ToJSON a) => In t a -> Modal.Content t m Income +view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Income view input cancel = do rec @@ -57,7 +59,7 @@ view input cancel = do form :: Event t String -> Event t () - -> m (Dynamic t (Validation Text a)) + -> m (Dynamic t (Validation Text Value)) form reset confirm = do amount <- Input._out_raw <$> (Input.view (Input.defaultIn @@ -92,30 +94,26 @@ view input cancel = do amount = case op of - New _ -> "" - Clone _ income -> T.pack . show . _income_amount $ income - Edit _ income -> T.pack . show . _income_amount $ income + New -> "" + Clone income -> T.pack . show . _income_amount $ income + Edit income -> T.pack . show . _income_amount $ income date currentDay = case op of - New _ -> currentDay - Clone _ _ -> currentDay - Edit _ income -> _income_date income + Edit income -> _income_date income + _ -> currentDay ajax = case op of - New _ -> Ajax.post - Clone _ _ -> Ajax.post - Edit _ _ -> Ajax.put + Edit _ -> Ajax.put + _ -> Ajax.post headerLabel = case op of - New _ -> Msg.get Msg.Income_AddLong - Clone _ _ -> Msg.get Msg.Income_AddLong - Edit _ _ -> Msg.get Msg.Income_Edit + Edit _ -> Msg.get Msg.Income_Edit + _ -> Msg.get Msg.Income_AddLong mkPayload = case op of - New f -> f - Clone f _ -> f - Edit f _ -> f + Edit income -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id income) a b + _ -> \a b -> Aeson.toJSON $ CreateIncomeForm a b diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 182db33..8e82525 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -11,8 +11,7 @@ import qualified Data.Time.Clock as Clock import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (CreateIncomeForm (..), Currency, - Income (..), User (..)) +import Common.Model (Currency, Income (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -73,7 +72,7 @@ view input = addIncome <- Modal.view $ Modal.In { Modal._in_show = addIncome - , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New CreateIncomeForm } + , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New } } return $ Out diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index c754a77..d089d9f 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -11,9 +11,8 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (CreateIncomeForm (..), Currency, - EditIncomeForm (..), Income (..), - User (..), UserId) +import Common.Model (Currency, Income (..), User (..), + UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -50,11 +49,11 @@ view input = do , Table._in_resetPage = _in_resetPage input , Table._in_cloneModal = \income -> Form.view $ Form.In - { Form._in_operation = Form.Clone CreateIncomeForm income + { Form._in_operation = Form.Clone income } , Table._in_editModal = \income -> Form.view $ Form.In - { Form._in_operation = Form.Edit (EditIncomeForm $ _income_id income) income + { Form._in_operation = Form.Edit income } , Table._in_deleteModal = \income -> ConfirmDialog.view $ ConfirmDialog.In -- cgit v1.2.3 From b97ad942495352c3fc1e0c820cfba82a9693ac7a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 27 Oct 2019 20:26:29 +0100 Subject: WIP Set up server side paging for incomes --- client/client.cabal | 1 + client/src/Component/Pages.hs | 37 ++++++++------ client/src/Component/Table.hs | 20 +------- client/src/Loadable.hs | 9 ++++ client/src/View/Income/Income.hs | 101 +++++++++++++++++++------------------- client/src/View/Income/Reducer.hs | 66 +++++++++++++++++++++++++ client/src/View/Income/Table.hs | 13 ++--- 7 files changed, 152 insertions(+), 95 deletions(-) create mode 100644 client/src/View/Income/Reducer.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 9a212e8..8648d57 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -72,6 +72,7 @@ Executable client View.Income.Form View.Income.Header View.Income.Income + View.Income.Reducer View.Income.Table View.NotFound View.Payment.Add diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs index 7284a36..a297222 100644 --- a/client/src/Component/Pages.hs +++ b/client/src/Component/Pages.hs @@ -16,38 +16,43 @@ import qualified View.Icon as Icon data In t = In { _in_total :: Dynamic t Int , _in_perPage :: Int - , _in_reset :: Event t () } data Out t = Out - { _out_currentPage :: Dynamic t Int + { _out_newPage :: Event t Int + , _out_currentPage :: Dynamic t Int } view :: forall t m. MonadWidget t m => In t -> m (Out t) view input = do - currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset + (newPage, currentPage) <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage return $ Out - { _out_currentPage = currentPage + { _out_newPage = newPage + , _out_currentPage = currentPage } where total = _in_total input perPage = _in_perPage input - reset = _in_reset input -pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) -pageButtons total perPage reset = do +pageButtons + :: forall t m. MonadWidget t m + => Dynamic t Int + -> Int + -> m (Event t Int, Dynamic t Int) +pageButtons total perPage = do R.divClass "pages" $ do rec - currentPage <- R.holdDyn 1 . R.leftmost $ - [ firstPageClic - , previousPageClic - , pageClic - , nextPageClic - , lastPageClic - , 1 <$ reset - ] + let newPage = R.leftmost + [ firstPageClic + , previousPageClic + , pageClic + , nextPageClic + , lastPageClic + ] + + currentPage <- R.holdDyn 1 newPage firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar @@ -60,7 +65,7 @@ pageButtons total perPage reset = do lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar - return currentPage + return (newPage, currentPage) where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) pageEvent = R.switch . R.current . fmap R.leftmost diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index a02eaa7..7103abd 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -10,7 +10,6 @@ import qualified Reflex.Dom as R import qualified Component.Button as Button import qualified Component.Modal as Modal -import qualified Component.Pages as Pages import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon @@ -18,8 +17,6 @@ data In m t h r a = In { _in_headerLabel :: h -> Text , _in_rows :: Dynamic t [r] , _in_cell :: h -> r -> Text - , _in_perPage :: Int - , _in_resetPage :: Event t () , _in_cloneModal :: r -> Modal.Content t m a , _in_editModal :: r -> Modal.Content t m a , _in_deleteModal :: r -> Modal.Content t m a @@ -47,12 +44,7 @@ view input = R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - let rows = getRange - (_in_perPage input) - <$> (Pages._out_currentPage pages) - <*> (_in_rows input) - - R.simpleList rows $ \r -> + R.simpleList (_in_rows input) $ \r -> R.divClass "row" $ do flip mapM_ [minBound..] $ \h -> R.divClass "cell" $ @@ -104,12 +96,6 @@ view input = return (cloned, edited, deleted) - pages <- Pages.view $ Pages.In - { Pages._in_total = length <$> _in_rows input - , Pages._in_perPage = _in_perPage input - , Pages._in_reset = _in_resetPage input - } - let add = R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result edit = R.switch . R.current . fmap (R.leftmost . map (\(_, a, _) -> a)) $ result delete = R.switch . R.current . fmap (R.leftmost . map (\(_, _, a) -> a)) $ result @@ -119,7 +105,3 @@ view input = , _out_edit = edit , _out_delete = delete } - -getRange :: forall a. Int -> Int -> [a] -> [a] -getRange perPage currentPage = - take perPage . drop ((currentPage - 1) * perPage) diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs index 8714a4d..a5c1d41 100644 --- a/client/src/Loadable.hs +++ b/client/src/Loadable.hs @@ -49,3 +49,12 @@ view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m () view _ (Loading) = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank view _ (Error e) = R.text e view f (Loaded x) = f x + +-- view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) +-- view _ (Loading) = do +-- R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank +-- return Nothing +-- view _ (Error e) = do +-- R.text e +-- return Nothing +-- view f (Loaded x) = Just <$> (f x) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 2f0b8f5..c48f325 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -4,19 +4,23 @@ module View.Income.Income , In(..) ) where -import Data.Aeson (FromJSON) -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import Data.Aeson (FromJSON) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Currency, Income (..), UserId) +import Common.Model (Currency, Income (..), + IncomesAndCount (..), UserId) -import Loadable (Loadable (..)) +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) import qualified Loadable -import qualified Util.Ajax as AjaxUtil -import qualified View.Income.Header as Header -import View.Income.Init (Init (..)) -import qualified View.Income.Table as Table +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +-- import qualified View.Income.Header as Header +import View.Income.Init (Init (..)) +import qualified View.Income.Reducer as Reducer +import qualified View.Income.Table as Table data In t = In { _in_currentUser :: UserId @@ -37,50 +41,45 @@ init = do view :: forall t m. MonadWidget t m => In t -> m () view input = do - R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> + -- rec + -- incomes <- Reducer.reducer + -- { Reducer._in_newPage = ReflexUtil.flatten (Table._out_newPage <$> table) + -- , Reducer._in_currentPage = ReflexUtil.flatten (Table._out_currentPage <$> table) + -- , Reducer._in_addIncome = ReflexUtil.flatten (Table._out_add <$> table) + -- , Reducer._in_editIncome = ReflexUtil.flatten (Table._out_edit <$> table) + -- , Reducer._in_deleteIncome = ReflexUtil.flatten (Table._out_delete <$> table) + -- } - R.elClass "main" "income" $ do + rec + incomes <- Reducer.reducer $ Reducer.In + { Reducer._in_newPage = Pages._out_newPage pages + , Reducer._in_currentPage = Pages._out_currentPage pages + , Reducer._in_addIncome = Table._out_add table + , Reducer._in_editIncome = Table._out_edit table + , Reducer._in_deleteIncome = Table._out_delete table + } - rec - let addIncome = R.leftmost - [ Header._out_add header - , Table._out_add table - ] + table <- Table.view $ Table.In + { Table._in_currentUser = _in_currentUser input + , Table._in_currency = _in_currency input + , Table._in_incomes = R.ffor incomes $ \case + Loaded (IncomesAndCount xs _) -> xs + _ -> [] + } - incomes <- reduceIncomes - (_init_incomes init) - addIncome - (Table._out_edit table) - (Table._out_delete table) + pages <- Pages.view $ Pages.In + { Pages._in_total = R.ffor incomes $ \case + Loaded (IncomesAndCount _ n) -> n + _ -> 0 + , Pages._in_perPage = Reducer.perPage + } - header <- Header.view $ Header.In - { Header._in_init = init - , Header._in_currency = _in_currency input - , Header._in_incomes = incomes - } - - table <- Table.view $ Table.In - { Table._in_currentUser = _in_currentUser input - , Table._in_init = init - , Table._in_currency = _in_currency input - , Table._in_incomes = incomes - , Table._in_resetPage = () <$ addIncome - } - - return () + -- -- table :: Event t (Maybe (Table.Out t)) + -- table <- R.dyn . R.ffor incomes . Loadable.view $ \incomes -> + -- Table.view $ Table.In + -- { Table._in_currentUser = _in_currentUser input + -- , Table._in_currency = _in_currency input + -- , Table._in_incomes = incomes + -- } return () - -reduceIncomes - :: forall t m. MonadWidget t m - => [Income] - -> Event t Income -- add - -> Event t Income -- edit - -> Event t Income -- delete - -> m (Dynamic t [Income]) -reduceIncomes initIncomes add edit delete = - R.foldDyn id initIncomes $ R.leftmost - [ (:) <$> add - , R.ffor edit (\p -> (p:) . filter ((/= (_income_id p)) . _income_id)) - , R.ffor delete (\p -> filter ((/= (_income_id p)) . _income_id)) - ] diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs new file mode 100644 index 0000000..5b346cb --- /dev/null +++ b/client/src/View/Income/Reducer.hs @@ -0,0 +1,66 @@ +module View.Income.Reducer + ( perPage + , reducer + , In(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (IncomesAndCount) + +import Loadable (Loadable (..)) +import qualified Loadable as Loadable +import qualified Util.Ajax as AjaxUtil + +perPage :: Int +perPage = 7 + +data In t a b c = In + { _in_newPage :: Event t Int + , _in_currentPage :: Dynamic t Int + , _in_addIncome :: Event t a + , _in_editIncome :: Event t b + , _in_deleteIncome :: Event t c + } + +data Action + = LoadPage Int + | GetResult (Either Text IncomesAndCount) + +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomesAndCount)) +reducer input = do + + postBuild <- R.getPostBuild + + let loadPage = + R.leftmost + [ 1 <$ postBuild + , _in_newPage input + , 1 <$ _in_addIncome input + , R.tag (R.current $ _in_currentPage input) (_in_editIncome input) + , R.tag (R.current $ _in_currentPage input) (_in_deleteIncome input) + ] + + getResult <- AjaxUtil.get $ fmap pageUrl loadPage + + R.foldDyn + (\action _ -> case action of + LoadPage _ -> Loading + GetResult (Left err) -> Error err + GetResult (Right incomes) -> Loaded incomes + ) + Loading + (R.leftmost + [ LoadPage <$> loadPage + , GetResult <$> getResult + ]) + + where + pageUrl p = + "api/v2/incomes?page=" + <> (T.pack . show $ p) + <> "&perPage=" + <> (T.pack . show $ perPage) diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index d089d9f..6d69c19 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -22,14 +22,11 @@ import qualified Component.Table as Table import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil import qualified View.Income.Form as Form -import View.Income.Init (Init (..)) data In t = In { _in_currentUser :: UserId - , _in_init :: Init , _in_currency :: Currency , _in_incomes :: Dynamic t [Income] - , _in_resetPage :: Event t () } data Out t = Out @@ -44,9 +41,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date - , Table._in_cell = cell (_in_init input) (_in_currency input) - , Table._in_perPage = 7 - , Table._in_resetPage = _in_resetPage input + , Table._in_cell = cell [] (_in_currency input) , Table._in_cloneModal = \income -> Form.view $ Form.In { Form._in_operation = Form.Clone income @@ -84,11 +79,11 @@ headerLabel UserHeader = Msg.get Msg.Income_Name headerLabel DateHeader = Msg.get Msg.Income_Date headerLabel AmountHeader = Msg.get Msg.Income_Amount -cell :: Init -> Currency -> Header -> Income -> Text -cell init currency header income = +cell :: [User] -> Currency -> Header -> Income -> Text +cell users currency header income = case header of UserHeader -> - Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init) + Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users DateHeader -> Format.longDay . _income_date $ income -- cgit v1.2.3 From 227dcd4435b775d7dbc5ae5d3d81b589897253cc Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 2 Nov 2019 20:52:27 +0100 Subject: Implement incomes server side paging --- client/src/Component/Pages.hs | 22 +++++--------- client/src/Component/Table.hs | 62 +++++++++++++++++++------------------- client/src/Loadable.hs | 17 +++-------- client/src/Util/Reflex.hs | 1 - client/src/View/Income/Income.hs | 65 +++++++++++++++++++--------------------- client/src/View/Income/Table.hs | 4 +-- 6 files changed, 76 insertions(+), 95 deletions(-) (limited to 'client') diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs index a297222..d54cd3d 100644 --- a/client/src/Component/Pages.hs +++ b/client/src/Component/Pages.hs @@ -16,32 +16,26 @@ import qualified View.Icon as Icon data In t = In { _in_total :: Dynamic t Int , _in_perPage :: Int + , _in_page :: Int } data Out t = Out { _out_newPage :: Event t Int - , _out_currentPage :: Dynamic t Int } view :: forall t m. MonadWidget t m => In t -> m (Out t) view input = do - (newPage, currentPage) <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage + newPage <- ReflexUtil.divVisibleIf ((> 0) <$> (_in_total input)) $ pageButtons input return $ Out { _out_newPage = newPage - , _out_currentPage = currentPage } - where - total = _in_total input - perPage = _in_perPage input - pageButtons :: forall t m. MonadWidget t m - => Dynamic t Int - -> Int - -> m (Event t Int, Dynamic t Int) -pageButtons total perPage = do + => In t + -> m (Event t Int) +pageButtons input = do R.divClass "pages" $ do rec let newPage = R.leftmost @@ -52,7 +46,7 @@ pageButtons total perPage = do , lastPageClic ] - currentPage <- R.holdDyn 1 newPage + currentPage <- R.holdDyn (_in_page input) newPage firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar @@ -65,9 +59,9 @@ pageButtons total perPage = do lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar - return (newPage, currentPage) + return newPage - where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) + where maxPage = R.ffor (_in_total input) (\t -> ceiling $ toRational t / toRational (_in_perPage input)) pageEvent = R.switch . R.current . fmap R.leftmost noCurrentPage = R.constDyn Nothing diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index 7103abd..3b9ec24 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -4,8 +4,9 @@ module Component.Table , Out(..) ) where +import qualified Data.Map as M import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, MonadWidget) +import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R import qualified Component.Button as Button @@ -15,7 +16,7 @@ import qualified View.Icon as Icon data In m t h r a = In { _in_headerLabel :: h -> Text - , _in_rows :: Dynamic t [r] + , _in_rows :: [r] , _in_cell :: h -> r -> Text , _in_cloneModal :: r -> Modal.Content t m a , _in_editModal :: r -> Modal.Content t m a @@ -44,61 +45,60 @@ view input = R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - R.simpleList (_in_rows input) $ \r -> + flip mapM (_in_rows input) $ \row -> R.divClass "row" $ do - flip mapM_ [minBound..] $ \h -> + flip mapM_ [minBound..] $ \header -> R.divClass "cell" $ - R.dynText $ - R.ffor r (_in_cell input h) + R.text $ + _in_cell input header row - clone <- + cloneButton <- R.divClass "cell button" $ Button._out_clic <$> (Button.view $ Button.defaultIn Icon.clone) - cloned <- + clone <- Modal.view $ Modal.In - { Modal._in_show = clone - , Modal._in_content = \curtainClick -> - (R.dyn . R.ffor r $ \r2 -> _in_cloneModal input r2 curtainClick) - >>= ReflexUtil.flattenTuple + { Modal._in_show = cloneButton + , Modal._in_content = _in_cloneModal input row } - let isOwner = R.ffor r (_in_isOwner input) + let isOwner = _in_isOwner input row - edit <- + let visibleIf cond = + R.elAttr + "div" + (if cond then M.empty else M.singleton "style" "display:none") + + editButton <- R.divClass "cell button" $ - ReflexUtil.divVisibleIf isOwner $ + visibleIf isOwner $ Button._out_clic <$> (Button.view $ Button.defaultIn Icon.edit) - edited <- + edit <- Modal.view $ Modal.In - { Modal._in_show = edit - , Modal._in_content = \curtainClick -> - (R.dyn . R.ffor r $ \r2 -> _in_editModal input r2 curtainClick) - >>= ReflexUtil.flattenTuple + { Modal._in_show = editButton + , Modal._in_content = _in_editModal input row } - delete <- + deleteButton <- R.divClass "cell button" $ - ReflexUtil.divVisibleIf isOwner $ + visibleIf isOwner $ Button._out_clic <$> (Button.view $ Button.defaultIn Icon.delete) - deleted <- + delete <- Modal.view $ Modal.In - { Modal._in_show = delete - , Modal._in_content = \curtainClick -> - (R.dyn . R.ffor r $ \r2 -> _in_deleteModal input r2 curtainClick) - >>= ReflexUtil.flattenTuple + { Modal._in_show = deleteButton + , Modal._in_content = _in_deleteModal input row } - return (cloned, edited, deleted) + return (clone, edit, delete) - let add = R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result - edit = R.switch . R.current . fmap (R.leftmost . map (\(_, a, _) -> a)) $ result - delete = R.switch . R.current . fmap (R.leftmost . map (\(_, _, a) -> a)) $ result + let add = R.leftmost . map (\(a, _, _) -> a) $ result + edit = R.leftmost . map (\(_, a, _) -> a) $ result + delete = R.leftmost . map (\(_, _, a) -> a) $ result return $ Out { _out_add = add diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs index a5c1d41..f57b99c 100644 --- a/client/src/Loadable.hs +++ b/client/src/Loadable.hs @@ -45,16 +45,7 @@ fromEvent = ) Loading -view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m () -view _ (Loading) = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank -view _ (Error e) = R.text e -view f (Loaded x) = f x - --- view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) --- view _ (Loading) = do --- R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank --- return Nothing --- view _ (Error e) = do --- R.text e --- return Nothing --- view f (Loaded x) = Just <$> (f x) +view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) +view _ (Loading) = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing +view _ (Error e) = R.text e >> return Nothing +view f (Loaded x) = Just <$> f x diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs index 9f51c5c..aa5cebb 100644 --- a/client/src/Util/Reflex.hs +++ b/client/src/Util/Reflex.hs @@ -45,7 +45,6 @@ flatten e = do dyn <- R.holdDyn R.never e return $ R.switchDyn dyn - flattenTuple :: forall t m a b. MonadWidget t m => Event t (Event t a, Event t b) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index c48f325..fedf3d8 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -1,10 +1,14 @@ +{-# LANGUAGE ExplicitForAll #-} + module View.Income.Income ( init , view , In(..) ) where +import qualified Data.Text as T import Data.Aeson (FromJSON) +import qualified Data.Maybe as Maybe import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R @@ -41,45 +45,38 @@ init = do view :: forall t m. MonadWidget t m => In t -> m () view input = do - -- rec - -- incomes <- Reducer.reducer - -- { Reducer._in_newPage = ReflexUtil.flatten (Table._out_newPage <$> table) - -- , Reducer._in_currentPage = ReflexUtil.flatten (Table._out_currentPage <$> table) - -- , Reducer._in_addIncome = ReflexUtil.flatten (Table._out_add <$> table) - -- , Reducer._in_editIncome = ReflexUtil.flatten (Table._out_edit <$> table) - -- , Reducer._in_deleteIncome = ReflexUtil.flatten (Table._out_delete <$> table) - -- } - rec incomes <- Reducer.reducer $ Reducer.In - { Reducer._in_newPage = Pages._out_newPage pages - , Reducer._in_currentPage = Pages._out_currentPage pages - , Reducer._in_addIncome = Table._out_add table - , Reducer._in_editIncome = Table._out_edit table - , Reducer._in_deleteIncome = Table._out_delete table + { Reducer._in_newPage = newPage + , Reducer._in_currentPage = currentPage + , Reducer._in_addIncome = addIncome + , Reducer._in_editIncome = editIncome + , Reducer._in_deleteIncome = deleteIncome } - table <- Table.view $ Table.In - { Table._in_currentUser = _in_currentUser input - , Table._in_currency = _in_currency input - , Table._in_incomes = R.ffor incomes $ \case - Loaded (IncomesAndCount xs _) -> xs - _ -> [] - } + let eventFromResult :: forall a. ((Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result - pages <- Pages.view $ Pages.In - { Pages._in_total = R.ffor incomes $ \case - Loaded (IncomesAndCount _ n) -> n - _ -> 0 - , Pages._in_perPage = Reducer.perPage - } + newPage <- eventFromResult $ Pages._out_newPage . snd + currentPage <- R.holdDyn 1 newPage + addIncome <- eventFromResult $ Table._out_add . fst + editIncome <- eventFromResult $ Table._out_edit . fst + deleteIncome <- eventFromResult $ Table._out_delete . fst + + result <- R.dyn . R.ffor ((,) <$> incomes <*> currentPage) $ \(is, p) -> + flip Loadable.view is $ \(IncomesAndCount incomes count) -> do + table <- Table.view $ Table.In + { Table._in_currentUser = _in_currentUser input + , Table._in_currency = _in_currency input + , Table._in_incomes = incomes + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = p + } - -- -- table :: Event t (Maybe (Table.Out t)) - -- table <- R.dyn . R.ffor incomes . Loadable.view $ \incomes -> - -- Table.view $ Table.In - -- { Table._in_currentUser = _in_currentUser input - -- , Table._in_currency = _in_currency input - -- , Table._in_incomes = incomes - -- } + return (table, pages) return () diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 6d69c19..9b2129f 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -26,7 +26,7 @@ import qualified View.Income.Form as Form data In t = In { _in_currentUser :: UserId , _in_currency :: Currency - , _in_incomes :: Dynamic t [Income] + , _in_incomes :: [Income] } data Out t = Out @@ -40,7 +40,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel - , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date + , Table._in_rows = reverse . L.sortOn _income_date $ _in_incomes input , Table._in_cell = cell [] (_in_currency input) , Table._in_cloneModal = \income -> Form.view $ Form.In -- cgit v1.2.3 From a267f0bb4566389342c3244d3c082dc2453f4615 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 09:22:12 +0100 Subject: Show users in income table --- client/client.cabal | 1 + client/src/Component/Appearing.hs | 10 ++++++++++ client/src/View/App.hs | 3 +-- client/src/View/Income/Income.hs | 24 ++++++------------------ client/src/View/Income/Table.hs | 3 ++- 5 files changed, 20 insertions(+), 21 deletions(-) create mode 100644 client/src/Component/Appearing.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 8648d57..cac06d5 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -45,6 +45,7 @@ Executable client , uri-bytestring other-modules: + Component.Appearing Component.Button Component.ConfirmDialog Component.Form diff --git a/client/src/Component/Appearing.hs b/client/src/Component/Appearing.hs new file mode 100644 index 0000000..e0144ca --- /dev/null +++ b/client/src/Component/Appearing.hs @@ -0,0 +1,10 @@ +module Component.Appearing + ( view + ) where + +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +view :: forall t m a. MonadWidget t m => m a -> m a +view = + R.divClass "g-Appearing" diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 1e26417..d305d00 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -67,11 +67,10 @@ signedWidget init route = do } IncomeRoute -> do - incomeInit <- Income.init Income.view $ Income.In { Income._in_currentUser = _init_currentUser init , Income._in_currency = _init_currency init - , Income._in_init = incomeInit + , Income._in_users = _init_users init } NotFoundRoute -> diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index fedf3d8..d31775a 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -1,20 +1,18 @@ {-# LANGUAGE ExplicitForAll #-} module View.Income.Income - ( init - , view + ( view , In(..) ) where -import qualified Data.Text as T import Data.Aeson (FromJSON) import qualified Data.Maybe as Maybe -import Prelude hiding (init) +import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Currency, Income (..), - IncomesAndCount (..), UserId) + IncomesAndCount (..), User, UserId) import qualified Component.Pages as Pages import Loadable (Loadable (..)) @@ -27,22 +25,11 @@ import qualified View.Income.Reducer as Reducer import qualified View.Income.Table as Table data In t = In - { _in_currentUser :: UserId + { _in_users :: [User] + , _in_currentUser :: UserId , _in_currency :: Currency - , _in_init :: Dynamic t (Loadable Init) } -init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) -init = do - users <- AjaxUtil.getNow "api/users" - incomes <- AjaxUtil.getNow "api/incomes" - payments <- AjaxUtil.getNow "api/payments" - return $ do - us <- users - is <- incomes - ps <- payments - return $ Init <$> us <*> is <*> ps - view :: forall t m. MonadWidget t m => In t -> m () view input = do rec @@ -69,6 +56,7 @@ view input = do { Table._in_currentUser = _in_currentUser input , Table._in_currency = _in_currency input , Table._in_incomes = incomes + , Table._in_users = _in_users input } pages <- Pages.view $ Pages.In diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 9b2129f..32ab27b 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -27,6 +27,7 @@ data In t = In { _in_currentUser :: UserId , _in_currency :: Currency , _in_incomes :: [Income] + , _in_users :: [User] } data Out t = Out @@ -41,7 +42,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel , Table._in_rows = reverse . L.sortOn _income_date $ _in_incomes input - , Table._in_cell = cell [] (_in_currency input) + , Table._in_cell = cell (_in_users input) (_in_currency input) , Table._in_cloneModal = \income -> Form.view $ Form.In { Form._in_operation = Form.Clone income -- cgit v1.2.3 From 9dbb4e6f7c2f0edc1126626e2ff498144c6b9947 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 11:28:42 +0100 Subject: Show income header --- client/src/View/Income/Header.hs | 35 ++++++++++++----------------------- client/src/View/Income/Income.hs | 29 ++++++++++++++++++----------- client/src/View/Income/Reducer.hs | 8 ++++---- 3 files changed, 34 insertions(+), 38 deletions(-) (limited to 'client') diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 8e82525..8451ee4 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -5,13 +5,15 @@ module View.Income.Header ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M import qualified Data.Maybe as Maybe import qualified Data.Text as T import qualified Data.Time.Clock as Clock import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Currency, Income (..), User (..)) +import Common.Model (Currency, Income (..), + IncomeHeader (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -23,9 +25,9 @@ import qualified View.Income.Form as Form import View.Income.Init (Init (..)) data In t = In - { _in_init :: Init + { _in_users :: [User] + , _in_header :: IncomeHeader , _in_currency :: Currency - , _in_incomes :: Dynamic t [Income] } data Out t = Out @@ -38,11 +40,11 @@ view input = currentTime <- liftIO Clock.getCurrentTime - R.dyn . R.ffor useIncomesFrom $ \case - (Nothing, _) -> + case _incomeHeader_since $ _in_header input of + Nothing -> R.blank - (Just since, incomes) -> + Just since -> R.el "div" $ do R.el "h1" $ do @@ -50,15 +52,13 @@ view input = R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day)) R.el "ul" $ - flip mapM_ (_init_users init) $ \user -> + flip mapM_ (M.toList . _incomeHeader_byUser $ _in_header input) $ \(userId, amount) -> R.el "li" $ - R.text $ do - let userIncomes = filter ((==) (_user_id user) . _income_userId) incomes + R.text $ T.intercalate " " - [ _user_name user + [ Maybe.fromMaybe "" . fmap _user_name $ CM.findUser userId (_in_users input) , "−" - , Format.price (_in_currency input) $ - CM.cumulativeIncomesSince currentTime since userIncomes + , Format.price (_in_currency input) amount ] R.divClass "titleButton" $ do @@ -78,14 +78,3 @@ view input = return $ Out { _out_add = addIncome } - - where - init = _in_init input - - useIncomesFrom = R.ffor (_in_incomes input) $ \incomes -> - ( CM.useIncomesFrom - (map _user_id $_init_users init) - incomes - (_init_payments init) - , incomes - ) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index d31775a..d82ab4d 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -11,15 +11,15 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Currency, Income (..), - IncomesAndCount (..), User, UserId) +import Common.Model (Currency, Income (..), IncomePage (..), + User, UserId) import qualified Component.Pages as Pages import Loadable (Loadable (..)) import qualified Loadable import qualified Util.Ajax as AjaxUtil import qualified Util.Reflex as ReflexUtil --- import qualified View.Income.Header as Header +import qualified View.Income.Header as Header import View.Income.Init (Init (..)) import qualified View.Income.Reducer as Reducer import qualified View.Income.Table as Table @@ -36,22 +36,29 @@ view input = do incomes <- Reducer.reducer $ Reducer.In { Reducer._in_newPage = newPage , Reducer._in_currentPage = currentPage - , Reducer._in_addIncome = addIncome + , Reducer._in_addIncome = R.leftmost [headerAddIncome, tableAddIncome] , Reducer._in_editIncome = editIncome , Reducer._in_deleteIncome = deleteIncome } - let eventFromResult :: forall a. ((Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + let eventFromResult :: forall a. ((Header.Out t, Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result - newPage <- eventFromResult $ Pages._out_newPage . snd + newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) currentPage <- R.holdDyn 1 newPage - addIncome <- eventFromResult $ Table._out_add . fst - editIncome <- eventFromResult $ Table._out_edit . fst - deleteIncome <- eventFromResult $ Table._out_delete . fst + headerAddIncome <- eventFromResult $ Header._out_add . (\(a, _, _) -> a) + tableAddIncome <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) + editIncome <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) + deleteIncome <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) result <- R.dyn . R.ffor ((,) <$> incomes <*> currentPage) $ \(is, p) -> - flip Loadable.view is $ \(IncomesAndCount incomes count) -> do + flip Loadable.view is $ \(IncomePage header incomes count) -> do + header <- Header.view $ Header.In + { Header._in_users = _in_users input + , Header._in_header = header + , Header._in_currency = _in_currency input + } + table <- Table.view $ Table.In { Table._in_currentUser = _in_currentUser input , Table._in_currency = _in_currency input @@ -65,6 +72,6 @@ view input = do , Pages._in_page = p } - return (table, pages) + return (header, table, pages) return () diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs index 5b346cb..092d9b3 100644 --- a/client/src/View/Income/Reducer.hs +++ b/client/src/View/Income/Reducer.hs @@ -9,7 +9,7 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (IncomesAndCount) +import Common.Model (IncomePage) import Loadable (Loadable (..)) import qualified Loadable as Loadable @@ -28,9 +28,9 @@ data In t a b c = In data Action = LoadPage Int - | GetResult (Either Text IncomesAndCount) + | GetResult (Either Text IncomePage) -reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomesAndCount)) +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomePage)) reducer input = do postBuild <- R.getPostBuild @@ -60,7 +60,7 @@ reducer input = do where pageUrl p = - "api/v2/incomes?page=" + "api/incomes?page=" <> (T.pack . show $ p) <> "&perPage=" <> (T.pack . show $ perPage) -- cgit v1.2.3 From 182f3d3fea9985c0e403087fe253981c68e57102 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 11:33:20 +0100 Subject: Fix payment page --- client/src/View/Payment/Payment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'client') diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index f86acd8..e72577f 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -29,7 +29,7 @@ init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) init = do users <- AjaxUtil.getNow "api/users" payments <- AjaxUtil.getNow "api/payments" - incomes <- AjaxUtil.getNow "api/incomes" + incomes <- AjaxUtil.getNow "api/deprecated/incomes" categories <- AjaxUtil.getNow "api/categories" paymentCategories <- AjaxUtil.getNow "api/paymentCategories" return $ do -- cgit v1.2.3 From 0f85cbd8ee736b1996e3966bac1f5e47ed7d27a9 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 15:47:11 +0100 Subject: Fetch the first payment date instead of every payment to get cumulative income --- client/client.cabal | 1 - client/src/Util/Date.hs | 12 ------------ client/src/View/Income/Header.hs | 4 +--- 3 files changed, 1 insertion(+), 16 deletions(-) delete mode 100644 client/src/Util/Date.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index cac06d5..04c8543 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -60,7 +60,6 @@ Executable client Model.Route Util.Ajax Util.Css - Util.Date Util.Either Util.List Util.Reflex diff --git a/client/src/Util/Date.hs b/client/src/Util/Date.hs deleted file mode 100644 index 8fad881..0000000 --- a/client/src/Util/Date.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Util.Date - ( utcToLocalDay - ) where - -import Data.Time.Calendar (Day) -import Data.Time.Clock (UTCTime) -import qualified Data.Time.LocalTime as LocalTime - -utcToLocalDay :: UTCTime -> IO Day -utcToLocalDay time = do - timezone <- LocalTime.getCurrentTimeZone - return . LocalTime.localDay $ LocalTime.utcToLocalTime timezone time diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 8451ee4..9e1c5b6 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -20,7 +20,6 @@ import qualified Common.View.Format as Format import qualified Component.Button as Button import qualified Component.Modal as Modal -import qualified Util.Date as DateUtil import qualified View.Income.Form as Form import View.Income.Init (Init (..)) @@ -48,8 +47,7 @@ view input = R.el "div" $ do R.el "h1" $ do - day <- liftIO $ DateUtil.utcToLocalDay since - R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day)) + R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay since)) R.el "ul" $ flip mapM_ (M.toList . _incomeHeader_byUser $ _in_header input) $ \(userId, amount) -> -- cgit v1.2.3 From 4c79ca374e030454f62a467fb4f2197d372e9bc1 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 15:53:46 +0100 Subject: Fix select input style --- client/src/Component/Select.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'client') diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 375ae06..70f5f58 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -35,7 +35,7 @@ view input = do rec let containerAttr = R.ffor showedError (\e -> M.singleton "class" $ T.intercalate " " - [ "input" + [ "input selectInput" , if Maybe.isJust e then "error" else "" ]) -- cgit v1.2.3 From 58f6c4e25f5f20f1b608242c83786e2f13947804 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 16:09:30 +0100 Subject: Delay modal event to let time for the modal to disappear --- client/src/Component/Modal.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'client') diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index 50af469..b0533e2 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -71,7 +71,8 @@ view input = do let hide = R.switchDyn $ (\(_, b, _) -> b) <$> dyn let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn - return content + -- Delay the event in order to let time for the modal to disappear + R.delay (0.3 :: NominalDiffTime) content getAttributes :: Text -> LM.Map Text Text getAttributes modalClass = -- cgit v1.2.3 From f4f24158a46d8c0975f1b8813bbdbbeebad8c108 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 6 Nov 2019 19:44:15 +0100 Subject: Show the payment table with server side paging --- client/client.cabal | 6 +- client/src/Component/Modal.hs | 2 +- client/src/Component/Table.hs | 21 +-- client/src/View/App.hs | 7 +- client/src/View/Income/Form.hs | 18 +- client/src/View/Income/Table.hs | 8 +- client/src/View/Payment/Add.hs | 55 ------ client/src/View/Payment/Clone.hs | 61 ------ client/src/View/Payment/Delete.hs | 58 ------ client/src/View/Payment/Edit.hs | 56 ------ client/src/View/Payment/Form.hs | 137 +++++++++----- client/src/View/Payment/Header.hs | 8 +- client/src/View/Payment/Pages.hs | 87 --------- client/src/View/Payment/Payment.hs | 367 ++++++++++++++++++++----------------- client/src/View/Payment/Reducer.hs | 66 +++++++ client/src/View/Payment/Table.hs | 315 +++++++++++++------------------ 16 files changed, 517 insertions(+), 755 deletions(-) delete mode 100644 client/src/View/Payment/Add.hs delete mode 100644 client/src/View/Payment/Clone.hs delete mode 100644 client/src/View/Payment/Delete.hs delete mode 100644 client/src/View/Payment/Edit.hs delete mode 100644 client/src/View/Payment/Pages.hs create mode 100644 client/src/View/Payment/Reducer.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 04c8543..75c2c1b 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -75,14 +75,10 @@ Executable client View.Income.Reducer View.Income.Table View.NotFound - View.Payment.Add - View.Payment.Clone - View.Payment.Delete - View.Payment.Edit View.Payment.Form View.Payment.Header View.Payment.Init - View.Payment.Pages View.Payment.Payment + View.Payment.Reducer View.Payment.Table View.SignIn diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index b0533e2..08f2e74 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -72,7 +72,7 @@ view input = do let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn -- Delay the event in order to let time for the modal to disappear - R.delay (0.3 :: NominalDiffTime) content + R.delay (0.5 :: NominalDiffTime) content getAttributes :: Text -> LM.Map Text Text getAttributes modalClass = diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index 3b9ec24..2869c2d 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -4,7 +4,7 @@ module Component.Table , Out(..) ) where -import qualified Data.Map as M +import qualified Data.Map as M import Data.Text (Text) import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R @@ -14,23 +14,23 @@ import qualified Component.Modal as Modal import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon -data In m t h r a = In +data In m t h r a b c = In { _in_headerLabel :: h -> Text , _in_rows :: [r] - , _in_cell :: h -> r -> Text + , _in_cell :: h -> r -> m () , _in_cloneModal :: r -> Modal.Content t m a - , _in_editModal :: r -> Modal.Content t m a - , _in_deleteModal :: r -> Modal.Content t m a + , _in_editModal :: r -> Modal.Content t m b + , _in_deleteModal :: r -> Modal.Content t m c , _in_isOwner :: r -> Bool } -data Out t a = Out +data Out t a b c = Out { _out_add :: Event t a - , _out_edit :: Event t a - , _out_delete :: Event t a + , _out_edit :: Event t b + , _out_delete :: Event t c } -view :: forall t m h r a. (MonadWidget t m, Bounded h, Enum h) => In m t h r a -> m (Out t a) +view :: forall t m h r a b c. (MonadWidget t m, Bounded h, Enum h) => In m t h r a b c-> m (Out t a b c) view input = R.divClass "table" $ do rec @@ -49,8 +49,7 @@ view input = R.divClass "row" $ do flip mapM_ [minBound..] $ \header -> R.divClass "cell" $ - R.text $ - _in_cell input header row + _in_cell input header row cloneButton <- R.divClass "cell button" $ diff --git a/client/src/View/App.hs b/client/src/View/App.hs index d305d00..2b346af 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -58,15 +58,14 @@ widget initResult = signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () signedWidget init route = do R.dyn . R.ffor route $ \case - RootRoute -> do - paymentInit <- Payment.init + RootRoute -> Payment.view $ Payment.In { Payment._in_currentUser = _init_currentUser init , Payment._in_currency = _init_currency init - , Payment._in_init = paymentInit + , Payment._in_users = _init_users init } - IncomeRoute -> do + IncomeRoute -> Income.view $ Income.In { Income._in_currentUser = _init_currentUser init , Income._in_currency = _init_currency init diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index a4f7de8..ff6e55e 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -27,7 +27,7 @@ import qualified Component.Modal as Modal import qualified Component.ModalForm as ModalForm import qualified Util.Ajax as Ajax -data In t = In +data In = In { _in_operation :: Operation } @@ -36,7 +36,7 @@ data Operation | Clone Income | Edit Income -view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Income +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m Income view input cancel = do rec @@ -94,14 +94,14 @@ view input cancel = do amount = case op of - New -> "" - Clone income -> T.pack . show . _income_amount $ income - Edit income -> T.pack . show . _income_amount $ income + New -> "" + Clone i -> T.pack . show . _income_amount $ i + Edit i -> T.pack . show . _income_amount $ i date currentDay = case op of - Edit income -> _income_date income - _ -> currentDay + Edit i -> _income_date i + _ -> currentDay ajax = case op of @@ -115,5 +115,5 @@ view input cancel = do mkPayload = case op of - Edit income -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id income) a b - _ -> \a b -> Aeson.toJSON $ CreateIncomeForm a b + Edit i -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id i) a b + _ -> \a b -> Aeson.toJSON $ CreateIncomeForm a b diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 32ab27b..c623acb 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -80,14 +80,14 @@ headerLabel UserHeader = Msg.get Msg.Income_Name headerLabel DateHeader = Msg.get Msg.Income_Date headerLabel AmountHeader = Msg.get Msg.Income_Amount -cell :: [User] -> Currency -> Header -> Income -> Text +cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Income -> m () cell users currency header income = case header of UserHeader -> - Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users + R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users DateHeader -> - Format.longDay . _income_date $ income + R.text . Format.longDay . _income_date $ income AmountHeader -> - Format.price currency . _income_amount $ income + R.text . Format.price currency . _income_amount $ income diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs deleted file mode 100644 index e983465..0000000 --- a/client/src/View/Payment/Add.hs +++ /dev/null @@ -1,55 +0,0 @@ -module View.Payment.Add - ( view - , In(..) - ) where - -import Control.Monad (join) -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import qualified Data.Time.Clock as Time -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), CreatePaymentForm (..), - Frequency (..), Payment (..), - PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as TimeUtil -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form - -data In t = In - { _in_categories :: [Category] - , _in_paymentCategories :: Dynamic t [PaymentCategory] - , _in_frequency :: Dynamic t Frequency - } - -view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment -view input cancel = do - - currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - - formOutput <- R.dyn $ do - paymentCategories <- _in_paymentCategories input - frequency <- _in_frequency input - return $ Form.view $ Form.In - { Form._in_cancel = cancel - , Form._in_headerLabel = Msg.get Msg.Payment_Add - , Form._in_categories = _in_categories input - , Form._in_paymentCategories = paymentCategories - , Form._in_name = "" - , Form._in_cost = "" - , Form._in_date = currentDay - , Form._in_category = -1 - , Form._in_frequency = frequency - , Form._in_mkPayload = CreatePaymentForm - , Form._in_ajax = Ajax.post - } - - hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) - addPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) - - return (hide, addPayment) diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs deleted file mode 100644 index 82b0c27..0000000 --- a/client/src/View/Payment/Clone.hs +++ /dev/null @@ -1,61 +0,0 @@ -module View.Payment.Clone - ( In(..) - , view - ) where - -import qualified Control.Monad as Monad -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import qualified Data.Time.Clock as Time -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), CategoryId, - CreatePaymentForm (..), Frequency (..), - Payment (..), PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as TimeUtil -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form - -data In t = In - { _in_show :: Event t () - , _in_categories :: [Category] - , _in_paymentCategories :: Dynamic t [PaymentCategory] - , _in_payment :: Dynamic t Payment - , _in_category :: Dynamic t CategoryId - } - -view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment -view input cancel = do - - currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - - form <- R.dyn $ do - paymentCategories <- _in_paymentCategories input - payment <- _in_payment input - category <- _in_category input - return . Form.view $ Form.In - { Form._in_cancel = cancel - , Form._in_headerLabel = Msg.get Msg.Payment_CloneLong - , Form._in_categories = _in_categories input - , Form._in_paymentCategories = paymentCategories - , Form._in_name = _payment_name payment - , Form._in_cost = T.pack . show . _payment_cost $ payment - , Form._in_date = currentDay - , Form._in_category = category - , Form._in_frequency = _payment_frequency payment - , Form._in_mkPayload = CreatePaymentForm - , Form._in_ajax = Ajax.post - } - - hide <- ReflexUtil.flatten (Form._output_hide <$> form) - clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> form) - - return $ - ( hide - , clonePayment - ) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs deleted file mode 100644 index e5e7219..0000000 --- a/client/src/View/Payment/Delete.hs +++ /dev/null @@ -1,58 +0,0 @@ -module View.Payment.Delete - ( In(..) - , view - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Payment (..)) -import qualified Common.Msg as Msg -import qualified Component.Button as Button -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.WaitFor as WaitFor - -data In t = In - { _in_payment :: Dynamic t Payment - } - -view :: forall t m. MonadWidget t m => (In t) -> Modal.Content t m Payment -view input _ = - R.divClass "delete" $ do - R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm - - R.divClass "deleteContent" $ do - - (confirm, cancel) <- R.divClass "buttons" $ do - - cancel <- Button._out_clic <$> (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) - { Button._in_class = R.constDyn "undo" }) - - rec - confirm <- Button._out_clic <$> (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { Button._in_class = R.constDyn "confirm" - , Button._in_submit = True - , Button._in_waiting = waiting - }) - - let url = - R.ffor (_in_payment input) (\id -> - T.concat ["/api/payment/", T.pack . show $ _payment_id id] - ) - - (result, waiting) <- WaitFor.waitFor - (Ajax.delete url) - confirm - - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) - - return $ - ( R.leftmost [ cancel, () <$ confirm ] - , R.tag (R.current $ _in_payment input) confirm - ) diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs deleted file mode 100644 index 5cb4537..0000000 --- a/client/src/View/Payment/Edit.hs +++ /dev/null @@ -1,56 +0,0 @@ -module View.Payment.Edit - ( In(..) - , view - ) where - -import qualified Control.Monad as Monad -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), CategoryId, - EditPaymentForm (..), Frequency (..), - Payment (..), PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form - -data In t = In - { _in_show :: Event t () - , _in_categories :: [Category] - , _in_paymentCategories :: Dynamic t [PaymentCategory] - , _in_payment :: Dynamic t Payment - , _in_category :: Dynamic t CategoryId - } - -view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment -view input cancel = do - - formOutput <- R.dyn $ do - paymentCategories <- _in_paymentCategories input - payment <- _in_payment input - category <- _in_category input - return . Form.view $ Form.In - { Form._in_cancel = cancel - , Form._in_headerLabel = Msg.get Msg.Payment_EditLong - , Form._in_categories = _in_categories input - , Form._in_paymentCategories = paymentCategories - , Form._in_name = _payment_name payment - , Form._in_cost = T.pack . show . _payment_cost $ payment - , Form._in_date = _payment_date payment - , Form._in_category = category - , Form._in_frequency = _payment_frequency payment - , Form._in_mkPayload = EditPaymentForm (_payment_id payment) - , Form._in_ajax = Ajax.put - } - - hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) - editPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) - - return $ - ( hide - , editPayment - ) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 29768aa..99b0848 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -1,10 +1,12 @@ module View.Payment.Form ( view , In(..) - , Out(..) + , Operation(..) ) where -import Data.Aeson (ToJSON) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson import qualified Data.List as L import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as M @@ -13,6 +15,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Clock import Data.Validation (Validation) import qualified Data.Validation as V import Reflex.Dom (Dynamic, Event, MonadWidget) @@ -20,103 +23,98 @@ import qualified Reflex.Dom as R import qualified Text.Read as T import Common.Model (Category (..), CategoryId, + CreatePaymentForm (..), + EditPaymentForm (..), Frequency (..), Payment (..), PaymentCategory (..), SavedPayment (..)) import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil import qualified Common.Validation.Payment as PaymentValidation + import qualified Component.Input as Input +import qualified Component.Modal as Modal import qualified Component.ModalForm as ModalForm import qualified Component.Select as Select +import qualified Util.Ajax as Ajax import qualified Util.Validation as ValidationUtil -data In m t a = In - { _in_cancel :: Event t () - , _in_headerLabel :: Text - , _in_categories :: [Category] +data In = In + { _in_categories :: [Category] , _in_paymentCategories :: [PaymentCategory] - , _in_name :: Text - , _in_cost :: Text - , _in_date :: Day - , _in_category :: CategoryId - , _in_frequency :: Frequency - , _in_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> a - , _in_ajax :: Text -> Event t a -> m (Event t (Either Text SavedPayment)) + , _in_operation :: Operation } -data Out t = Out - { _output_hide :: Event t () - , _output_addPayment :: Event t SavedPayment - } +data Operation + = New Frequency + | Clone Payment + | Edit Payment -view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t) -view input = do +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m SavedPayment +view input cancel = do rec let reset = R.leftmost [ "" <$ ModalForm._out_cancel modalForm , "" <$ ModalForm._out_validate modalForm - , "" <$ _in_cancel input + , "" <$ cancel ] modalForm <- ModalForm.view $ ModalForm.In - { ModalForm._in_headerLabel = _in_headerLabel input - , ModalForm._in_ajax = _in_ajax input "/api/payment" + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/payment" , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) } - return $ Out - { _output_hide = ModalForm._out_hide modalForm - , _output_addPayment = ModalForm._out_validate modalForm - } + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) where + form :: Event t String -> Event t () - -> m (Dynamic t (Validation (NonEmpty Text) a)) + -> m (Dynamic t (Validation (NonEmpty Text) Value)) form reset confirm = do name <- Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.Payment_Name - , Input._in_initialValue = _in_name input + , Input._in_initialValue = name , Input._in_validation = PaymentValidation.name }) - (_in_name input <$ reset) + (name <$ reset) confirm cost <- Input._out_raw <$> (Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.Payment_Cost - , Input._in_initialValue = _in_cost input + , Input._in_initialValue = cost , Input._in_validation = PaymentValidation.cost }) - (_in_cost input <$ reset) + (cost <$ reset) confirm) - let initialDate = T.pack . Calendar.showGregorian . _in_date $ input + d <- date date <- Input._out_raw <$> (Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.Payment_Date - , Input._in_initialValue = initialDate + , Input._in_initialValue = d , Input._in_inputType = "date" , Input._in_hasResetButton = False , Input._in_validation = PaymentValidation.date }) - (initialDate <$ reset) + (d <$ reset) confirm) let setCategory = R.fmapMaybe id . R.updated $ - R.ffor (Input._out_raw name) $ \name -> - findCategory name (_in_paymentCategories input) + R.ffor (Input._out_raw name) findCategory category <- Select._out_value <$> (Select.view $ Select.In { Select._in_label = Msg.get Msg.Payment_Category - , Select._in_initialValue = _in_category input + , Select._in_initialValue = category , Select._in_value = setCategory , Select._in_values = R.constDyn categories - , Select._in_reset = _in_category input <$ reset + , Select._in_reset = category <$ reset , Select._in_isValid = PaymentValidation.category (map _category_id $ _in_categories input) , Select._in_validate = confirm }) @@ -126,12 +124,12 @@ view input = do c <- cost d <- date cat <- category - return ((_in_mkPayload input) + return (mkPayload <$> ValidationUtil.nelError n <*> V.Success c <*> V.Success d <*> ValidationUtil.nelError cat - <*> V.Success (_in_frequency input)) + <*> V.Success frequency) frequencies = M.fromList @@ -142,7 +140,58 @@ view input = do categories = M.fromList . flip map (_in_categories input) $ \c -> (_category_id c, _category_name c) -findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId -findCategory paymentName = - fmap _paymentCategory_category - . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) + op = _in_operation input + + name = + case op of + New _ -> "" + Clone p -> _payment_name p + Edit p -> _payment_name p + + cost = + case op of + New _ -> "" + Clone p -> T.pack . show . _payment_cost $ p + Edit p -> T.pack . show . _payment_cost $ p + + date = do + currentDay <- liftIO $ Clock.getCurrentTime >>= TimeUtil.timeToDay + return . T.pack . Calendar.showGregorian $ + case op of + New _ -> currentDay + Clone p -> currentDay + Edit p -> _payment_date p + + category = + case op of + New _ -> -1 + Clone p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) + Edit p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) + + frequency = + case op of + New f -> f + Clone p -> _payment_frequency p + Edit p -> _payment_frequency p + + headerLabel = + case op of + New _ -> Msg.get Msg.Payment_Add + Clone _ -> Msg.get Msg.Payment_CloneLong + Edit _ -> Msg.get Msg.Payment_EditLong + + ajax = + case op of + Edit _ -> Ajax.put + _ -> Ajax.post + + mkPayload = + case op of + Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e + _ -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e + + findCategory :: Text -> Maybe CategoryId + findCategory paymentName = + fmap _paymentCategory_category + . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) + $ (_in_paymentCategories input) diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 00987a3..c8ca347 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -32,7 +32,7 @@ import qualified Component.Input as Input import qualified Component.Modal as Modal import qualified Component.Select as Select import qualified Util.List as L -import qualified View.Payment.Add as Add +import qualified View.Payment.Form as Form import View.Payment.Init (Init (..)) data In t = In @@ -120,11 +120,7 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen Modal.view $ Modal.In { Modal._in_show = addPayment - , Modal._in_content = Add.view $ Add.In - { Add._in_categories = categories - , Add._in_paymentCategories = paymentCategories - , Add._in_frequency = frequency - } + , Modal._in_content = \_ -> return (R.never, R.never) -- TODO } searchLine diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs deleted file mode 100644 index 9a1902c..0000000 --- a/client/src/View/Payment/Pages.hs +++ /dev/null @@ -1,87 +0,0 @@ -module View.Payment.Pages - ( view - , In(..) - , Out(..) - ) where - -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import qualified Component.Button as Button - -import qualified Util.Reflex as ReflexUtil -import qualified View.Icon as Icon - -data In t = In - { _in_total :: Dynamic t Int - , _in_perPage :: Int - , _in_reset :: Event t () - } - -data Out t = Out - { _out_currentPage :: Dynamic t Int - } - -view :: forall t m. MonadWidget t m => In t -> m (Out t) -view input = do - currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset - - return $ Out - { _out_currentPage = currentPage - } - - where - total = _in_total input - perPage = _in_perPage input - reset = _in_reset input - -pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) -pageButtons total perPage reset = do - R.divClass "pages" $ do - rec - currentPage <- R.holdDyn 1 . R.leftmost $ - [ firstPageClic - , previousPageClic - , pageClic - , nextPageClic - , lastPageClic - , 1 <$ reset - ] - - firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar - - previousPageClic <- pageButton noCurrentPage (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft - - pageClic <- pageEvent <$> (R.simpleList (range <$> currentPage <*> maxPage) $ \p -> - pageButton (Just <$> currentPage) p (R.dynText $ fmap (T.pack . show) p)) - - nextPageClic <- pageButton noCurrentPage ((\c m -> min (c + 1) m) <$> currentPage <*> maxPage) Icon.doubleRight - - lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar - - return currentPage - - where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) - pageEvent = R.switch . R.current . fmap R.leftmost - noCurrentPage = R.constDyn Nothing - -range :: Int -> Int -> [Int] -range currentPage maxPage = [start..end] - where sidePages = 2 - start = max 1 (min (currentPage - sidePages) (maxPage - sidePages * 2)) - end = min maxPage (start + sidePages * 2) - -pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int) -pageButton currentPage page content = do - clic <- Button._out_clic <$> (Button.view $ Button.In - { Button._in_class = do - cp <- currentPage - p <- page - if cp == Just p then "page current" else "page" - , Button._in_content = content - , Button._in_waiting = R.never - , Button._in_tabIndex = Nothing - , Button._in_submit = False - }) - return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index e72577f..bf0186f 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -1,181 +1,218 @@ module View.Payment.Payment - ( init - , view + ( view , In(..) ) where -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime) -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Frequency, Income (..), - Payment (..), PaymentCategory (..), - PaymentId, SavedPayment (..), User, - UserId) -import qualified Common.Util.Text as T - -import Loadable (Loadable (..)) +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Frequency, Income (..), + Payment (..), PaymentCategory (..), + PaymentId, PaymentPage (..), + SavedPayment (..), User, UserId) +import qualified Common.Util.Text as T + +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) import qualified Loadable -import qualified Util.Ajax as AjaxUtil -import qualified View.Payment.Header as Header -import View.Payment.Init (Init (..)) -import qualified View.Payment.Pages as Pages -import qualified View.Payment.Table as Table - -init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) -init = do - users <- AjaxUtil.getNow "api/users" - payments <- AjaxUtil.getNow "api/payments" - incomes <- AjaxUtil.getNow "api/deprecated/incomes" - categories <- AjaxUtil.getNow "api/categories" - paymentCategories <- AjaxUtil.getNow "api/paymentCategories" - return $ do - us <- users - ps <- payments - is <- incomes - cs <- categories - pcs <- paymentCategories - return $ Init <$> us <*> ps <*> is <*> cs <*> pcs - +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Header as Header +import View.Payment.Init (Init (..)) +import qualified View.Payment.Reducer as Reducer +import qualified View.Payment.Table as Table data In t = In { _in_currentUser :: UserId + , _in_users :: [User] , _in_currency :: Currency - , _in_init :: Dynamic t (Loadable Init) } view :: forall t m. MonadWidget t m => In t -> m () view input = do - R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> - - R.elClass "main" "payment" $ do - rec - let addPayment = R.leftmost - [ Header._out_addPayment header - , Table._out_addPayment table - ] - - paymentsPerPage = 7 - - payments <- reducePayments - (_init_payments init) - (_savedPayment_payment <$> addPayment) - (_savedPayment_payment <$> Table._out_editPayment table) - (Table._out_deletePayment table) - - paymentCategories <- reducePaymentCategories - (_init_paymentCategories init) - payments - (_savedPayment_paymentCategory <$> addPayment) - (_savedPayment_paymentCategory <$> Table._out_editPayment table) - (Table._out_deletePayment table) - - (searchNameEvent, searchName) <- - debounceSearchName (Header._out_searchName header) - - let searchPayments = - getSearchPayments searchName (Header._out_searchFrequency header) payments - - header <- Header.view $ Header.In - { Header._in_init = init - , Header._in_currency = _in_currency input - , Header._in_payments = payments - , Header._in_searchPayments = searchPayments - , Header._in_paymentCategories = paymentCategories - } - - table <- Table.view $ Table.In - { Table._in_init = init - , Table._in_currency = _in_currency input - , Table._in_currentUser = _in_currentUser input - , Table._in_currentPage = Pages._out_currentPage pages - , Table._in_payments = searchPayments - , Table._in_perPage = paymentsPerPage - , Table._in_paymentCategories = paymentCategories - } - - pages <- Pages.view $ Pages.In - { Pages._in_total = length <$> searchPayments - , Pages._in_perPage = paymentsPerPage - , Pages._in_reset = R.leftmost $ - [ () <$ searchNameEvent - , () <$ Header._out_addPayment header - ] - } - - pure () + + categoriesEvent <- (AjaxUtil.getNow "api/categories") + + R.dyn . R.ffor categoriesEvent . Loadable.view $ \categories -> do + + rec + payments <- Reducer.reducer $ Reducer.In + { Reducer._in_newPage = newPage + , Reducer._in_currentPage = currentPage + , Reducer._in_addPayment = R.leftmost [headerAddPayment, tableAddPayment] + , Reducer._in_editPayment = editPayment + , Reducer._in_deletePayment = deletePayment + } + + let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result + + newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) + currentPage <- R.holdDyn 1 newPage + -- headerAddPayment <- eventFromResult $ Header._out_add . (\(a, _, _) -> a) + let headerAddPayment = R.never + tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) + editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) + deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) + + result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) -> + flip Loadable.view is $ \(PaymentPage payments paymentCategories count) -> do + table <- Table.view $ Table.In + { Table._in_users = _in_users input + , Table._in_currentUser = _in_currentUser input + , Table._in_categories = categories + , Table._in_currency = _in_currency input + , Table._in_payments = payments + , Table._in_paymentCategories = paymentCategories + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = p + } + + return ((), table, pages) + + return () return () -debounceSearchName - :: forall t m. MonadWidget t m - => Dynamic t Text - -> m (Event t Text, Dynamic t Text) -debounceSearchName searchName = do - event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) - dynamic <- R.holdDyn "" event - return (event, dynamic) - -reducePayments - :: forall t m. MonadWidget t m - => [Payment] - -> Event t Payment -- add payment - -> Event t Payment -- edit payment - -> Event t Payment -- delete payment - -> m (Dynamic t [Payment]) -reducePayments initPayments addPayment editPayment deletePayment = - R.foldDyn id initPayments $ R.leftmost - [ (:) <$> addPayment - , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) - , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) - ] - -reducePaymentCategories - :: forall t m. MonadWidget t m - => [PaymentCategory] - -> Dynamic t [Payment] -- payments - -> Event t PaymentCategory -- add payment category - -> Event t PaymentCategory -- edit payment category - -> Event t Payment -- delete payment - -> m (Dynamic t [PaymentCategory]) -reducePaymentCategories - initPaymentCategories - payments - addPaymentCategory - editPaymentCategory - deletePayment - = - R.foldDyn id initPaymentCategories $ R.leftmost - [ (:) <$> addPaymentCategory - , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) - , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) - ] - where - deletePaymentName = - R.attachWithMaybe - (\ps p -> - if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then - Nothing - else - Just (_payment_name p)) - (R.current payments) - deletePayment - lowerName = T.toLower . _payment_name - -getSearchPayments - :: forall t. Reflex t - => Dynamic t Text - -> Dynamic t Frequency - -> Dynamic t [Payment] - -> Dynamic t [Payment] -getSearchPayments name frequency payments = do - n <- name - f <- frequency - ps <- payments - pure $ flip filter ps (\p -> - ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) - && (_payment_frequency p == f) - )) + +-- view :: forall t m. MonadWidget t m => In t -> m () +-- view input = do +-- R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> +-- +-- R.elClass "main" "payment" $ do +-- rec +-- let addPayment = R.leftmost +-- -- [ Header._out_addPayment header +-- [ Table2._out_addPayment table +-- ] +-- +-- paymentsPerPage = 7 +-- +-- payments <- reducePayments +-- (_init_payments init) +-- (_savedPayment_payment <$> addPayment) +-- (_savedPayment_payment <$> Table2._out_editPayment table) +-- (Table2._out_deletePayment table) +-- +-- paymentCategories <- reducePaymentCategories +-- (_init_paymentCategories init) +-- payments +-- (_savedPayment_paymentCategory <$> addPayment) +-- (_savedPayment_paymentCategory <$> Table2._out_editPayment table) +-- (Table2._out_deletePayment table) +-- +-- -- (searchNameEvent, searchName) <- +-- -- debounceSearchName (Header._out_searchName header) +-- +-- -- let searchPayments = +-- -- getSearchPayments searchName (Header._out_searchFrequency header) payments +-- +-- -- header <- Header.view $ Header.In +-- -- { Header._in_init = init +-- -- , Header._in_currency = _in_currency input +-- -- , Header._in_payments = payments +-- -- , Header._in_searchPayments = searchPayments +-- -- , Header._in_paymentCategories = paymentCategories +-- -- } +-- +-- table <- Table2.view $ Table2.In +-- { Table2._in_init = init +-- , Table2._in_currency = _in_currency input +-- , Table2._in_currentUser = _in_currentUser input +-- , Table2._in_currentPage = Pages2._out_currentPage pages +-- , Table2._in_payments = payments +-- , Table2._in_perPage = paymentsPerPage +-- , Table2._in_paymentCategories = paymentCategories +-- } +-- +-- pages <- Pages2.view $ Pages2.In +-- { Pages2._in_total = length <$> payments +-- , Pages2._in_perPage = paymentsPerPage +-- , Pages2._in_reset = R.never +-- -- [ () <$ searchNameEvent +-- -- [ () <$ Header._out_addPayment header +-- -- ] +-- } +-- +-- pure () +-- +-- return () +-- +-- -- debounceSearchName +-- -- :: forall t m. MonadWidget t m +-- -- => Dynamic t Text +-- -- -> m (Event t Text, Dynamic t Text) +-- -- debounceSearchName searchName = do +-- -- event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) +-- -- dynamic <- R.holdDyn "" event +-- -- return (event, dynamic) +-- +-- reducePayments +-- :: forall t m. MonadWidget t m +-- => [Payment] +-- -> Event t Payment -- add payment +-- -> Event t Payment -- edit payment +-- -> Event t Payment -- delete payment +-- -> m (Dynamic t [Payment]) +-- reducePayments initPayments addPayment editPayment deletePayment = +-- R.foldDyn id initPayments $ R.leftmost +-- [ (:) <$> addPayment +-- , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) +-- , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) +-- ] +-- +-- reducePaymentCategories +-- :: forall t m. MonadWidget t m +-- => [PaymentCategory] +-- -> Dynamic t [Payment] -- payments +-- -> Event t PaymentCategory -- add payment category +-- -> Event t PaymentCategory -- edit payment category +-- -> Event t Payment -- delete payment +-- -> m (Dynamic t [PaymentCategory]) +-- reducePaymentCategories +-- initPaymentCategories +-- payments +-- addPaymentCategory +-- editPaymentCategory +-- deletePayment +-- = +-- R.foldDyn id initPaymentCategories $ R.leftmost +-- [ (:) <$> addPaymentCategory +-- , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) +-- , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) +-- ] +-- where +-- deletePaymentName = +-- R.attachWithMaybe +-- (\ps p -> +-- if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then +-- Nothing +-- else +-- Just (_payment_name p)) +-- (R.current payments) +-- deletePayment +-- lowerName = T.toLower . _payment_name +-- +-- -- getSearchPayments +-- -- :: forall t. Reflex t +-- -- => Dynamic t Text +-- -- -> Dynamic t Frequency +-- -- -> Dynamic t [Payment] +-- -- -> Dynamic t [Payment] +-- -- getSearchPayments name frequency payments = do +-- -- n <- name +-- -- f <- frequency +-- -- ps <- payments +-- -- pure $ flip filter ps (\p -> +-- -- ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) +-- -- && (_payment_frequency p == f) +-- -- )) diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs new file mode 100644 index 0000000..0c70f8a --- /dev/null +++ b/client/src/View/Payment/Reducer.hs @@ -0,0 +1,66 @@ +module View.Payment.Reducer + ( perPage + , reducer + , In(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (PaymentPage) + +import Loadable (Loadable (..)) +import qualified Loadable as Loadable +import qualified Util.Ajax as AjaxUtil + +perPage :: Int +perPage = 7 + +data In t a b c = In + { _in_newPage :: Event t Int + , _in_currentPage :: Dynamic t Int + , _in_addPayment :: Event t a + , _in_editPayment :: Event t b + , _in_deletePayment :: Event t c + } + +data Action + = LoadPage Int + | GetResult (Either Text PaymentPage) + +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage)) +reducer input = do + + postBuild <- R.getPostBuild + + let loadPage = + R.leftmost + [ 1 <$ postBuild + , _in_newPage input + , 1 <$ _in_addPayment input + , R.tag (R.current $ _in_currentPage input) (_in_editPayment input) + , R.tag (R.current $ _in_currentPage input) (_in_deletePayment input) + ] + + getResult <- AjaxUtil.get $ fmap pageUrl loadPage + + R.foldDyn + (\action _ -> case action of + LoadPage _ -> Loading + GetResult (Left err) -> Error err + GetResult (Right payments) -> Loaded payments + ) + Loading + (R.leftmost + [ LoadPage <$> loadPage + , GetResult <$> getResult + ]) + + where + pageUrl p = + "api/payments?page=" + <> (T.pack . show $ p) + <> "&perPage=" + <> (T.pack . show $ perPage) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 0793836..dde5168 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -4,209 +4,146 @@ module View.Payment.Table , Out(..) ) where -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), Currency, - Frequency (Punctual), Payment (..), - PaymentCategory (..), SavedPayment, - User (..), UserId) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format -import qualified Component.Button as Button -import qualified Component.Modal as Modal -import qualified View.Payment.Clone as Clone -import qualified View.Payment.Delete as Delete -import qualified View.Payment.Edit as Edit -import View.Payment.Init (Init (..)) - -import qualified Util.Reflex as ReflexUtil -import qualified View.Icon as Icon +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Currency, Payment (..), + PaymentCategory (..), SavedPayment, + User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Component.ConfirmDialog as ConfirmDialog +import qualified Component.Table as Table +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Payment.Form as Form data In t = In - { _in_init :: Init - , _in_currency :: Currency + { _in_users :: [User] , _in_currentUser :: UserId - , _in_currentPage :: Dynamic t Int - , _in_payments :: Dynamic t [Payment] - , _in_perPage :: Int - , _in_paymentCategories :: Dynamic t [PaymentCategory] , _in_categories :: [Category] + , _in_currency :: Currency + , _in_payments :: [Payment] + , _in_paymentCategories :: [PaymentCategory] } data Out t = Out - { _out_addPayment :: Event t SavedPayment - , _out_editPayment :: Event t SavedPayment - , _out_deletePayment :: Event t Payment + { _out_add :: Event t SavedPayment + , _out_edit :: Event t SavedPayment + , _out_delete :: Event t Payment } view :: forall t m. MonadWidget t m => In t -> m (Out t) view input = do - R.divClass "table" $ do - - (addPayment, editPayment, deletePayment) <- R.divClass "lines" $ do - R.divClass "header" $ do - R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name - R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost - R.divClass "cell user" $ R.text $ Msg.get Msg.Payment_User - R.divClass "cell category" $ R.text $ Msg.get Msg.Payment_Category - R.divClass "cell date" $ R.text $ Msg.get Msg.Payment_Date - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - - result <- - (R.simpleList paymentRange (paymentRow init currency currentUser paymentCategories)) - - return $ - ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result - , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result - , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result - ) - - ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ - R.text $ Msg.get Msg.Payment_Empty - - return $ Out - { _out_addPayment = addPayment - , _out_editPayment = editPayment - , _out_deletePayment = deletePayment - } - - where - init = _in_init input - currency = _in_currency input - currentUser = _in_currentUser input - currentPage = _in_currentPage input - payments = _in_payments input - paymentRange = getPaymentRange (_in_perPage input) <$> payments <*> currentPage - paymentCategories = _in_paymentCategories input - -getPaymentRange :: Int -> [Payment] -> Int -> [Payment] -getPaymentRange perPage payments currentPage = - take perPage - . drop ((currentPage - 1) * perPage) - . reverse - . L.sortOn _payment_date - $ payments - -paymentRow - :: forall t m. MonadWidget t m - => Init - -> Currency - -> UserId - -> Dynamic t [PaymentCategory] - -> Dynamic t Payment - -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment) -paymentRow init currency currentUser paymentCategories payment = - R.divClass "row" $ do - - R.divClass "cell name" $ - R.dynText $ fmap _payment_name payment - - R.divClass "cell cost" $ - R.dynText $ fmap (Format.price currency . _payment_cost) payment - - let user = R.ffor payment (\p -> - CM.findUser (_payment_user p) (_init_users init)) - - R.divClass "cell user" $ - R.dynText $ flip fmap user $ \mbUser -> case mbUser of - Just u -> _user_name u - _ -> "" - - let category = do - p <- payment - pcs <- paymentCategories - return $ findCategory (_init_categories init) pcs (_payment_name p) - - R.divClass "cell category" $ do - - let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of - Just c -> M.fromList - [ ("class", "tag") - , ("style", T.concat [ "background-color: ", _category_color c ]) - ] - Nothing -> M.singleton "display" "none" - - R.elDynAttr "span" attrs $ - R.dynText $ R.ffor category $ \case - Just c -> _category_name c - _ -> "" - - R.divClass "cell date" $ do - R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment - R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment - - let categoryId = (Maybe.fromMaybe (-1) . fmap _category_id) <$> category - - clonePayment <- - R.divClass "cell button" $ - Button._out_clic <$> (Button.view $ - Button.defaultIn Icon.clone) - - paymentCloned <- - Modal.view $ Modal.In - { Modal._in_show = clonePayment - , Modal._in_content = - Clone.view $ Clone.In - { Clone._in_show = clonePayment - , Clone._in_categories = _init_categories init - , Clone._in_paymentCategories = paymentCategories - , Clone._in_payment = payment - , Clone._in_category = categoryId - } - } - let isFromCurrentUser = - R.ffor - payment - (\p -> _payment_user p == currentUser) - - editPayment <- - R.divClass "cell button" $ - ReflexUtil.divVisibleIf isFromCurrentUser $ - Button._out_clic <$> (Button.view $ - Button.defaultIn Icon.edit) - - paymentEdited <- - Modal.view $ Modal.In - { Modal._in_show = editPayment - , Modal._in_content = - Edit.view $ Edit.In - { Edit._in_show = editPayment - , Edit._in_categories = _init_categories init - , Edit._in_paymentCategories = paymentCategories - , Edit._in_payment = payment - , Edit._in_category = categoryId - } + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input + , Table._in_cell = + cell + (_in_users input) + (_in_categories input) + (_in_paymentCategories input) + (_in_currency input) + , Table._in_cloneModal = \payment -> + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_paymentCategories = _in_paymentCategories input + , Form._in_operation = Form.Clone payment } - - deletePayment <- - R.divClass "cell button" $ - ReflexUtil.divVisibleIf isFromCurrentUser $ - Button._out_clic <$> (Button.view $ - (Button.defaultIn Icon.delete) - { Button._in_class = R.constDyn "deletePayment" - }) - - paymentDeleted <- - Modal.view $ Modal.In - { Modal._in_show = deletePayment - , Modal._in_content = - Delete.view $ Delete.In - { Delete._in_payment = payment - } + , Table._in_editModal = \payment -> + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_paymentCategories = _in_paymentCategories input + , Form._in_operation = Form.Edit payment } - - return $ (paymentCloned, paymentEdited, paymentDeleted) + , Table._in_deleteModal = \payment -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Payment_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/payment/", T.pack . show $ _payment_id payment]) + e + return $ payment <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user + } + + return $ Out + { _out_add = Table._out_add table + , _out_edit = Table._out_edit table + , _out_delete = Table._out_delete table + } + +data Header + = NameHeader + | CostHeader + | UserHeader + | CategoryHeader + | DateHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel NameHeader = Msg.get Msg.Payment_Name +headerLabel CostHeader = Msg.get Msg.Payment_Cost +headerLabel UserHeader = Msg.get Msg.Payment_User +headerLabel CategoryHeader = Msg.get Msg.Payment_Category +headerLabel DateHeader = Msg.get Msg.Payment_Date + +cell + :: forall t m. MonadWidget t m + => [User] + -> [Category] + -> [PaymentCategory] + -> Currency + -> Header + -> Payment + -> m () +cell users categories paymentCategories currency header payment = + case header of + NameHeader -> + R.text $ _payment_name payment + + CostHeader -> + R.text . Format.price currency . _payment_cost $ payment + + UserHeader -> + R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_payment_user payment) users + + CategoryHeader -> + let + category = + findCategory categories paymentCategories (_payment_name payment) + + attrs = + case category of + Just c -> + M.fromList + [ ("class", "tag") + , ("style", T.concat [ "background-color: ", _category_color c ]) + ] + + Nothing -> + M.singleton "display" "none" + in + R.elAttr "span" attrs $ + R.text $ + Maybe.fromMaybe "" (_category_name <$> category) + + DateHeader -> + do + R.elClass "span" "shortDate" $ + R.text . Format.shortDay . _payment_date $ payment + + R.elClass "span" "longDate" $ + R.text . Format.longDay . _payment_date $ payment findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do -- cgit v1.2.3 From 4dc84dbda7ba3ea60d13e6f81eeec556974b7c72 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 7 Nov 2019 07:59:41 +0100 Subject: Show payment header infos --- client/client.cabal | 5 +- client/src/View/Payment/Header.hs | 187 --------------------------------- client/src/View/Payment/HeaderForm.hs | 78 ++++++++++++++ client/src/View/Payment/HeaderInfos.hs | 96 +++++++++++++++++ client/src/View/Payment/Init.hs | 13 --- client/src/View/Payment/Payment.hs | 53 ++++++---- 6 files changed, 206 insertions(+), 226 deletions(-) delete mode 100644 client/src/View/Payment/Header.hs create mode 100644 client/src/View/Payment/HeaderForm.hs create mode 100644 client/src/View/Payment/HeaderInfos.hs delete mode 100644 client/src/View/Payment/Init.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 75c2c1b..78ea7d3 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -61,7 +61,6 @@ Executable client Util.Ajax Util.Css Util.Either - Util.List Util.Reflex Util.Router Util.Validation @@ -76,8 +75,8 @@ Executable client View.Income.Table View.NotFound View.Payment.Form - View.Payment.Header - View.Payment.Init + View.Payment.HeaderForm + View.Payment.HeaderInfos View.Payment.Payment View.Payment.Reducer View.Payment.Table diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs deleted file mode 100644 index c8ca347..0000000 --- a/client/src/View/Payment/Header.hs +++ /dev/null @@ -1,187 +0,0 @@ -module View.Payment.Header - ( view - , In(..) - , Out(..) - ) where - -import Control.Monad (forM_) -import Control.Monad.IO.Class (liftIO) -import qualified Data.List as L hiding (groupBy) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (NominalDiffTime) -import qualified Data.Time as Time -import qualified Data.Validation as V -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Category, Currency, - ExceedingPayer (..), Frequency (..), - Income (..), Payment (..), - PaymentCategory, SavedPayment (..), - User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format - -import qualified Component.Button as Button -import qualified Component.Input as Input -import qualified Component.Modal as Modal -import qualified Component.Select as Select -import qualified Util.List as L -import qualified View.Payment.Form as Form -import View.Payment.Init (Init (..)) - -data In t = In - { _in_init :: Init - , _in_currency :: Currency - , _in_payments :: Dynamic t [Payment] - , _in_searchPayments :: Dynamic t [Payment] - , _in_paymentCategories :: Dynamic t [PaymentCategory] - } - -data Out t = Out - { _out_searchName :: Dynamic t Text - , _out_searchFrequency :: Dynamic t Frequency - , _out_addPayment :: Event t SavedPayment - } - -view :: forall t m. MonadWidget t m => In t -> m (Out t) -view input = - R.divClass "header" $ do - rec - addPayment <- - payerAndAdd - incomes - payments - users - categories - paymentCategories - currency - searchFrequency - let resetSearchName = fmap (const ()) $ addPayment - (searchName, searchFrequency) <- searchLine resetSearchName - - infos (_in_searchPayments input) users currency - - return $ Out - { _out_searchName = searchName - , _out_searchFrequency = searchFrequency - , _out_addPayment = addPayment - } - where - init = _in_init input - incomes = _init_incomes init - initPayments = _init_payments init - payments = _in_payments input - users = _init_users init - categories = _init_categories init - currency = _in_currency input - paymentCategories = _in_paymentCategories input - -payerAndAdd - :: forall t m. MonadWidget t m - => [Income] - -> Dynamic t [Payment] - -> [User] - -> [Category] - -> Dynamic t [PaymentCategory] - -> Currency - -> Dynamic t Frequency - -> m (Event t SavedPayment) -payerAndAdd incomes payments users categories paymentCategories currency frequency = do - time <- liftIO Time.getCurrentTime - R.divClass "payerAndAdd" $ do - - let exceedingPayers = - R.ffor payments $ \ps -> - CM.getExceedingPayers time users incomes $ - filter ((==) Punctual . _payment_frequency) ps - - R.divClass "exceedingPayers" $ - R.simpleList exceedingPayers $ \exceedingPayer -> - R.elClass "span" "exceedingPayer" $ do - R.elClass "span" "userName" $ - R.dynText . R.ffor exceedingPayer $ \ep -> - fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users - R.elClass "span" "amount" $ do - R.text "+ " - R.dynText . R.ffor exceedingPayer $ \ep -> - Format.price currency $ _exceedingPayer_amount ep - - addPayment <- Button._out_clic <$> - (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add)) - { Button._in_class = R.constDyn "addPayment" - }) - - Modal.view $ Modal.In - { Modal._in_show = addPayment - , Modal._in_content = \_ -> return (R.never, R.never) -- TODO - } - -searchLine - :: forall t m. MonadWidget t m - => Event t () - -> m (Dynamic t Text, Dynamic t Frequency) -searchLine reset = do - R.divClass "searchLine" $ do - searchName <- Input._out_raw <$> (Input.view - ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) - ("" <$ reset) - R.never) - - let frequencies = M.fromList - [ (Punctual, Msg.get Msg.Payment_PunctualMale) - , (Monthly, Msg.get Msg.Payment_MonthlyMale) - ] - - searchFrequency <- Select._out_raw <$> (Select.view $ Select.In - { Select._in_label = "" - , Select._in_initialValue = Punctual - , Select._in_value = R.never - , Select._in_values = R.constDyn frequencies - , Select._in_reset = R.never - , Select._in_isValid = V.Success - , Select._in_validate = R.never - }) - - return (searchName, searchFrequency) - -infos - :: forall t m. MonadWidget t m - => Dynamic t [Payment] - -> [User] - -> Currency -> m () -infos payments users currency = - R.divClass "infos" $ do - - R.elClass "span" "total" $ do - R.dynText $ do - ps <- payments - let paymentCount = length ps - total = sum . map _payment_cost $ ps - pure . Msg.get $ Msg.Payment_Worth - (T.intercalate " " - [ (Format.number paymentCount) - , if paymentCount > 1 - then Msg.get Msg.Payment_Many - else Msg.get Msg.Payment_One - ]) - (Format.price currency total) - - R.elClass "span" "partition" . R.dynText $ do - ps <- payments - let totalByUser = - L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) - . map (\(u, xs) -> (u, sum . map snd $ xs)) - . L.groupBy fst - . map (\p -> (_payment_user p, _payment_cost p)) - $ ps - pure . T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) -> - Msg.get $ Msg.Payment_By - (fromMaybe "" . fmap _user_name $ CM.findUser userId users) - (Format.price currency userTotal) diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs new file mode 100644 index 0000000..07a6b81 --- /dev/null +++ b/client/src/View/Payment/HeaderForm.hs @@ -0,0 +1,78 @@ +module View.Payment.HeaderForm + ( view + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category, Currency, ExceedingPayer (..), + Frequency (..), Income (..), Payment (..), + PaymentCategory, SavedPayment (..), + User (..)) +import qualified Common.Msg as Msg + +import qualified Component.Button as Button +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.Select as Select +import qualified View.Payment.Form as Form + +data In t = In + { _in_reset :: Event t () + , _in_categories :: [Category] + , _in_paymentCategories :: [PaymentCategory] + } + +data Out = Out + { _out_name :: Event t Text + , _out_frequency :: Event t Frequency + , _out_addPayment :: Event t SavedPayment + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do + R.divClass "g-HeaderForm" $ do + searchName <- Input._out_raw <$> (Input.view + ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) + ("" <$ _in_reset input) + R.never) + + let frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + searchFrequency <- Select._out_raw <$> (Select.view $ Select.In + { Select._in_label = "" + , Select._in_initialValue = Punctual + , Select._in_value = R.never + , Select._in_values = R.constDyn frequencies + , Select._in_reset = R.never + , Select._in_isValid = V.Success + , Select._in_validate = R.never + }) + + addPaymentButton <- Button._out_clic <$> + (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add)) + { Button._in_class = R.constDyn "addPayment" + }) + + addPayment <- Modal.view $ Modal.In + { Modal._in_show = addPaymentButton + , Modal._in_content = + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_paymentCategories = _in_paymentCategories input + , Form._in_operation = Form.New searchFrequency + } + } + + return $ Out + { _out_name = searchName + , _out_frequency = searchFrequency + , _out_addPayment = addPayment + } diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs new file mode 100644 index 0000000..12facc4 --- /dev/null +++ b/client/src/View/Payment/HeaderInfos.hs @@ -0,0 +1,96 @@ +module View.Payment.HeaderInfos + ( view + , In(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L hiding (groupBy) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Time as Time +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, ExceedingPayer (..), + Payment (..), PaymentHeader (..), + SavedPayment (..), User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Util.List as L + +data In t = In + { _in_users :: [User] + , _in_currency :: Currency + , _in_header :: PaymentHeader + , _in_paymentCount :: Int + } + +view :: forall t m. MonadWidget t m => In t -> m () +view input = + R.divClass "g-HeaderInfos" $ do + exceedingPayers + (_in_users input) + (_in_currency input) + (_paymentHeader_exceedingPayers header) + + infos + (_in_users input) + (_in_currency input) + (_paymentHeader_repartition header) + (_in_paymentCount input) + + where + header = _in_header input + +exceedingPayers + :: forall t m. MonadWidget t m + => [User] + -> Currency + -> [ExceedingPayer] + -> m () +exceedingPayers users currency payers = + R.divClass "g-HeaderInfos__ExceedingPayers" $ + flip mapM_ payers $ \payer -> + R.elClass "span" "exceedingPayer" $ do + R.elClass "span" "userName" $ + R.text $ + fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId payer) users + R.elClass "span" "amount" $ do + R.text "+ " + R.text . Format.price currency $ _exceedingPayer_amount payer + +infos + :: forall t m. MonadWidget t m + => [User] + -> Currency + -> Map UserId Int + -> Int + -> m () +infos users currency repartition paymentCount = + R.divClass "g-HeaderInfos__Repartition" $ do + + R.elClass "span" "total" $ do + R.text $ + Msg.get $ Msg.Payment_Worth + (T.intercalate " " + [ (Format.number paymentCount) + , if paymentCount > 1 + then Msg.get Msg.Payment_Many + else Msg.get Msg.Payment_One + ]) + (Format.price currency (M.foldl (+) 0 repartition)) + + R.elClass "span" "partition" . R.text $ + let totalByUser = + L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) + . M.toList + $ repartition + in T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) -> + Msg.get $ Msg.Payment_By + (fromMaybe "" . fmap _user_name $ CM.findUser userId users) + (Format.price currency userTotal) diff --git a/client/src/View/Payment/Init.hs b/client/src/View/Payment/Init.hs deleted file mode 100644 index d9f85c8..0000000 --- a/client/src/View/Payment/Init.hs +++ /dev/null @@ -1,13 +0,0 @@ -module View.Payment.Init - ( Init(..) - ) where - -import Common.Model (Category, Income, Payment, PaymentCategory, User) - -data Init = Init - { _init_users :: [User] - , _init_payments :: [Payment] - , _init_incomes :: [Income] - , _init_categories :: [Category] - , _init_paymentCategories :: [PaymentCategory] - } deriving (Show) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index bf0186f..f47b627 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -3,29 +3,29 @@ module View.Payment.Payment , In(..) ) where -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime) -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Frequency, Income (..), - Payment (..), PaymentCategory (..), - PaymentId, PaymentPage (..), - SavedPayment (..), User, UserId) -import qualified Common.Util.Text as T - -import qualified Component.Pages as Pages -import Loadable (Loadable (..)) +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Frequency, Income (..), + Payment (..), PaymentCategory (..), + PaymentId, PaymentPage (..), + SavedPayment (..), User, UserId) +import qualified Common.Util.Text as T + +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) import qualified Loadable -import qualified Util.Ajax as AjaxUtil -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Header as Header -import View.Payment.Init (Init (..)) -import qualified View.Payment.Reducer as Reducer -import qualified View.Payment.Table as Table +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.HeaderInfos as HeaderInfos +-- import qualified View.Payment.HeaderForm as HeaderForm +import qualified View.Payment.Reducer as Reducer +import qualified View.Payment.Table as Table data In t = In { _in_currentUser :: UserId @@ -61,7 +61,14 @@ view input = do deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) -> - flip Loadable.view is $ \(PaymentPage payments paymentCategories count) -> do + flip Loadable.view is $ \(PaymentPage header payments paymentCategories count) -> do + HeaderInfos.view $ HeaderInfos.In + { HeaderInfos._in_users = _in_users input + , HeaderInfos._in_currency = _in_currency input + , HeaderInfos._in_header = header + , HeaderInfos._in_paymentCount = count + } + table <- Table.view $ Table.In { Table._in_users = _in_users input , Table._in_currentUser = _in_currentUser input -- cgit v1.2.3 From c0ea63f8c1a8c7123b78798cec99726b113fb1f3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 17 Nov 2019 18:08:28 +0100 Subject: Optimize and refactor payments --- client/src/Loadable.hs | 3 +- client/src/Util/Ajax.hs | 5 +- client/src/Util/Either.hs | 2 +- client/src/Util/List.hs | 13 --- client/src/View/Payment/Form.hs | 52 +++++----- client/src/View/Payment/HeaderForm.hs | 69 +++++++------ client/src/View/Payment/HeaderInfos.hs | 28 +++--- client/src/View/Payment/Payment.hs | 177 +++++---------------------------- client/src/View/Payment/Reducer.hs | 83 +++++++++++++--- client/src/View/Payment/Table.hs | 31 ++---- 10 files changed, 183 insertions(+), 280 deletions(-) delete mode 100644 client/src/Util/List.hs (limited to 'client') diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs index f57b99c..2b9008a 100644 --- a/client/src/Loadable.hs +++ b/client/src/Loadable.hs @@ -16,6 +16,7 @@ data Loadable t = Loading | Error Text | Loaded t + deriving Show instance Functor Loadable where fmap f Loading = Loading @@ -46,6 +47,6 @@ fromEvent = Loading view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) -view _ (Loading) = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing +view _ Loading = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing view _ (Error e) = R.text e >> return Nothing view f (Loaded x) = Just <$> f x diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 47f4f3c..dc56701 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -16,6 +16,7 @@ import qualified Data.Map.Lazy as LM import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.Time.Clock (NominalDiffTime) import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, XhrRequest, XhrRequestConfig (..), XhrResponse, @@ -28,7 +29,9 @@ import qualified Loadable getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a)) getNow url = do postBuild <- R.getPostBuild - get (R.tag (R.constant url) postBuild) >>= Loadable.fromEvent + get (url <$ postBuild) + >>= R.debounce (0 :: NominalDiffTime) -- Fired 2 times otherwise + >>= Loadable.fromEvent get :: forall t m a. (MonadWidget t m, FromJSON a) diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs index 2910d95..e76bc8a 100644 --- a/client/src/Util/Either.hs +++ b/client/src/Util/Either.hs @@ -2,6 +2,6 @@ module Util.Either ( eitherToMaybe ) where -eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe :: forall a b. Either a b -> Maybe b eitherToMaybe (Right b) = Just b eitherToMaybe _ = Nothing diff --git a/client/src/Util/List.hs b/client/src/Util/List.hs deleted file mode 100644 index 4e22ba8..0000000 --- a/client/src/Util/List.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Util.List - ( groupBy - ) where - -import Control.Arrow ((&&&)) -import Data.Function (on) -import qualified Data.List as L - -groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])] -groupBy f = - map (f . head &&& id) - . L.groupBy ((==) `on` f) - . L.sortBy (compare `on` f) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 99b0848..6c3c1e8 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -4,6 +4,7 @@ module View.Payment.Form , Operation(..) ) where +import Control.Monad (join) import Control.Monad.IO.Class (liftIO) import Data.Aeson (Value) import qualified Data.Aeson as Aeson @@ -13,6 +14,7 @@ import qualified Data.Map as M import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T +import Data.Time (NominalDiffTime) import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Clock @@ -25,9 +27,7 @@ import qualified Text.Read as T import Common.Model (Category (..), CategoryId, CreatePaymentForm (..), EditPaymentForm (..), - Frequency (..), Payment (..), - PaymentCategory (..), - SavedPayment (..)) + Frequency (..), Payment (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil import qualified Common.Validation.Payment as PaymentValidation @@ -37,20 +37,20 @@ import qualified Component.Modal as Modal import qualified Component.ModalForm as ModalForm import qualified Component.Select as Select import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil import qualified Util.Validation as ValidationUtil -data In = In - { _in_categories :: [Category] - , _in_paymentCategories :: [PaymentCategory] - , _in_operation :: Operation +data In t = In + { _in_categories :: [Category] + , _in_operation :: Operation t } -data Operation - = New Frequency +data Operation t + = New (Dynamic t Frequency) | Clone Payment | Edit Payment -view :: forall t m a. MonadWidget t m => In -> Modal.Content t m SavedPayment +view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Payment view input cancel = do rec let reset = R.leftmost @@ -105,9 +105,10 @@ view input cancel = do (d <$ reset) confirm) - let setCategory = - R.fmapMaybe id . R.updated $ - R.ffor (Input._out_raw name) findCategory + setCategory <- + R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name) + >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>))) + >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe)) category <- Select._out_value <$> (Select.view $ Select.In { Select._in_label = Msg.get Msg.Payment_Category @@ -124,12 +125,13 @@ view input cancel = do c <- cost d <- date cat <- category + f <- frequency return (mkPayload <$> ValidationUtil.nelError n <*> V.Success c <*> V.Success d <*> ValidationUtil.nelError cat - <*> V.Success frequency) + <*> V.Success f) frequencies = M.fromList @@ -140,6 +142,12 @@ view input cancel = do categories = M.fromList . flip map (_in_categories input) $ \c -> (_category_id c, _category_name c) + category = + case op of + New _ -> -1 + Clone p -> _payment_category p + Edit p -> _payment_category p + op = _in_operation input name = @@ -162,17 +170,11 @@ view input cancel = do Clone p -> currentDay Edit p -> _payment_date p - category = - case op of - New _ -> -1 - Clone p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) - Edit p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) - frequency = case op of New f -> f - Clone p -> _payment_frequency p - Edit p -> _payment_frequency p + Clone p -> R.constDyn $ _payment_frequency p + Edit p -> R.constDyn $ _payment_frequency p headerLabel = case op of @@ -189,9 +191,3 @@ view input cancel = do case op of Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e _ -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e - - findCategory :: Text -> Maybe CategoryId - findCategory paymentName = - fmap _paymentCategory_category - . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) - $ (_in_paymentCategories input) diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs index 07a6b81..c8ca4d9 100644 --- a/client/src/View/Payment/HeaderForm.hs +++ b/client/src/View/Payment/HeaderForm.hs @@ -1,5 +1,7 @@ module View.Payment.HeaderForm ( view + , In(..) + , Out(..) ) where import qualified Data.Map as M @@ -8,10 +10,8 @@ import qualified Data.Validation as V import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Category, Currency, ExceedingPayer (..), - Frequency (..), Income (..), Payment (..), - PaymentCategory, SavedPayment (..), - User (..)) +import Common.Model (Category, Currency, Frequency (..), + Income (..), Payment (..), User (..)) import qualified Common.Msg as Msg import qualified Component.Button as Button @@ -21,39 +21,43 @@ import qualified Component.Select as Select import qualified View.Payment.Form as Form data In t = In - { _in_reset :: Event t () - , _in_categories :: [Category] - , _in_paymentCategories :: [PaymentCategory] + { _in_reset :: Event t () + , _in_categories :: [Category] } -data Out = Out - { _out_name :: Event t Text +data Out t = Out + { _out_search :: Event t Text , _out_frequency :: Event t Frequency - , _out_addPayment :: Event t SavedPayment + , _out_addPayment :: Event t Payment } view :: forall t m. MonadWidget t m => In t -> m (Out t) -view input = do - R.divClass "g-HeaderForm" $ do - searchName <- Input._out_raw <$> (Input.view - ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) - ("" <$ _in_reset input) - R.never) +view input = + R.divClass "g-PaymentHeaderForm" $ do - let frequencies = M.fromList - [ (Punctual, Msg.get Msg.Payment_PunctualMale) - , (Monthly, Msg.get Msg.Payment_MonthlyMale) - ] + (searchName, frequency) <- R.el "div" $ do - searchFrequency <- Select._out_raw <$> (Select.view $ Select.In - { Select._in_label = "" - , Select._in_initialValue = Punctual - , Select._in_value = R.never - , Select._in_values = R.constDyn frequencies - , Select._in_reset = R.never - , Select._in_isValid = V.Success - , Select._in_validate = R.never - }) + searchName <- Input._out_raw <$> (Input.view + ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) + ("" <$ _in_reset input) + R.never) + + let frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + frequency <- Select._out_raw <$> (Select.view $ Select.In + { Select._in_label = "" + , Select._in_initialValue = Punctual + , Select._in_value = R.never + , Select._in_values = R.constDyn frequencies + , Select._in_reset = R.never + , Select._in_isValid = V.Success + , Select._in_validate = R.never + }) + + return (searchName, frequency) addPaymentButton <- Button._out_clic <$> (Button.view $ @@ -66,13 +70,12 @@ view input = do , Modal._in_content = Form.view $ Form.In { Form._in_categories = _in_categories input - , Form._in_paymentCategories = _in_paymentCategories input - , Form._in_operation = Form.New searchFrequency + , Form._in_operation = Form.New frequency } } return $ Out - { _out_name = searchName - , _out_frequency = searchFrequency + { _out_search = R.updated searchName + , _out_frequency = R.updated frequency , _out_addPayment = addPayment } diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs index 12facc4..f84ee1f 100644 --- a/client/src/View/Payment/HeaderInfos.hs +++ b/client/src/View/Payment/HeaderInfos.hs @@ -16,13 +16,11 @@ import qualified Reflex.Dom as R import Common.Model (Currency, ExceedingPayer (..), Payment (..), PaymentHeader (..), - SavedPayment (..), User (..), UserId) + User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import qualified Util.List as L - data In t = In { _in_users :: [User] , _in_currency :: Currency @@ -32,17 +30,17 @@ data In t = In view :: forall t m. MonadWidget t m => In t -> m () view input = - R.divClass "g-HeaderInfos" $ do - exceedingPayers - (_in_users input) - (_in_currency input) - (_paymentHeader_exceedingPayers header) + R.divClass "g-PaymentHeaderInfos" $ do + exceedingPayers + (_in_users input) + (_in_currency input) + (_paymentHeader_exceedingPayers header) - infos - (_in_users input) - (_in_currency input) - (_paymentHeader_repartition header) - (_in_paymentCount input) + infos + (_in_users input) + (_in_currency input) + (_paymentHeader_repartition header) + (_in_paymentCount input) where header = _in_header input @@ -54,7 +52,7 @@ exceedingPayers -> [ExceedingPayer] -> m () exceedingPayers users currency payers = - R.divClass "g-HeaderInfos__ExceedingPayers" $ + R.divClass "g-PaymentHeaderInfos__ExceedingPayers" $ flip mapM_ payers $ \payer -> R.elClass "span" "exceedingPayer" $ do R.elClass "span" "userName" $ @@ -72,7 +70,7 @@ infos -> Int -> m () infos users currency repartition paymentCount = - R.divClass "g-HeaderInfos__Repartition" $ do + R.divClass "g-PaymentHeaderInfos__Repartition" $ do R.elClass "span" "total" $ do R.text $ diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index f47b627..6bc1614 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -3,6 +3,7 @@ module View.Payment.Payment , In(..) ) where +import Control.Monad.IO.Class (liftIO) import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T @@ -12,9 +13,8 @@ import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R import Common.Model (Currency, Frequency, Income (..), - Payment (..), PaymentCategory (..), - PaymentId, PaymentPage (..), - SavedPayment (..), User, UserId) + Payment (..), PaymentId, + PaymentPage (..), User, UserId) import qualified Common.Util.Text as T import qualified Component.Pages as Pages @@ -22,8 +22,8 @@ import Loadable (Loadable (..)) import qualified Loadable import qualified Util.Ajax as AjaxUtil import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.HeaderForm as HeaderForm import qualified View.Payment.HeaderInfos as HeaderInfos --- import qualified View.Payment.HeaderForm as HeaderForm import qualified View.Payment.Reducer as Reducer import qualified View.Payment.Table as Table @@ -36,15 +36,16 @@ data In t = In view :: forall t m. MonadWidget t m => In t -> m () view input = do - categoriesEvent <- (AjaxUtil.getNow "api/categories") + categories <- AjaxUtil.getNow "api/categories" - R.dyn . R.ffor categoriesEvent . Loadable.view $ \categories -> do + R.dyn . R.ffor categories . Loadable.view $ \categories -> do rec payments <- Reducer.reducer $ Reducer.In - { Reducer._in_newPage = newPage - , Reducer._in_currentPage = currentPage - , Reducer._in_addPayment = R.leftmost [headerAddPayment, tableAddPayment] + { Reducer._in_page = page + , Reducer._in_search = HeaderForm._out_search form + , Reducer._in_frequency = HeaderForm._out_frequency form + , Reducer._in_addPayment = addPayment , Reducer._in_editPayment = editPayment , Reducer._in_deletePayment = deletePayment } @@ -52,16 +53,25 @@ view input = do let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result - newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) - currentPage <- R.holdDyn 1 newPage - -- headerAddPayment <- eventFromResult $ Header._out_add . (\(a, _, _) -> a) - let headerAddPayment = R.never + let addPayment = + R.leftmost + [ tableAddPayment + , HeaderForm._out_addPayment form + ] + + page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) - result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) -> - flip Loadable.view is $ \(PaymentPage header payments paymentCategories count) -> do + form <- HeaderForm.view $ HeaderForm.In + { HeaderForm._in_reset = () <$ addPayment + , HeaderForm._in_categories = categories + } + + result <- R.dyn . R.ffor payments $ + Loadable.view $ \(PaymentPage page header payments count) -> do + HeaderInfos.view $ HeaderInfos.In { HeaderInfos._in_users = _in_users input , HeaderInfos._in_currency = _in_currency input @@ -75,13 +85,12 @@ view input = do , Table._in_categories = categories , Table._in_currency = _in_currency input , Table._in_payments = payments - , Table._in_paymentCategories = paymentCategories } pages <- Pages.view $ Pages.In { Pages._in_total = R.constDyn count , Pages._in_perPage = Reducer.perPage - , Pages._in_page = p + , Pages._in_page = page } return ((), table, pages) @@ -89,137 +98,3 @@ view input = do return () return () - - --- view :: forall t m. MonadWidget t m => In t -> m () --- view input = do --- R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> --- --- R.elClass "main" "payment" $ do --- rec --- let addPayment = R.leftmost --- -- [ Header._out_addPayment header --- [ Table2._out_addPayment table --- ] --- --- paymentsPerPage = 7 --- --- payments <- reducePayments --- (_init_payments init) --- (_savedPayment_payment <$> addPayment) --- (_savedPayment_payment <$> Table2._out_editPayment table) --- (Table2._out_deletePayment table) --- --- paymentCategories <- reducePaymentCategories --- (_init_paymentCategories init) --- payments --- (_savedPayment_paymentCategory <$> addPayment) --- (_savedPayment_paymentCategory <$> Table2._out_editPayment table) --- (Table2._out_deletePayment table) --- --- -- (searchNameEvent, searchName) <- --- -- debounceSearchName (Header._out_searchName header) --- --- -- let searchPayments = --- -- getSearchPayments searchName (Header._out_searchFrequency header) payments --- --- -- header <- Header.view $ Header.In --- -- { Header._in_init = init --- -- , Header._in_currency = _in_currency input --- -- , Header._in_payments = payments --- -- , Header._in_searchPayments = searchPayments --- -- , Header._in_paymentCategories = paymentCategories --- -- } --- --- table <- Table2.view $ Table2.In --- { Table2._in_init = init --- , Table2._in_currency = _in_currency input --- , Table2._in_currentUser = _in_currentUser input --- , Table2._in_currentPage = Pages2._out_currentPage pages --- , Table2._in_payments = payments --- , Table2._in_perPage = paymentsPerPage --- , Table2._in_paymentCategories = paymentCategories --- } --- --- pages <- Pages2.view $ Pages2.In --- { Pages2._in_total = length <$> payments --- , Pages2._in_perPage = paymentsPerPage --- , Pages2._in_reset = R.never --- -- [ () <$ searchNameEvent --- -- [ () <$ Header._out_addPayment header --- -- ] --- } --- --- pure () --- --- return () --- --- -- debounceSearchName --- -- :: forall t m. MonadWidget t m --- -- => Dynamic t Text --- -- -> m (Event t Text, Dynamic t Text) --- -- debounceSearchName searchName = do --- -- event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) --- -- dynamic <- R.holdDyn "" event --- -- return (event, dynamic) --- --- reducePayments --- :: forall t m. MonadWidget t m --- => [Payment] --- -> Event t Payment -- add payment --- -> Event t Payment -- edit payment --- -> Event t Payment -- delete payment --- -> m (Dynamic t [Payment]) --- reducePayments initPayments addPayment editPayment deletePayment = --- R.foldDyn id initPayments $ R.leftmost --- [ (:) <$> addPayment --- , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) --- , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) --- ] --- --- reducePaymentCategories --- :: forall t m. MonadWidget t m --- => [PaymentCategory] --- -> Dynamic t [Payment] -- payments --- -> Event t PaymentCategory -- add payment category --- -> Event t PaymentCategory -- edit payment category --- -> Event t Payment -- delete payment --- -> m (Dynamic t [PaymentCategory]) --- reducePaymentCategories --- initPaymentCategories --- payments --- addPaymentCategory --- editPaymentCategory --- deletePayment --- = --- R.foldDyn id initPaymentCategories $ R.leftmost --- [ (:) <$> addPaymentCategory --- , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) --- , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) --- ] --- where --- deletePaymentName = --- R.attachWithMaybe --- (\ps p -> --- if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then --- Nothing --- else --- Just (_payment_name p)) --- (R.current payments) --- deletePayment --- lowerName = T.toLower . _payment_name --- --- -- getSearchPayments --- -- :: forall t. Reflex t --- -- => Dynamic t Text --- -- -> Dynamic t Frequency --- -- -> Dynamic t [Payment] --- -- -> Dynamic t [Payment] --- -- getSearchPayments name frequency payments = do --- -- n <- name --- -- f <- frequency --- -- ps <- payments --- -- pure $ flip filter ps (\p -> --- -- ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) --- -- && (_payment_frequency p == f) --- -- )) diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs index 0c70f8a..0b6c041 100644 --- a/client/src/View/Payment/Reducer.hs +++ b/client/src/View/Payment/Reducer.hs @@ -2,14 +2,16 @@ module View.Payment.Reducer ( perPage , reducer , In(..) + , Params(..) ) where import Data.Text (Text) import qualified Data.Text as T +import Data.Time (NominalDiffTime) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (PaymentPage) +import Common.Model (Frequency (..), PaymentPage) import Loadable (Loadable (..)) import qualified Loadable as Loadable @@ -19,48 +21,99 @@ perPage :: Int perPage = 7 data In t a b c = In - { _in_newPage :: Event t Int - , _in_currentPage :: Dynamic t Int + { _in_page :: Event t Int + , _in_search :: Event t Text + , _in_frequency :: Event t Frequency , _in_addPayment :: Event t a , _in_editPayment :: Event t b , _in_deletePayment :: Event t c } data Action - = LoadPage Int + = LoadPage | GetResult (Either Text PaymentPage) +data Params = Params + { _params_page :: Int + , _params_search :: Text + , _params_frequency :: Frequency + } deriving (Show) + +initParams = Params 1 "" Punctual + +data Msg + = Page Int + | Search Text + | Frequency Common.Model.Frequency + | ResetSearch + deriving Show + reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage)) reducer input = do postBuild <- R.getPostBuild - let loadPage = + debouncedSearch <- R.debounce (1 :: NominalDiffTime) (_in_search input) + + params <- R.foldDynMaybe + (\msg params -> case msg of + Page page -> + Just $ params { _params_page = page } + + Search "" -> + if _params_search params == "" then + Nothing + + else + Just $ initParams { _params_frequency = _params_frequency params } + + Search search -> + Just $ params { _params_search = search, _params_page = _params_page initParams } + + Frequency frequency -> + Just $ params { _params_frequency = frequency } + + ResetSearch -> + Just $ initParams { _params_frequency = _params_frequency params } + ) + initParams + (R.leftmost + [ Page <$> _in_page input + , Search <$> debouncedSearch + , Frequency <$> _in_frequency input + , ResetSearch <$ _in_addPayment input + ]) + + let paramsEvent = R.leftmost - [ 1 <$ postBuild - , _in_newPage input - , 1 <$ _in_addPayment input - , R.tag (R.current $ _in_currentPage input) (_in_editPayment input) - , R.tag (R.current $ _in_currentPage input) (_in_deletePayment input) + [ initParams <$ postBuild + , R.updated params + , R.tag (R.current params) (_in_editPayment input) + , R.tag (R.current params) (_in_deletePayment input) ] - getResult <- AjaxUtil.get $ fmap pageUrl loadPage + getResult <- AjaxUtil.get (pageUrl <$> paramsEvent) + R.foldDyn (\action _ -> case action of - LoadPage _ -> Loading + LoadPage -> Loading GetResult (Left err) -> Error err GetResult (Right payments) -> Loaded payments ) Loading (R.leftmost - [ LoadPage <$> loadPage + [ LoadPage <$ paramsEvent , GetResult <$> getResult ]) where - pageUrl p = + pageUrl (Params page search frequency) = "api/payments?page=" - <> (T.pack . show $ p) + <> (T.pack . show $ page) <> "&perPage=" <> (T.pack . show $ perPage) + <> "&search=" + <> search + <> "&frequency=" + <> (T.pack $ show frequency) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index dde5168..59ac890 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -13,7 +13,6 @@ import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Category (..), Currency, Payment (..), - PaymentCategory (..), SavedPayment, User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg @@ -26,17 +25,16 @@ import qualified Util.Either as EitherUtil import qualified View.Payment.Form as Form data In t = In - { _in_users :: [User] - , _in_currentUser :: UserId - , _in_categories :: [Category] - , _in_currency :: Currency - , _in_payments :: [Payment] - , _in_paymentCategories :: [PaymentCategory] + { _in_users :: [User] + , _in_currentUser :: UserId + , _in_categories :: [Category] + , _in_currency :: Currency + , _in_payments :: [Payment] } data Out t = Out - { _out_add :: Event t SavedPayment - , _out_edit :: Event t SavedPayment + { _out_add :: Event t Payment + , _out_edit :: Event t Payment , _out_delete :: Event t Payment } @@ -50,18 +48,15 @@ view input = do cell (_in_users input) (_in_categories input) - (_in_paymentCategories input) (_in_currency input) , Table._in_cloneModal = \payment -> Form.view $ Form.In { Form._in_categories = _in_categories input - , Form._in_paymentCategories = _in_paymentCategories input , Form._in_operation = Form.Clone payment } , Table._in_editModal = \payment -> Form.view $ Form.In { Form._in_categories = _in_categories input - , Form._in_paymentCategories = _in_paymentCategories input , Form._in_operation = Form.Edit payment } , Table._in_deleteModal = \payment -> @@ -101,12 +96,11 @@ cell :: forall t m. MonadWidget t m => [User] -> [Category] - -> [PaymentCategory] -> Currency -> Header -> Payment -> m () -cell users categories paymentCategories currency header payment = +cell users categories currency header payment = case header of NameHeader -> R.text $ _payment_name payment @@ -120,7 +114,7 @@ cell users categories paymentCategories currency header payment = CategoryHeader -> let category = - findCategory categories paymentCategories (_payment_name payment) + L.find ((== (_payment_category payment)) . _category_id) categories attrs = case category of @@ -144,10 +138,3 @@ cell users categories paymentCategories currency header payment = R.elClass "span" "longDate" $ R.text . Format.longDay . _payment_date $ payment - -findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category -findCategory categories paymentCategories paymentName = do - paymentCategory <- L.find - ((== T.toLower paymentName) . _paymentCategory_name) - paymentCategories - L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories -- cgit v1.2.3 From 3c67fcf1d524811a18f0c4db3ef6eed1270b9a12 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 17 Nov 2019 19:55:22 +0100 Subject: Hide date from monthly payments --- client/src/View/Payment/Form.hs | 51 +++++++++++++++++++---------------- client/src/View/Payment/HeaderForm.hs | 20 ++++++++------ client/src/View/Payment/Payment.hs | 3 ++- client/src/View/Payment/Table.hs | 40 ++++++++++++++++----------- 4 files changed, 67 insertions(+), 47 deletions(-) (limited to 'client') diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 6c3c1e8..99dce13 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -43,10 +43,11 @@ import qualified Util.Validation as ValidationUtil data In t = In { _in_categories :: [Category] , _in_operation :: Operation t + , _in_frequency :: Frequency } data Operation t - = New (Dynamic t Frequency) + = New | Clone Payment | Edit Payment @@ -92,18 +93,23 @@ view input cancel = do (cost <$ reset) confirm) - d <- date - - date <- Input._out_raw <$> (Input.view - (Input.defaultIn - { Input._in_label = Msg.get Msg.Payment_Date - , Input._in_initialValue = d - , Input._in_inputType = "date" - , Input._in_hasResetButton = False - , Input._in_validation = PaymentValidation.date - }) - (d <$ reset) - confirm) + currentDate <- date + + date <- + case frequency of + Punctual -> do + Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Date + , Input._in_initialValue = currentDate + , Input._in_inputType = "date" + , Input._in_hasResetButton = False + , Input._in_validation = PaymentValidation.date + }) + (currentDate <$ reset) + confirm) + Monthly -> + return . R.constDyn $ currentDate setCategory <- R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name) @@ -125,13 +131,12 @@ view input cancel = do c <- cost d <- date cat <- category - f <- frequency return (mkPayload <$> ValidationUtil.nelError n <*> V.Success c <*> V.Success d <*> ValidationUtil.nelError cat - <*> V.Success f) + <*> V.Success frequency) frequencies = M.fromList @@ -144,7 +149,7 @@ view input cancel = do category = case op of - New _ -> -1 + New -> -1 Clone p -> _payment_category p Edit p -> _payment_category p @@ -152,13 +157,13 @@ view input cancel = do name = case op of - New _ -> "" + New -> "" Clone p -> _payment_name p Edit p -> _payment_name p cost = case op of - New _ -> "" + New -> "" Clone p -> T.pack . show . _payment_cost $ p Edit p -> T.pack . show . _payment_cost $ p @@ -166,19 +171,19 @@ view input cancel = do currentDay <- liftIO $ Clock.getCurrentTime >>= TimeUtil.timeToDay return . T.pack . Calendar.showGregorian $ case op of - New _ -> currentDay + New -> currentDay Clone p -> currentDay Edit p -> _payment_date p frequency = case op of - New f -> f - Clone p -> R.constDyn $ _payment_frequency p - Edit p -> R.constDyn $ _payment_frequency p + New -> _in_frequency input + Clone p -> _payment_frequency p + Edit p -> _payment_frequency p headerLabel = case op of - New _ -> Msg.get Msg.Payment_Add + New -> Msg.get Msg.Payment_Add Clone _ -> Msg.get Msg.Payment_CloneLong Edit _ -> Msg.get Msg.Payment_EditLong diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs index c8ca4d9..0ee0cd3 100644 --- a/client/src/View/Payment/HeaderForm.hs +++ b/client/src/View/Payment/HeaderForm.hs @@ -18,6 +18,7 @@ import qualified Component.Button as Button import qualified Component.Input as Input import qualified Component.Modal as Modal import qualified Component.Select as Select +import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form data In t = In @@ -65,14 +66,17 @@ view input = { Button._in_class = R.constDyn "addPayment" }) - addPayment <- Modal.view $ Modal.In - { Modal._in_show = addPaymentButton - , Modal._in_content = - Form.view $ Form.In - { Form._in_categories = _in_categories input - , Form._in_operation = Form.New frequency - } - } + addPayment <- + (R.dyn . R.ffor frequency $ \frequency -> + Modal.view $ Modal.In + { Modal._in_show = addPaymentButton + , Modal._in_content = + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_operation = Form.New + , Form._in_frequency = frequency + } + }) >>= ReflexUtil.flatten return $ Out { _out_search = R.updated searchName diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index 6bc1614..a34d2f4 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -70,7 +70,7 @@ view input = do } result <- R.dyn . R.ffor payments $ - Loadable.view $ \(PaymentPage page header payments count) -> do + Loadable.view $ \(PaymentPage page frequency header payments count) -> do HeaderInfos.view $ HeaderInfos.In { HeaderInfos._in_users = _in_users input @@ -85,6 +85,7 @@ view input = do , Table._in_categories = categories , Table._in_currency = _in_currency input , Table._in_payments = payments + , Table._in_frequency = frequency } pages <- Pages.view $ Pages.In diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 59ac890..f9215bc 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -12,7 +12,8 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Category (..), Currency, Payment (..), +import Common.Model (Category (..), Currency, + Frequency (..), Payment (..), User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg @@ -30,6 +31,7 @@ data In t = In , _in_categories :: [Category] , _in_currency :: Currency , _in_payments :: [Payment] + , _in_frequency :: Frequency } data Out t = Out @@ -42,22 +44,25 @@ view :: forall t m. MonadWidget t m => In t -> m (Out t) view input = do table <- Table.view $ Table.In - { Table._in_headerLabel = headerLabel + { Table._in_headerLabel = headerLabel (_in_frequency input) , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input , Table._in_cell = cell (_in_users input) (_in_categories input) + (_in_frequency input) (_in_currency input) , Table._in_cloneModal = \payment -> Form.view $ Form.In { Form._in_categories = _in_categories input , Form._in_operation = Form.Clone payment + , Form._in_frequency = _in_frequency input } , Table._in_editModal = \payment -> Form.view $ Form.In { Form._in_categories = _in_categories input , Form._in_operation = Form.Edit payment + , Form._in_frequency = _in_frequency input } , Table._in_deleteModal = \payment -> ConfirmDialog.view $ ConfirmDialog.In @@ -85,22 +90,24 @@ data Header | DateHeader deriving (Eq, Show, Bounded, Enum) -headerLabel :: Header -> Text -headerLabel NameHeader = Msg.get Msg.Payment_Name -headerLabel CostHeader = Msg.get Msg.Payment_Cost -headerLabel UserHeader = Msg.get Msg.Payment_User -headerLabel CategoryHeader = Msg.get Msg.Payment_Category -headerLabel DateHeader = Msg.get Msg.Payment_Date +headerLabel :: Frequency -> Header -> Text +headerLabel _ NameHeader = Msg.get Msg.Payment_Name +headerLabel _ CostHeader = Msg.get Msg.Payment_Cost +headerLabel _ UserHeader = Msg.get Msg.Payment_User +headerLabel _ CategoryHeader = Msg.get Msg.Payment_Category +headerLabel Punctual DateHeader = Msg.get Msg.Payment_Date +headerLabel Monthly DateHeader = "" cell :: forall t m. MonadWidget t m => [User] -> [Category] + -> Frequency -> Currency -> Header -> Payment -> m () -cell users categories currency header payment = +cell users categories frequency currency header payment = case header of NameHeader -> R.text $ _payment_name payment @@ -132,9 +139,12 @@ cell users categories currency header payment = Maybe.fromMaybe "" (_category_name <$> category) DateHeader -> - do - R.elClass "span" "shortDate" $ - R.text . Format.shortDay . _payment_date $ payment - - R.elClass "span" "longDate" $ - R.text . Format.longDay . _payment_date $ payment + if frequency == Punctual then + do + R.elClass "span" "shortDate" $ + R.text . Format.shortDay . _payment_date $ payment + + R.elClass "span" "longDate" $ + R.text . Format.longDay . _payment_date $ payment + else + R.blank -- cgit v1.2.3 From 54628c70cb33de5e4309c35b9f6b57bbe9f7a07b Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Nov 2019 16:19:53 +0100 Subject: Compute cumulative income with a DB query --- client/src/Loadable.hs | 37 +++++++++++++++++++++++++++++++++++ client/src/View/Income/Income.hs | 15 +++++++------- client/src/View/Income/Reducer.hs | 40 ++++++++++++++++++-------------------- client/src/View/Payment/Form.hs | 1 + client/src/View/Payment/Payment.hs | 18 ++++++++--------- client/src/View/Payment/Reducer.hs | 30 +++++++++++++--------------- 6 files changed, 86 insertions(+), 55 deletions(-) (limited to 'client') diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs index 2b9008a..9a14b3f 100644 --- a/client/src/Loadable.hs +++ b/client/src/Loadable.hs @@ -1,9 +1,12 @@ module Loadable ( Loadable (..) + , Loadable2 (..) , fromEvent , view + , view2 ) where +import qualified Data.Map as M import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R @@ -50,3 +53,37 @@ view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe view _ Loading = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing view _ (Error e) = R.text e >> return Nothing view f (Loaded x) = Just <$> f x + +data Loadable2 t a = Loadable2 + { _loadable_isLoading :: Dynamic t Bool + , _loadable_value :: Dynamic t (Maybe a) + } + +view2 :: forall t m a b. MonadWidget t m => Loadable2 t a -> (a -> m b) -> m (Event t (Maybe b)) +view2 (Loadable2 isLoading value) f = + withLoader isLoading $ + R.dyn . R.ffor value . viewMaybe $ f + + where + viewMaybe _ Nothing = return Nothing + viewMaybe f (Just x) = Just <$> f x + +withLoader + :: forall t m a. MonadWidget t m + => Dynamic t Bool + -> m a + -> m a +withLoader isLoading block = + R.divClass "g-Loadable" $ do + R.elDynAttr "div" (spinnerAttrs <$> isLoading) $ + R.divClass "spinner" R.blank + R.elDynAttr "div" (blockAttrs <$> isLoading) $ + block + where + spinnerAttrs l = M.singleton "class" $ + "g-Loadable__Spinner" + <> (if l then " g-Loadable__Spinner--Loading" else "") + + blockAttrs l = M.singleton "class" $ + "g-Loadable__Content" + <> (if l then " g-Loadable__Content--Loading" else "") diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index d82ab4d..fa2585d 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -19,6 +19,7 @@ import Loadable (Loadable (..)) import qualified Loadable import qualified Util.Ajax as AjaxUtil import qualified Util.Reflex as ReflexUtil +import qualified Util.Reflex as ReflexUtil import qualified View.Income.Header as Header import View.Income.Init (Init (..)) import qualified View.Income.Reducer as Reducer @@ -33,9 +34,8 @@ data In t = In view :: forall t m. MonadWidget t m => In t -> m () view input = do rec - incomes <- Reducer.reducer $ Reducer.In - { Reducer._in_newPage = newPage - , Reducer._in_currentPage = currentPage + incomePage <- Reducer.reducer $ Reducer.In + { Reducer._in_page = page , Reducer._in_addIncome = R.leftmost [headerAddIncome, tableAddIncome] , Reducer._in_editIncome = editIncome , Reducer._in_deleteIncome = deleteIncome @@ -44,15 +44,14 @@ view input = do let eventFromResult :: forall a. ((Header.Out t, Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result - newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) - currentPage <- R.holdDyn 1 newPage + page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) headerAddIncome <- eventFromResult $ Header._out_add . (\(a, _, _) -> a) tableAddIncome <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) editIncome <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) deleteIncome <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) - result <- R.dyn . R.ffor ((,) <$> incomes <*> currentPage) $ \(is, p) -> - flip Loadable.view is $ \(IncomePage header incomes count) -> do + result <- Loadable.view2 incomePage $ + \(IncomePage page header incomes count) -> do header <- Header.view $ Header.In { Header._in_users = _in_users input , Header._in_header = header @@ -69,7 +68,7 @@ view input = do pages <- Pages.view $ Pages.In { Pages._in_total = R.constDyn count , Pages._in_perPage = Reducer.perPage - , Pages._in_page = p + , Pages._in_page = page } return (header, table, pages) diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs index 092d9b3..391890f 100644 --- a/client/src/View/Income/Reducer.hs +++ b/client/src/View/Income/Reducer.hs @@ -11,53 +11,51 @@ import qualified Reflex.Dom as R import Common.Model (IncomePage) -import Loadable (Loadable (..)) -import qualified Loadable as Loadable +import Loadable (Loadable2 (..)) import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil perPage :: Int perPage = 7 data In t a b c = In - { _in_newPage :: Event t Int - , _in_currentPage :: Dynamic t Int + { _in_page :: Event t Int , _in_addIncome :: Event t a , _in_editIncome :: Event t b , _in_deleteIncome :: Event t c } -data Action - = LoadPage Int - | GetResult (Either Text IncomePage) - -reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomePage)) +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t IncomePage) reducer input = do postBuild <- R.getPostBuild + currentPage <- R.holdDyn 1 (_in_page input) + let loadPage = R.leftmost [ 1 <$ postBuild - , _in_newPage input + , _in_page input , 1 <$ _in_addIncome input - , R.tag (R.current $ _in_currentPage input) (_in_editIncome input) - , R.tag (R.current $ _in_currentPage input) (_in_deleteIncome input) + , R.tag (R.current currentPage) (_in_editIncome input) + , R.tag (R.current currentPage) (_in_deleteIncome input) ] getResult <- AjaxUtil.get $ fmap pageUrl loadPage - R.foldDyn - (\action _ -> case action of - LoadPage _ -> Loading - GetResult (Left err) -> Error err - GetResult (Right incomes) -> Loaded incomes - ) - Loading + isLoading <- R.holdDyn + True (R.leftmost - [ LoadPage <$> loadPage - , GetResult <$> getResult + [ True <$ loadPage + , False <$ getResult ]) + incomePage <- R.holdDyn + Nothing + (fmap EitherUtil.eitherToMaybe getResult) + + return $ Loadable2 isLoading incomePage + where pageUrl p = "api/incomes?page=" diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 99dce13..064b5b3 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -113,6 +113,7 @@ view input cancel = do setCategory <- R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name) + >>= (return . R.ffilter (\name -> T.length name >= 3)) >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>))) >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe)) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index a34d2f4..a97c3df 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -41,7 +41,7 @@ view input = do R.dyn . R.ffor categories . Loadable.view $ \categories -> do rec - payments <- Reducer.reducer $ Reducer.In + paymentPage <- Reducer.reducer $ Reducer.In { Reducer._in_page = page , Reducer._in_search = HeaderForm._out_search form , Reducer._in_frequency = HeaderForm._out_frequency form @@ -50,7 +50,7 @@ view input = do , Reducer._in_deletePayment = deletePayment } - let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + let eventFromResult :: forall a. ((Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result let addPayment = @@ -59,18 +59,18 @@ view input = do , HeaderForm._out_addPayment form ] - page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) - tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) - editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) - deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) + page <- eventFromResult $ Pages._out_newPage . snd + tableAddPayment <- eventFromResult $ Table._out_add . fst + editPayment <- eventFromResult $ Table._out_edit . fst + deletePayment <- eventFromResult $ Table._out_delete . fst form <- HeaderForm.view $ HeaderForm.In { HeaderForm._in_reset = () <$ addPayment , HeaderForm._in_categories = categories } - result <- R.dyn . R.ffor payments $ - Loadable.view $ \(PaymentPage page frequency header payments count) -> do + result <- Loadable.view2 paymentPage $ + \(PaymentPage page frequency header payments count) -> do HeaderInfos.view $ HeaderInfos.In { HeaderInfos._in_users = _in_users input @@ -94,7 +94,7 @@ view input = do , Pages._in_page = page } - return ((), table, pages) + return (table, pages) return () diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs index 0b6c041..d221ff0 100644 --- a/client/src/View/Payment/Reducer.hs +++ b/client/src/View/Payment/Reducer.hs @@ -13,9 +13,9 @@ import qualified Reflex.Dom as R import Common.Model (Frequency (..), PaymentPage) -import Loadable (Loadable (..)) -import qualified Loadable as Loadable +import Loadable (Loadable2 (..)) import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil perPage :: Int perPage = 7 @@ -29,10 +29,6 @@ data In t a b c = In , _in_deletePayment :: Event t c } -data Action - = LoadPage - | GetResult (Either Text PaymentPage) - data Params = Params { _params_page :: Int , _params_search :: Text @@ -48,7 +44,7 @@ data Msg | ResetSearch deriving Show -reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage)) +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t PaymentPage) reducer input = do postBuild <- R.getPostBuild @@ -94,19 +90,19 @@ reducer input = do getResult <- AjaxUtil.get (pageUrl <$> paramsEvent) - - R.foldDyn - (\action _ -> case action of - LoadPage -> Loading - GetResult (Left err) -> Error err - GetResult (Right payments) -> Loaded payments - ) - Loading + isLoading <- R.holdDyn + True (R.leftmost - [ LoadPage <$ paramsEvent - , GetResult <$> getResult + [ True <$ paramsEvent + , False <$ getResult ]) + paymentPage <- R.holdDyn + Nothing + (fmap EitherUtil.eitherToMaybe getResult) + + return $ Loadable2 isLoading paymentPage + where pageUrl (Params page search frequency) = "api/payments?page=" -- cgit v1.2.3 From e622e8fdd2e40b4306b5cc724d8dfb76bf976242 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 25 Nov 2019 08:17:59 +0100 Subject: Remove Loadable2 --- client/src/Loadable.hs | 62 +++++++++++++++++++++++++------------- client/src/View/Income/Income.hs | 2 +- client/src/View/Income/Reducer.hs | 19 +++++------- client/src/View/Payment/Payment.hs | 4 +-- client/src/View/Payment/Reducer.hs | 19 +++++------- 5 files changed, 58 insertions(+), 48 deletions(-) (limited to 'client') diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs index 9a14b3f..4806b08 100644 --- a/client/src/Loadable.hs +++ b/client/src/Loadable.hs @@ -1,9 +1,9 @@ module Loadable ( Loadable (..) - , Loadable2 (..) + , fromEither , fromEvent - , view - , view2 + , viewHideValueWhileLoading + , viewShowValueWhileLoading ) where import qualified Data.Map as M @@ -19,7 +19,7 @@ data Loadable t = Loading | Error Text | Loaded t - deriving Show + deriving (Eq, Show) instance Functor Loadable where fmap f Loading = Loading @@ -40,6 +40,10 @@ instance Monad Loadable where (Error e) >>= f = Error e (Loaded x) >>= f = f x +fromEither :: forall a b. Either Text b -> Loadable b +fromEither (Left err) = Error err +fromEither (Right value) = Loaded value + fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a)) fromEvent = R.foldDyn @@ -49,24 +53,38 @@ fromEvent = ) Loading -view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) -view _ Loading = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing -view _ (Error e) = R.text e >> return Nothing -view f (Loaded x) = Just <$> f x +viewHideValueWhileLoading :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) +viewHideValueWhileLoading f loadable = + case loadable of + Loading -> + (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing -data Loadable2 t a = Loadable2 - { _loadable_isLoading :: Dynamic t Bool - , _loadable_value :: Dynamic t (Maybe a) - } + Error err -> + R.text err >> return Nothing -view2 :: forall t m a b. MonadWidget t m => Loadable2 t a -> (a -> m b) -> m (Event t (Maybe b)) -view2 (Loadable2 isLoading value) f = - withLoader isLoading $ - R.dyn . R.ffor value . viewMaybe $ f + Loaded x -> + Just <$> f x - where - viewMaybe _ Nothing = return Nothing - viewMaybe f (Just x) = Just <$> f x +viewShowValueWhileLoading + :: forall t m a b. (MonadWidget t m, Eq a) + => Dynamic t (Loadable a) + -> (a -> m b) + -> m (Event t (Maybe b)) +viewShowValueWhileLoading loadable f = do + + value <- + (R.foldDyn + (\l v1 -> + case l of + Loaded v2 -> Just v2 + _ -> v1) + Nothing + (R.updated loadable)) >>= R.holdUniqDyn + + withLoader (fmap ((==) Loading) loadable) $ + R.dyn . R.ffor value $ \case + Nothing -> return Nothing + Just x -> Just <$> f x withLoader :: forall t m a. MonadWidget t m @@ -75,10 +93,12 @@ withLoader -> m a withLoader isLoading block = R.divClass "g-Loadable" $ do + res <- R.elDynAttr "div" (blockAttrs <$> isLoading) $ + block R.elDynAttr "div" (spinnerAttrs <$> isLoading) $ R.divClass "spinner" R.blank - R.elDynAttr "div" (blockAttrs <$> isLoading) $ - block + return res + where spinnerAttrs l = M.singleton "class" $ "g-Loadable__Spinner" diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index fa2585d..e83ba80 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -50,7 +50,7 @@ view input = do editIncome <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) deleteIncome <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) - result <- Loadable.view2 incomePage $ + result <- Loadable.viewShowValueWhileLoading incomePage $ \(IncomePage page header incomes count) -> do header <- Header.view $ Header.In { Header._in_users = _in_users input diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs index 391890f..ea9f664 100644 --- a/client/src/View/Income/Reducer.hs +++ b/client/src/View/Income/Reducer.hs @@ -11,7 +11,8 @@ import qualified Reflex.Dom as R import Common.Model (IncomePage) -import Loadable (Loadable2 (..)) +import Loadable (Loadable (..)) +import qualified Loadable as Loadable import qualified Util.Ajax as AjaxUtil import qualified Util.Either as EitherUtil @@ -25,7 +26,7 @@ data In t a b c = In , _in_deleteIncome :: Event t c } -reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t IncomePage) +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomePage)) reducer input = do postBuild <- R.getPostBuild @@ -43,19 +44,13 @@ reducer input = do getResult <- AjaxUtil.get $ fmap pageUrl loadPage - isLoading <- R.holdDyn - True + R.holdDyn + Loading (R.leftmost - [ True <$ loadPage - , False <$ getResult + [ Loading <$ loadPage + , Loadable.fromEither <$> getResult ]) - incomePage <- R.holdDyn - Nothing - (fmap EitherUtil.eitherToMaybe getResult) - - return $ Loadable2 isLoading incomePage - where pageUrl p = "api/incomes?page=" diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index a97c3df..8d0fee1 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -38,7 +38,7 @@ view input = do categories <- AjaxUtil.getNow "api/categories" - R.dyn . R.ffor categories . Loadable.view $ \categories -> do + R.dyn . R.ffor categories . Loadable.viewHideValueWhileLoading $ \categories -> do rec paymentPage <- Reducer.reducer $ Reducer.In @@ -69,7 +69,7 @@ view input = do , HeaderForm._in_categories = categories } - result <- Loadable.view2 paymentPage $ + result <- Loadable.viewShowValueWhileLoading paymentPage $ \(PaymentPage page frequency header payments count) -> do HeaderInfos.view $ HeaderInfos.In diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs index d221ff0..7468097 100644 --- a/client/src/View/Payment/Reducer.hs +++ b/client/src/View/Payment/Reducer.hs @@ -13,7 +13,8 @@ import qualified Reflex.Dom as R import Common.Model (Frequency (..), PaymentPage) -import Loadable (Loadable2 (..)) +import Loadable (Loadable (..)) +import qualified Loadable as Loadable import qualified Util.Ajax as AjaxUtil import qualified Util.Either as EitherUtil @@ -44,7 +45,7 @@ data Msg | ResetSearch deriving Show -reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t PaymentPage) +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage)) reducer input = do postBuild <- R.getPostBuild @@ -90,19 +91,13 @@ reducer input = do getResult <- AjaxUtil.get (pageUrl <$> paramsEvent) - isLoading <- R.holdDyn - True + R.holdDyn + Loading (R.leftmost - [ True <$ paramsEvent - , False <$ getResult + [ Loading <$ paramsEvent + , Loadable.fromEither <$> getResult ]) - paymentPage <- R.holdDyn - Nothing - (fmap EitherUtil.eitherToMaybe getResult) - - return $ Loadable2 isLoading paymentPage - where pageUrl (Params page search frequency) = "api/payments?page=" -- cgit v1.2.3 From 316bda10c6bec8b5ccc9e23f1f677c076205f046 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 8 Dec 2019 11:39:37 +0100 Subject: Add category page --- client/client.cabal | 5 ++ client/src/Component/ConfirmDialog.hs | 6 +- client/src/Component/Modal.hs | 8 +-- client/src/Component/ModalForm.hs | 10 +-- client/src/Component/Table.hs | 18 +++--- client/src/Component/Tag.hs | 27 ++++++++ client/src/Model/Route.hs | 1 + client/src/Util/Ajax.hs | 28 +++++++- client/src/View/App.hs | 43 ++++++++----- client/src/View/Category/Category.hs | 92 ++++++++++++++++++++++++++ client/src/View/Category/Form.hs | 117 ++++++++++++++++++++++++++++++++++ client/src/View/Category/Reducer.hs | 59 +++++++++++++++++ client/src/View/Category/Table.hs | 91 ++++++++++++++++++++++++++ client/src/View/Header.hs | 5 ++ client/src/View/Income/Form.hs | 2 +- client/src/View/Income/Header.hs | 3 +- client/src/View/Income/Income.hs | 1 - client/src/View/Income/Init.hs | 11 ---- client/src/View/Income/Table.hs | 11 ++-- client/src/View/Payment/Form.hs | 2 +- client/src/View/Payment/HeaderForm.hs | 2 +- client/src/View/Payment/Payment.hs | 2 +- client/src/View/Payment/Table.hs | 30 ++++----- client/src/View/SignIn.hs | 2 +- 24 files changed, 493 insertions(+), 83 deletions(-) create mode 100644 client/src/Component/Tag.hs create mode 100644 client/src/View/Category/Category.hs create mode 100644 client/src/View/Category/Form.hs create mode 100644 client/src/View/Category/Reducer.hs create mode 100644 client/src/View/Category/Table.hs delete mode 100644 client/src/View/Income/Init.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 78ea7d3..227aed2 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -56,6 +56,7 @@ Executable client Component.Pages Component.Select Component.Table + Component.Tag Loadable Model.Route Util.Ajax @@ -73,6 +74,10 @@ Executable client View.Income.Income View.Income.Reducer View.Income.Table + View.Category.Form + View.Category.Category + View.Category.Reducer + View.Category.Table View.NotFound View.Payment.Form View.Payment.HeaderForm diff --git a/client/src/Component/ConfirmDialog.hs b/client/src/Component/ConfirmDialog.hs index 50e30ed..cf26593 100644 --- a/client/src/Component/ConfirmDialog.hs +++ b/client/src/Component/ConfirmDialog.hs @@ -13,12 +13,12 @@ import qualified Component.Modal as Modal import qualified Util.Either as EitherUtil import qualified Util.WaitFor as WaitFor -data In t m a = In +data In t m = In { _in_header :: Text - , _in_confirm :: Event t () -> m (Event t a) + , _in_confirm :: Event t () -> m (Event t ()) } -view :: forall t m a. MonadWidget t m => (In t m a) -> Modal.Content t m a +view :: forall t m a. MonadWidget t m => (In t m) -> Modal.Content t m view input _ = R.divClass "confirm" $ do R.divClass "confirmHeader" $ diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index 08f2e74..46d3f64 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -20,14 +20,14 @@ import qualified Reflex.Dom.Class as R import qualified Util.Reflex as ReflexUtil -- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent) -type Content t m a = Event t () -> m (Event t (), Event t a) +type Content t m = Event t () -> m (Event t (), Event t ()) -data In t m a = In +data In t m = In { _in_show :: Event t () - , _in_content :: Content t m a + , _in_content :: Content t m } -view :: forall t m a. MonadWidget t m => In t m a -> m (Event t a) +view :: forall t m a. MonadWidget t m => In t m -> m (Event t ()) view input = do rec let show = Show <$ (_in_show input) diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs index f5bf287..c56ff88 100644 --- a/client/src/Component/ModalForm.hs +++ b/client/src/Component/ModalForm.hs @@ -20,20 +20,20 @@ import qualified Util.Either as EitherUtil import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor -data In m t a b e = In +data In m t a e = In { _in_headerLabel :: Text , _in_form :: m (Dynamic t (Validation e a)) - , _in_ajax :: Event t a -> m (Event t (Either Text b)) + , _in_ajax :: Event t a -> m (Event t (Either Text ())) } -data Out t a = Out +data Out t = Out { _out_hide :: Event t () , _out_cancel :: Event t () , _out_confirm :: Event t () - , _out_validate :: Event t a + , _out_validate :: Event t () } -view :: forall t m a b e. (MonadWidget t m, ToJSON a) => In m t a b e -> m (Out t b) +view :: forall t m a e. (MonadWidget t m, ToJSON a) => In m t a e -> m (Out t) view input = R.divClass "form" $ do R.divClass "formHeader" $ diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index 2869c2d..f82cfa6 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -14,23 +14,23 @@ import qualified Component.Modal as Modal import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon -data In m t h r a b c = In +data In m t h r = In { _in_headerLabel :: h -> Text , _in_rows :: [r] , _in_cell :: h -> r -> m () - , _in_cloneModal :: r -> Modal.Content t m a - , _in_editModal :: r -> Modal.Content t m b - , _in_deleteModal :: r -> Modal.Content t m c + , _in_cloneModal :: r -> Modal.Content t m + , _in_editModal :: r -> Modal.Content t m + , _in_deleteModal :: r -> Modal.Content t m , _in_isOwner :: r -> Bool } -data Out t a b c = Out - { _out_add :: Event t a - , _out_edit :: Event t b - , _out_delete :: Event t c +data Out t = Out + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () } -view :: forall t m h r a b c. (MonadWidget t m, Bounded h, Enum h) => In m t h r a b c-> m (Out t a b c) +view :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => In m t h r -> m (Out t) view input = R.divClass "table" $ do rec diff --git a/client/src/Component/Tag.hs b/client/src/Component/Tag.hs new file mode 100644 index 0000000..f75b8d3 --- /dev/null +++ b/client/src/Component/Tag.hs @@ -0,0 +1,27 @@ +module Component.Tag + ( In(..) + , view + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +data In = In + { _in_text :: Text + , _in_color :: Text + } + +view :: forall t m a. MonadWidget t m => In -> m () +view input = + R.elAttr "span" attrs $ + R.text $ _in_text input + + where + attrs = + M.fromList + [ ("class", "tag") + , ("style", T.concat [ "background-color: ", _in_color input ]) + ] diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs index 420fe05..63e5d10 100644 --- a/client/src/Model/Route.hs +++ b/client/src/Model/Route.hs @@ -5,5 +5,6 @@ module Model.Route data Route = RootRoute | IncomeRoute + | CategoryRoute | NotFoundRoute deriving (Eq, Show) diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index dc56701..dcfd402 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -2,7 +2,9 @@ module Util.Ajax ( getNow , get , post + , postAndParseResult , put + , putAndParseResult , delete ) where @@ -42,20 +44,38 @@ get url = R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String "")) post + :: forall t m a. (MonadWidget t m, ToJSON a) + => Text + -> Event t a + -> m (Event t (Either Text ())) +post url input = + fmap checkResult <$> + R.performRequestAsync (jsonRequest "POST" url <$> input) + +postAndParseResult :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) => Text -> Event t a -> m (Event t (Either Text b)) -post url input = +postAndParseResult url input = fmap getJsonResult <$> R.performRequestAsync (jsonRequest "POST" url <$> input) put + :: forall t m a. (MonadWidget t m, ToJSON a) + => Text + -> Event t a + -> m (Event t (Either Text ())) +put url input = + fmap checkResult <$> + R.performRequestAsync (jsonRequest "PUT" url <$> input) + +putAndParseResult :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) => Text -> Event t a -> m (Event t (Either Text b)) -put url input = +putAndParseResult url input = fmap getJsonResult <$> R.performRequestAsync (jsonRequest "PUT" url <$> input) @@ -69,6 +89,10 @@ delete url fire = do (R.performRequestAsync $ R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire) +checkResult :: XhrResponse -> Either Text () +checkResult response = + () <$ getResult response + getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a getJsonResult response = case getResult response of diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 2b346af..460d499 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -2,22 +2,23 @@ module View.App ( widget ) where -import qualified Data.Text as T -import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Init (..), InitResult (..), - UserId) -import qualified Common.Msg as Msg - -import Model.Route (Route (..)) -import qualified Util.Router as Router -import qualified View.Header as Header -import qualified View.Income.Income as Income -import qualified View.NotFound as NotFound -import qualified View.Payment.Payment as Payment -import qualified View.SignIn as SignIn +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Init (..), InitResult (..), + UserId) +import qualified Common.Msg as Msg + +import Model.Route (Route (..)) +import qualified Util.Router as Router +import qualified View.Category.Category as Category +import qualified View.Header as Header +import qualified View.Income.Income as Income +import qualified View.NotFound as NotFound +import qualified View.Payment.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = @@ -72,6 +73,13 @@ signedWidget init route = do , Income._in_users = _init_users init } + CategoryRoute -> + Category.view $ Category.In + { Category._in_currentUser = _init_currentUser init + , Category._in_currency = _init_currency init + , Category._in_users = _init_users init + } + NotFoundRoute -> NotFound.view @@ -87,5 +95,8 @@ getRoute = do ["income"] -> IncomeRoute + ["category"] -> + CategoryRoute + _ -> NotFoundRoute diff --git a/client/src/View/Category/Category.hs b/client/src/View/Category/Category.hs new file mode 100644 index 0000000..77a331a --- /dev/null +++ b/client/src/View/Category/Category.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ExplicitForAll #-} + +module View.Category.Category + ( view + , In(..) + ) where + +import Data.Aeson (FromJSON) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category, CategoryPage (..), Currency, + User, UserId) +import qualified Common.Msg as Msg + +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) +import qualified Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Category.Form as Form +import qualified View.Category.Reducer as Reducer +import qualified View.Category.Table as Table + +data In t = In + { _in_users :: [User] + , _in_currentUser :: UserId + , _in_currency :: Currency + } + +view :: forall t m. MonadWidget t m => In t -> m () +view input = do + rec + categoryPage <- Reducer.reducer $ Reducer.In + { Reducer._in_page = page + , Reducer._in_addCategory = R.leftmost [ headerAddCategory, tableAddCategory ] + , Reducer._in_editCategory = editCategory + , Reducer._in_deleteCategory = deleteCategory + } + + let eventFromResult :: forall a. ((Event t (), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten $ (Maybe.fromMaybe R.never . fmap op) <$> result + + page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) + headerAddCategory <- eventFromResult $ (\(a, _, _) -> a) + tableAddCategory <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) + editCategory <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) + deleteCategory <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) + + result <- Loadable.viewShowValueWhileLoading categoryPage $ + \(CategoryPage page categories count) -> do + header <- headerView + + table <- Table.view $ Table.In + { Table._in_currentUser = _in_currentUser input + , Table._in_currency = _in_currency input + , Table._in_categories = categories + , Table._in_users = _in_users input + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = page + } + + return (header, table, pages) + + return () + +headerView :: forall t m. MonadWidget t m => m (Event t ()) +headerView = + R.divClass "titleButton" $ do + R.el "h1" $ + R.text $ + Msg.get Msg.Category_Title + + addCategory <- Button._out_clic <$> + (Button.view . Button.defaultIn . R.text $ + Msg.get Msg.Category_Add) + + addCategory <- Modal.view $ Modal.In + { Modal._in_show = addCategory + , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New } + } + + return addCategory diff --git a/client/src/View/Category/Form.hs b/client/src/View/Category/Form.hs new file mode 100644 index 0000000..d91fc2e --- /dev/null +++ b/client/src/View/Category/Form.hs @@ -0,0 +1,117 @@ +module View.Category.Form + ( view + , In(..) + , Operation(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Time +import Data.Validation (Validation) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), + CreateCategoryForm (..), + EditCategoryForm (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Common.Validation.Category as CategoryValidation +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.ModalForm as ModalForm +import qualified Util.Ajax as Ajax + +data In = In + { _in_operation :: Operation + } + +data Operation + = New + | Clone Category + | Edit Category + +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m +view input cancel = do + + rec + let reset = R.leftmost + [ "" <$ ModalForm._out_cancel modalForm + , "" <$ ModalForm._out_validate modalForm + , "" <$ cancel + ] + + modalForm <- ModalForm.view $ ModalForm.In + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/category" + , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) + } + + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) + + where + + form + :: Event t String + -> Event t () + -> m (Dynamic t (Validation Text Value)) + form reset confirm = do + name <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Category_Name + , Input._in_initialValue = name + , Input._in_validation = CategoryValidation.name + }) + (name <$ reset) + confirm) + + color <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Category_Color + , Input._in_initialValue = color + , Input._in_inputType = "color" + , Input._in_hasResetButton = False + , Input._in_validation = CategoryValidation.color + }) + (color <$ reset) + confirm) + + return $ do + n <- name + c <- color + return . V.Success $ mkPayload n c + + op = _in_operation input + + name = + case op of + New -> "" + Clone c -> _category_name c + Edit c -> _category_name c + + color = + case op of + New -> "" + Clone c -> _category_color c + Edit c -> _category_color c + + ajax = + case op of + Edit _ -> Ajax.put + _ -> Ajax.post + + headerLabel = + case op of + Edit _ -> Msg.get Msg.Category_Edit + _ -> Msg.get Msg.Category_Add + + mkPayload = + case op of + Edit i -> \a b -> Aeson.toJSON $ EditCategoryForm (_category_id i) a b + _ -> \a b -> Aeson.toJSON $ CreateCategoryForm a b diff --git a/client/src/View/Category/Reducer.hs b/client/src/View/Category/Reducer.hs new file mode 100644 index 0000000..5ad0ddb --- /dev/null +++ b/client/src/View/Category/Reducer.hs @@ -0,0 +1,59 @@ +module View.Category.Reducer + ( perPage + , reducer + , In(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (CategoryPage) + +import Loadable (Loadable (..)) +import qualified Loadable as Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil + +perPage :: Int +perPage = 7 + +data In t a b c = In + { _in_page :: Event t Int + , _in_addCategory :: Event t a + , _in_editCategory :: Event t b + , _in_deleteCategory :: Event t c + } + +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable CategoryPage)) +reducer input = do + + postBuild <- R.getPostBuild + + currentPage <- R.holdDyn 1 (_in_page input) + + let loadPage = + R.leftmost + [ 1 <$ postBuild + , _in_page input + , 1 <$ _in_addCategory input + , R.tag (R.current currentPage) (_in_editCategory input) + , R.tag (R.current currentPage) (_in_deleteCategory input) + ] + + getResult <- AjaxUtil.get $ fmap pageUrl loadPage + + R.holdDyn + Loading + (R.leftmost + [ Loading <$ loadPage + , Loadable.fromEither <$> getResult + ]) + + where + pageUrl p = + "api/categories?page=" + <> (T.pack . show $ p) + <> "&perPage=" + <> (T.pack . show $ perPage) diff --git a/client/src/View/Category/Table.hs b/client/src/View/Category/Table.hs new file mode 100644 index 0000000..fbe76e9 --- /dev/null +++ b/client/src/View/Category/Table.hs @@ -0,0 +1,91 @@ +module View.Category.Table + ( view + , In(..) + , Out(..) + ) where + +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Currency, User (..), + UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Component.ConfirmDialog as ConfirmDialog +import qualified Component.Table as Table +import qualified Component.Tag as Tag +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Category.Form as Form + +data In t = In + { _in_currentUser :: UserId + , _in_currency :: Currency + , _in_categories :: [Category] + , _in_users :: [User] + } + +data Out t = Out + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do + + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = _in_categories input + , Table._in_cell = cell (_in_users input) (_in_currency input) + , Table._in_cloneModal = \category -> + Form.view $ Form.In + { Form._in_operation = Form.Clone category + } + , Table._in_editModal = \category -> + Form.view $ Form.In + { Form._in_operation = Form.Edit category + } + , Table._in_deleteModal = \category -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Category_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/category/", T.pack . show $ _category_id category]) + e + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_isOwner = const True + } + + return $ Out + { _out_add = Table._out_add table + , _out_edit = Table._out_edit table + , _out_delete = Table._out_delete table + } + +data Header + = NameHeader + | ColorHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel NameHeader = Msg.get Msg.Category_Name +headerLabel ColorHeader = Msg.get Msg.Category_Color + +cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Category -> m () +cell users currency header category = + case header of + NameHeader -> + R.text $ _category_name category + + ColorHeader -> + Tag.view $ Tag.In + { Tag._in_text = _category_name category + , Tag._in_color = _category_color category + } diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 3f58dd5..5910f52 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -63,6 +63,11 @@ links route = do (R.ffor route (attrs IncomeRoute)) (Msg.get Msg.Income_Title) + Link.view + "/category" + (R.ffor route (attrs CategoryRoute)) + (Msg.get Msg.Category_Title) + where attrs linkRoute currentRoute = M.singleton "class" $ diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index ff6e55e..59f6a0d 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -36,7 +36,7 @@ data Operation | Clone Income | Edit Income -view :: forall t m a. MonadWidget t m => In -> Modal.Content t m Income +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m view input cancel = do rec diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 9e1c5b6..a26e16a 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -21,7 +21,6 @@ import qualified Common.View.Format as Format import qualified Component.Button as Button import qualified Component.Modal as Modal import qualified View.Income.Form as Form -import View.Income.Init (Init (..)) data In t = In { _in_users :: [User] @@ -30,7 +29,7 @@ data In t = In } data Out t = Out - { _out_add :: Event t Income + { _out_add :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index e83ba80..7be8091 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -21,7 +21,6 @@ import qualified Util.Ajax as AjaxUtil import qualified Util.Reflex as ReflexUtil import qualified Util.Reflex as ReflexUtil import qualified View.Income.Header as Header -import View.Income.Init (Init (..)) import qualified View.Income.Reducer as Reducer import qualified View.Income.Table as Table diff --git a/client/src/View/Income/Init.hs b/client/src/View/Income/Init.hs deleted file mode 100644 index 4f3ef99..0000000 --- a/client/src/View/Income/Init.hs +++ /dev/null @@ -1,11 +0,0 @@ -module View.Income.Init - ( Init(..) - ) where - -import Common.Model (Income, Payment, User) - -data Init = Init - { _init_users :: [User] - , _init_incomes :: [Income] - , _init_payments :: [Payment] - } deriving (Show) diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index c623acb..c7f172b 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -4,7 +4,6 @@ module View.Income.Table , Out(..) ) where -import qualified Data.List as L import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T @@ -31,9 +30,9 @@ data In t = In } data Out t = Out - { _out_add :: Event t Income - , _out_edit :: Event t Income - , _out_delete :: Event t Income + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) @@ -41,7 +40,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel - , Table._in_rows = reverse . L.sortOn _income_date $ _in_incomes input + , Table._in_rows = _in_incomes input , Table._in_cell = cell (_in_users input) (_in_currency input) , Table._in_cloneModal = \income -> Form.view $ Form.In @@ -58,7 +57,7 @@ view input = do res <- Ajax.delete (R.constDyn $ T.concat ["/api/income/", T.pack . show $ _income_id income]) e - return $ income <$ R.fmapMaybe EitherUtil.eitherToMaybe res + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } , Table._in_isOwner = (== (_in_currentUser input)) . _income_userId } diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 064b5b3..6c31fad 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -51,7 +51,7 @@ data Operation t | Clone Payment | Edit Payment -view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Payment +view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m view input cancel = do rec let reset = R.leftmost diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs index 0ee0cd3..1915841 100644 --- a/client/src/View/Payment/HeaderForm.hs +++ b/client/src/View/Payment/HeaderForm.hs @@ -29,7 +29,7 @@ data In t = In data Out t = Out { _out_search :: Event t Text , _out_frequency :: Event t Frequency - , _out_addPayment :: Event t Payment + , _out_addPayment :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index 8d0fee1..26444d7 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -36,7 +36,7 @@ data In t = In view :: forall t m. MonadWidget t m => In t -> m () view input = do - categories <- AjaxUtil.getNow "api/categories" + categories <- AjaxUtil.getNow "api/allCategories" R.dyn . R.ffor categories . Loadable.viewHideValueWhileLoading $ \categories -> do diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index f9215bc..6744d3a 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -21,6 +21,7 @@ import qualified Common.View.Format as Format import qualified Component.ConfirmDialog as ConfirmDialog import qualified Component.Table as Table +import qualified Component.Tag as Tag import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil import qualified View.Payment.Form as Form @@ -35,9 +36,9 @@ data In t = In } data Out t = Out - { _out_add :: Event t Payment - , _out_edit :: Event t Payment - , _out_delete :: Event t Payment + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) @@ -45,7 +46,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel (_in_frequency input) - , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input + , Table._in_rows = _in_payments input , Table._in_cell = cell (_in_users input) @@ -71,7 +72,7 @@ view input = do res <- Ajax.delete (R.constDyn $ T.concat ["/api/payment/", T.pack . show $ _payment_id payment]) e - return $ payment <$ R.fmapMaybe EitherUtil.eitherToMaybe res + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user } @@ -122,21 +123,12 @@ cell users categories frequency currency header payment = let category = L.find ((== (_payment_category payment)) . _category_id) categories - - attrs = - case category of - Just c -> - M.fromList - [ ("class", "tag") - , ("style", T.concat [ "background-color: ", _category_color c ]) - ] - - Nothing -> - M.singleton "display" "none" in - R.elAttr "span" attrs $ - R.text $ - Maybe.fromMaybe "" (_category_name <$> category) + Maybe.fromMaybe R.blank . flip fmap category $ \c -> + Tag.view $ Tag.In + { Tag._in_text = _category_name c + , Tag._in_color = _category_color c + } DateHeader -> if frequency == Punctual then diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index a589fc3..0a3b576 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -50,7 +50,7 @@ view signInMessage = let form = SignInForm <$> Input._out_raw input (signInResult, waiting) <- WaitFor.waitFor - (Ajax.post "/api/askSignIn") + (Ajax.postAndParseResult "/api/askSignIn") (ValidationUtil.fireMaybe ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) -- cgit v1.2.3 From da2a0c13aa89705c65fdb9df2f496fb4eea29654 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 4 Jan 2020 19:22:45 +0100 Subject: Allow to remove only unused categories --- client/src/Component/Input.hs | 2 +- client/src/Component/Table.hs | 9 ++++----- client/src/View/Category/Category.hs | 34 ++++++++++++++++++---------------- client/src/View/Category/Table.hs | 16 +++++++++------- client/src/View/Income/Table.hs | 3 ++- client/src/View/Payment/Table.hs | 3 ++- 6 files changed, 36 insertions(+), 31 deletions(-) (limited to 'client') diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 37020da..bcff377 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -57,7 +57,7 @@ view input reset validate = do ] inputAttr = R.ffor value (\v -> - if T.null v && _in_inputType input /= "date" + if T.null v && _in_inputType input /= "date" && _in_inputType input /= "color" then M.empty else M.singleton "class" "filled") diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index f82cfa6..1482f91 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -21,7 +21,8 @@ data In m t h r = In , _in_cloneModal :: r -> Modal.Content t m , _in_editModal :: r -> Modal.Content t m , _in_deleteModal :: r -> Modal.Content t m - , _in_isOwner :: r -> Bool + , _in_canEdit :: r -> Bool + , _in_canDelete :: r -> Bool } data Out t = Out @@ -62,8 +63,6 @@ view input = , Modal._in_content = _in_cloneModal input row } - let isOwner = _in_isOwner input row - let visibleIf cond = R.elAttr "div" @@ -71,7 +70,7 @@ view input = editButton <- R.divClass "cell button" $ - visibleIf isOwner $ + visibleIf (_in_canEdit input row) $ Button._out_clic <$> (Button.view $ Button.defaultIn Icon.edit) @@ -83,7 +82,7 @@ view input = deleteButton <- R.divClass "cell button" $ - visibleIf isOwner $ + visibleIf (_in_canDelete input row) $ Button._out_clic <$> (Button.view $ Button.defaultIn Icon.delete) diff --git a/client/src/View/Category/Category.hs b/client/src/View/Category/Category.hs index 77a331a..5b41bb6 100644 --- a/client/src/View/Category/Category.hs +++ b/client/src/View/Category/Category.hs @@ -53,13 +53,14 @@ view input = do deleteCategory <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) result <- Loadable.viewShowValueWhileLoading categoryPage $ - \(CategoryPage page categories count) -> do + \(CategoryPage page categories usedCategories count) -> do header <- headerView table <- Table.view $ Table.In { Table._in_currentUser = _in_currentUser input , Table._in_currency = _in_currency input , Table._in_categories = categories + , Table._in_usedCategories = usedCategories , Table._in_users = _in_users input } @@ -75,18 +76,19 @@ view input = do headerView :: forall t m. MonadWidget t m => m (Event t ()) headerView = - R.divClass "titleButton" $ do - R.el "h1" $ - R.text $ - Msg.get Msg.Category_Title - - addCategory <- Button._out_clic <$> - (Button.view . Button.defaultIn . R.text $ - Msg.get Msg.Category_Add) - - addCategory <- Modal.view $ Modal.In - { Modal._in_show = addCategory - , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New } - } - - return addCategory + R.divClass "withMargin" $ + R.divClass "titleButton" $ do + R.el "h1" $ + R.text $ + Msg.get Msg.Category_Title + + addCategory <- Button._out_clic <$> + (Button.view . Button.defaultIn . R.text $ + Msg.get Msg.Category_Add) + + addCategory <- Modal.view $ Modal.In + { Modal._in_show = addCategory + , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New } + } + + return addCategory diff --git a/client/src/View/Category/Table.hs b/client/src/View/Category/Table.hs index fbe76e9..90d013d 100644 --- a/client/src/View/Category/Table.hs +++ b/client/src/View/Category/Table.hs @@ -10,8 +10,8 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Category (..), Currency, User (..), - UserId) +import Common.Model (Category (..), CategoryId, Currency, + User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -24,10 +24,11 @@ import qualified Util.Either as EitherUtil import qualified View.Category.Form as Form data In t = In - { _in_currentUser :: UserId - , _in_currency :: Currency - , _in_categories :: [Category] - , _in_users :: [User] + { _in_currentUser :: UserId + , _in_currency :: Currency + , _in_categories :: [Category] + , _in_usedCategories :: [CategoryId] + , _in_users :: [User] } data Out t = Out @@ -60,7 +61,8 @@ view input = do e return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } - , Table._in_isOwner = const True + , Table._in_canEdit = const True + , Table._in_canDelete = not . flip elem (_in_usedCategories input) . _category_id } return $ Out diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index c7f172b..7b7940d 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -59,7 +59,8 @@ view input = do e return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } - , Table._in_isOwner = (== (_in_currentUser input)) . _income_userId + , Table._in_canEdit = (== (_in_currentUser input)) . _income_userId + , Table._in_canDelete = (== (_in_currentUser input)) . _income_userId } return $ Out diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 6744d3a..bfa0fb9 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -74,7 +74,8 @@ view input = do e return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } - , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user + , Table._in_canEdit = (== (_in_currentUser input)) . _payment_user + , Table._in_canDelete = (== (_in_currentUser input)) . _payment_user } return $ Out -- cgit v1.2.3 From cdb0ae1aeb22d7d7c36acb9d580f3723aa469829 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 4 Jan 2020 19:26:08 +0100 Subject: Go to page 1 when switching the search frequency --- client/src/View/Payment/Reducer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'client') diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs index 7468097..3fe59b2 100644 --- a/client/src/View/Payment/Reducer.hs +++ b/client/src/View/Payment/Reducer.hs @@ -68,7 +68,7 @@ reducer input = do Just $ params { _params_search = search, _params_page = _params_page initParams } Frequency frequency -> - Just $ params { _params_frequency = frequency } + Just $ params { _params_frequency = frequency, _params_page = _params_page initParams } ResetSearch -> Just $ initParams { _params_frequency = _params_frequency params } -- cgit v1.2.3 From af8353c6164aaaaa836bfed181f883ac86bb76a5 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Jan 2020 14:03:31 +0100 Subject: Sign in with email and password --- client/src/Component/Button.hs | 2 +- client/src/Main.hs | 10 +++--- client/src/Util/Validation.hs | 11 ------- client/src/View/App.hs | 61 +++++++++++++++++------------------- client/src/View/Header.hs | 52 +++++++++++++++---------------- client/src/View/SignIn.hs | 71 ++++++++++++++++++++++++------------------ 6 files changed, 100 insertions(+), 107 deletions(-) (limited to 'client') diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 6faecef..153a61b 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -22,7 +22,7 @@ data In t m = In , _in_submit :: Bool } -defaultIn :: MonadWidget t m => m () -> In t m +defaultIn :: forall t m. MonadWidget t m => m () -> In t m defaultIn content = In { _in_class = R.constDyn "" , _in_content = content diff --git a/client/src/Main.hs b/client/src/Main.hs index d6f89cd..c71b0f0 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -14,7 +14,7 @@ import JSDOM.Types (HTMLElement (..), JSM, import qualified JSDOM.Types as Dom import Prelude hiding (error, init) -import Common.Model (InitResult (InitError)) +import Common.Model (Init) import qualified Common.Msg as Msg import qualified View.App as App @@ -24,7 +24,7 @@ main = do initResult <- readInit App.widget initResult -readInit :: JSM InitResult +readInit :: JSM (Maybe Init) readInit = do document <- Dom.currentDocumentUnchecked initNode <- Dom.getElementById document ("init" :: JSString) @@ -34,8 +34,6 @@ readInit = do text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node) return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of Just init -> init - Nothing -> initParseError + Nothing -> Nothing _ -> - return initParseError - - where initParseError = InitError $ Msg.get Msg.SignIn_ParseError + return Nothing diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs index f9545a4..50f2468 100644 --- a/client/src/Util/Validation.hs +++ b/client/src/Util/Validation.hs @@ -3,7 +3,6 @@ module Util.Validation , toMaybe , maybeError , fireValidation - , fireMaybe ) where import Control.Monad (join) @@ -35,13 +34,3 @@ fireValidation value validate = R.fmapMaybe (Validation.validation (const Nothing) Just) (R.tag (R.current value) validate) - -fireMaybe - :: forall t a b. Reflex t - => Dynamic t (Maybe a) - -> Event t b - -> Event t a -fireMaybe value validate = - R.fmapMaybe - id - (R.tag (R.current value) validate) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 460d499..b0b89fb 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -4,14 +4,14 @@ module View.App import qualified Data.Text as T import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Currency, Init (..), InitResult (..), - UserId) +import Common.Model (Currency, Init (..), UserId) import qualified Common.Msg as Msg import Model.Route (Route (..)) +import qualified Util.Reflex as ReflexUtil import qualified Util.Router as Router import qualified View.Category.Category as Category import qualified View.Header as Header @@ -20,43 +20,40 @@ import qualified View.NotFound as NotFound import qualified View.Payment.Payment as Payment import qualified View.SignIn as SignIn -widget :: InitResult -> IO () -widget initResult = +widget :: Maybe Init -> IO () +widget init = R.mainWidget $ R.divClass "app" $ do route <- getRoute - header <- Header.view $ Header.In - { Header._in_initResult = initResult - , Header._in_isInitSuccess = - case initResult of - InitSuccess _ -> True - _ -> False - , Header._in_route = route - } - - let signOut = - Header._out_signOut header - - mainContent = - case initResult of - InitSuccess init -> - signedWidget init route - - InitEmpty -> - SignIn.view SignIn.EmptyMessage + rec + header <- Header.view $ Header.In + { Header._in_init = initState + , Header._in_route = route + } - InitError error -> - SignIn.view (SignIn.ErrorMessage error) + initState <- + R.foldDyn + const + init + (R.leftmost $ + [ initEvent + , Nothing <$ (Header._out_signOut header) + ]) - signOutContent = - SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess) + initEvent <- + (R.dyn . R.ffor initState $ \case + Nothing -> do + signIn <- SignIn.view + return (Just <$> SignIn._out_success signIn) - _ <- R.widgetHold (mainContent) (signOutContent <$ signOut) + Just i -> do + signedWidget i route + return R.never) >>= ReflexUtil.flatten - R.blank + return () -signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () +signedWidget :: forall t m. MonadWidget t m => Init -> Dynamic t Route -> m () signedWidget init route = do R.dyn . R.ffor route $ \case RootRoute -> @@ -85,7 +82,7 @@ signedWidget init route = do return () -getRoute :: MonadWidget t m => m (Dynamic t Route) +getRoute :: forall t m. MonadWidget t m => m (Dynamic t Route) getRoute = do r <- Router.partialPathRoute "" . R.switchPromptlyDyn =<< R.holdDyn R.never R.never return . R.ffor r $ \case diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 5910f52..f91c408 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -6,6 +6,7 @@ module View.Header import Data.Map (Map) import qualified Data.Map as M +import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Time (NominalDiffTime) @@ -13,7 +14,7 @@ import Prelude hiding (error, init) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init (..), InitResult (..), User (..)) +import Common.Model (Init (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Component.Button as Button @@ -24,9 +25,8 @@ import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon data In t = In - { _in_initResult :: InitResult - , _in_isInitSuccess :: Bool - , _in_route :: Dynamic t Route + { _in_init :: Dynamic t (Maybe Init) + , _in_route :: Dynamic t Route } data Out t = Out @@ -40,12 +40,11 @@ view input = R.divClass "title" $ R.text $ Msg.get Msg.App_Title + let showLinks = Maybe.isJust <$> _in_init input + signOut <- R.el "div" $ do - rec - showLinks <- R.foldDyn const (_in_isInitSuccess input) (False <$ signOut) - ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input) - signOut <- nameSignOut $ _in_initResult input - return signOut + ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input) + (R.dyn $ nameSignOut <$> _in_init input) >>= ReflexUtil.flatten return $ Out { _out_signOut = signOut @@ -76,23 +75,24 @@ links route = do , ("current", linkRoute == currentRoute) ] -nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) -nameSignOut initResult = case initResult of - InitSuccess init -> do - rec - attr <- R.holdDyn - (M.singleton "class" "nameSignOut") - (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) - - signOut <- R.elDynAttr "nameSignOut" attr $ do - case CM.findUser (_init_currentUser init) (_init_users init) of - Just user -> R.divClass "name" $ R.text (_user_name user) - Nothing -> R.blank - signOutButton - - return signOut - _ -> - return R.never +nameSignOut :: forall t m. MonadWidget t m => Maybe Init -> m (Event t ()) +nameSignOut init = + case init of + Just init -> do + rec + attr <- R.holdDyn + (M.singleton "class" "nameSignOut") + (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) + + signOut <- R.elDynAttr "nameSignOut" attr $ do + case CM.findUser (_init_currentUser init) (_init_users init) of + Just user -> R.divClass "name" $ R.text (_user_name user) + Nothing -> R.blank + signOutButton + + return signOut + _ -> + return R.never signOutButton :: forall t m. MonadWidget t m => m (Event t ()) signOutButton = do diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 0a3b576..e68755f 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,17 +1,16 @@ module View.SignIn - ( SignInMessage (..) - , view + ( view + , Out(..) ) where import qualified Data.Either as Either import qualified Data.Maybe as Maybe import Data.Text (Text) -import Data.Validation (Validation) -import Prelude hiding (error) +import qualified Data.Validation as V import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (SignInForm (SignInForm)) +import Common.Model (Init, SignInForm (SignInForm)) import qualified Common.Msg as Msg import qualified Common.Validation.SignIn as SignInValidation @@ -22,22 +21,32 @@ import qualified Util.Ajax as Ajax import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor -data SignInMessage = - SuccessMessage Text - | ErrorMessage Text - | EmptyMessage +data Out t = Out + { _out_success :: Event t Init + } -view :: forall t m. MonadWidget t m => SignInMessage -> m () -view signInMessage = - R.divClass "signIn" $ +view :: forall t m. MonadWidget t m => m (Out t) +view = do + signInResult <- R.divClass "signIn" $ Form.view $ do rec - input <- (Input.view + let resetForm = ("" <$ R.ffilter Either.isRight signInResult) + + email <- Input._out_raw <$> (Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.SignIn_EmailLabel , Input._in_validation = SignInValidation.email }) - ("" <$ R.ffilter Either.isRight signInResult) + resetForm + validate) + + password <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.SignIn_PasswordLabel + , Input._in_validation = SignInValidation.password + , Input._in_inputType = "password" + }) + resetForm validate) validate <- Button._out_clic <$> (Button.view $ @@ -47,27 +56,27 @@ view signInMessage = , Button._in_submit = True }) - let form = SignInForm <$> Input._out_raw input + let form = do + e <- email + p <- password + return . V.Success $ SignInForm e p (signInResult, waiting) <- WaitFor.waitFor - (Ajax.postAndParseResult "/api/askSignIn") - (ValidationUtil.fireMaybe - ((\f -> f <$ SignInValidation.signIn f) <$> form) - validate) + (Ajax.postAndParseResult "/api/signIn") + (ValidationUtil.fireValidation form validate) - showSignInResult signInMessage signInResult + showSignInResult signInResult -showSignInResult :: forall t m. MonadWidget t m => SignInMessage -> Event t (Either Text Text) -> m () -showSignInResult signInMessage signInResult = do - _ <- R.widgetHold (showInitResult signInMessage) $ R.ffor signInResult showResult - R.blank + return signInResult - where showInitResult (SuccessMessage success) = showSuccess success - showInitResult (ErrorMessage error) = showError error - showInitResult EmptyMessage = R.blank + return $ Out + { _out_success = R.filterRight signInResult + } - showResult (Left error) = showError error - showResult (Right success) = showSuccess success +showSignInResult :: forall t m. MonadWidget t m => Event t (Either Text Init) -> m () +showSignInResult signInResult = do + _ <- R.widgetHold R.blank $ showResult <$> signInResult + R.blank - showError = R.divClass "error" . R.text - showSuccess = R.divClass "success" . R.text + where showResult (Left error) = R.divClass "error" . R.text $ error + showResult (Right _) = R.blank -- cgit v1.2.3 From 47c2a4d6b68c54eed5f7b45671b1ccaf8c0db200 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 20 Jan 2020 19:47:23 +0100 Subject: Show payment stats --- client/client.cabal | 2 + client/src/Model/Route.hs | 1 + client/src/View/App.hs | 43 +++++++------ client/src/View/Header.hs | 5 ++ client/src/View/Statistics/Chart.hs | 102 +++++++++++++++++++++++++++++++ client/src/View/Statistics/Statistics.hs | 67 ++++++++++++++++++++ 6 files changed, 203 insertions(+), 17 deletions(-) create mode 100644 client/src/View/Statistics/Chart.hs create mode 100644 client/src/View/Statistics/Statistics.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 227aed2..cf2c5a1 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -86,3 +86,5 @@ Executable client View.Payment.Reducer View.Payment.Table View.SignIn + View.Statistics.Chart + View.Statistics.Statistics diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs index 63e5d10..f92e9be 100644 --- a/client/src/Model/Route.hs +++ b/client/src/Model/Route.hs @@ -6,5 +6,6 @@ data Route = RootRoute | IncomeRoute | CategoryRoute + | StatisticsRoute | NotFoundRoute deriving (Eq, Show) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index b0b89fb..71f0234 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -2,23 +2,24 @@ module View.App ( widget ) where -import qualified Data.Text as T -import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Init (..), UserId) -import qualified Common.Msg as Msg - -import Model.Route (Route (..)) -import qualified Util.Reflex as ReflexUtil -import qualified Util.Router as Router -import qualified View.Category.Category as Category -import qualified View.Header as Header -import qualified View.Income.Income as Income -import qualified View.NotFound as NotFound -import qualified View.Payment.Payment as Payment -import qualified View.SignIn as SignIn +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Init (..), UserId) +import qualified Common.Msg as Msg + +import Model.Route (Route (..)) +import qualified Util.Reflex as ReflexUtil +import qualified Util.Router as Router +import qualified View.Category.Category as Category +import qualified View.Header as Header +import qualified View.Income.Income as Income +import qualified View.NotFound as NotFound +import qualified View.Payment.Payment as Payment +import qualified View.SignIn as SignIn +import qualified View.Statistics.Statistics as Statistics widget :: Maybe Init -> IO () widget init = @@ -77,6 +78,11 @@ signedWidget init route = do , Category._in_users = _init_users init } + StatisticsRoute -> + Statistics.view $ Statistics.In + { Statistics._in_currency = _init_currency init + } + NotFoundRoute -> NotFound.view @@ -95,5 +101,8 @@ getRoute = do ["category"] -> CategoryRoute + ["statistics"] -> + StatisticsRoute + _ -> NotFoundRoute diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index f91c408..ff9f40a 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -67,6 +67,11 @@ links route = do (R.ffor route (attrs CategoryRoute)) (Msg.get Msg.Category_Title) + Link.view + "/statistics" + (R.ffor route (attrs StatisticsRoute)) + (Msg.get Msg.Statistics_Title) + where attrs linkRoute currentRoute = M.singleton "class" $ diff --git a/client/src/View/Statistics/Chart.hs b/client/src/View/Statistics/Chart.hs new file mode 100644 index 0000000..63df2a1 --- /dev/null +++ b/client/src/View/Statistics/Chart.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE JavaScriptFFI #-} + +module View.Statistics.Chart + ( view + , In(..) + , Dataset(..) + ) where + +import qualified Control.Concurrent as Concurrent +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson ((.=)) +import qualified Data.Aeson as AE +import qualified Data.Map as M +import Data.Text (Text) +import Language.Javascript.JSaddle (JSString, JSVal) +import qualified Language.Javascript.JSaddle.Value as JSValue +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R +-- import GHCJS.Foreign.Callback + + +#ifdef __GHCJS__ +foreign import javascript unsafe "new Chart(document.getElementById($1), $2);" drawChart :: JSString -> JSVal -> IO () +#else +drawChart = error "drawChart: only available from JavaScript" +#endif + +data In = In + { _in_title :: Text + , _in_labels :: [Text] + , _in_datasets :: [Dataset] + } + +data Dataset = Dataset + { _dataset_label :: Text + , _dataset_data :: [Int] + , _dataset_color :: Text + } + +view :: forall t m. MonadWidget t m => In -> m () +view input = do + R.divClass "g-Chart" $ + R.elAttr "canvas" (M.singleton "id" "chart") $ + R.blank + + liftIO $ Concurrent.forkIO $ do + Concurrent.threadDelay 500000 + config <- JSValue.valMakeJSON (configToJson input) + drawChart "chart" config + + return () + +configToJson (In title labels datasets) = + AE.object + [ "type" .= AE.String "line" + , "data" .= + AE.object + [ "labels" .= labels + , "datasets" .= map datasetToJson datasets + ] + , "options" .= + AE.object + [ "responsive" .= True + , "title" .= + AE.object + [ "display" .= True + , "text" .= title + ] + , "tooltips" .= + AE.object + [ "mode" .= AE.String "nearest" + , "intersect" .= False + ] + , "hover" .= + AE.object + [ "mode" .= AE.String "nearest" + , "intersect" .= True + ] + , "scales" .= + AE.object + [ "yAxes" .= + [ [ AE.object + [ "ticks" .= + AE.object + [ "beginAtZero" .= True ] + ] + ] + ] + ] + ] + ] + +datasetToJson (Dataset label data_ color) = + AE.object + [ "label" .= label + , "data" .= data_ + , "fill" .= False + , "backgroundColor" .= color + , "borderColor" .= color + ] diff --git a/client/src/View/Statistics/Statistics.hs b/client/src/View/Statistics/Statistics.hs new file mode 100644 index 0000000..71f93d4 --- /dev/null +++ b/client/src/View/Statistics/Statistics.hs @@ -0,0 +1,67 @@ +module View.Statistics.Statistics + ( view + , In(..) + ) where + +import Control.Monad (void) +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import Loadable (Loadable) +import qualified Loadable +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R +import qualified Util.Ajax as AjaxUtil +import qualified View.Statistics.Chart as Chart + +import Common.Model (Category (..), Currency, PaymentStats) +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +data In = In + { _in_currency :: Currency + } + +view :: forall t m. MonadWidget t m => In -> m () +view input = do + + categories <- AjaxUtil.getNow "api/allCategories" + statistics <- AjaxUtil.getNow "api/statistics" + let categoriesAndStatistics = (\c s -> (,) <$> c <*> s) <$> categories <*> statistics + + R.divClass "withMargin" $ + R.divClass "titleButton" $ + R.el "h1" $ + R.text $ Msg.get Msg.Statistics_Title + + void . R.dyn . R.ffor categoriesAndStatistics . Loadable.viewHideValueWhileLoading $ + stats (_in_currency input) + +stats :: forall t m. MonadWidget t m => Currency -> ([Category], PaymentStats) -> m () +stats currency (categories, stats) = + Chart.view $ Chart.In + { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averageEachMonth) + , Chart._in_labels = map (Format.monthAndYear . fst) stats + , Chart._in_datasets = + Chart.Dataset + { Chart._dataset_label = Msg.get Msg.Statistics_Total + , Chart._dataset_data = totalSeries + , Chart._dataset_color = "#555555" + } : (map categoryDataset categories) + } + + where + averageEachMonth = + Format.price currency $ sum totalSeries `div` length stats + + totalSeries = + map (sum . map snd . M.toList . snd) stats + + categoryDataset category = + Chart.Dataset + { Chart._dataset_label = _category_name category + , Chart._dataset_data = map (M.findWithDefault 0 (_category_id category) . snd) stats + , Chart._dataset_color = _category_color category + } -- cgit v1.2.3 From 79e1d8b0099d61b580a499311f1714b1b7eb07b5 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 27 Jan 2020 22:07:18 +0100 Subject: Show total incom by month in statistics --- client/src/View/Statistics/Statistics.hs | 54 +++++++++++++++++++++----------- 1 file changed, 36 insertions(+), 18 deletions(-) (limited to 'client') diff --git a/client/src/View/Statistics/Statistics.hs b/client/src/View/Statistics/Statistics.hs index 71f93d4..d931b2b 100644 --- a/client/src/View/Statistics/Statistics.hs +++ b/client/src/View/Statistics/Statistics.hs @@ -16,7 +16,8 @@ import qualified Reflex.Dom as R import qualified Util.Ajax as AjaxUtil import qualified View.Statistics.Chart as Chart -import Common.Model (Category (..), Currency, PaymentStats) +import Common.Model (Category (..), Currency, Income, + MonthStats (..), Stats, User (..)) import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -27,41 +28,58 @@ data In = In view :: forall t m. MonadWidget t m => In -> m () view input = do + users <- AjaxUtil.getNow "api/users" categories <- AjaxUtil.getNow "api/allCategories" statistics <- AjaxUtil.getNow "api/statistics" - let categoriesAndStatistics = (\c s -> (,) <$> c <*> s) <$> categories <*> statistics + + let loadable = (\u c s -> (,,) <$> u <*> c <*> s) <$> users <*> categories <*> statistics R.divClass "withMargin" $ R.divClass "titleButton" $ R.el "h1" $ R.text $ Msg.get Msg.Statistics_Title - void . R.dyn . R.ffor categoriesAndStatistics . Loadable.viewHideValueWhileLoading $ + void . R.dyn . R.ffor loadable . Loadable.viewHideValueWhileLoading $ stats (_in_currency input) -stats :: forall t m. MonadWidget t m => Currency -> ([Category], PaymentStats) -> m () -stats currency (categories, stats) = +stats :: forall t m. MonadWidget t m => Currency -> ([User], [Category], Stats) -> m () +stats currency (users, categories, stats) = Chart.view $ Chart.In - { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averageEachMonth) - , Chart._in_labels = map (Format.monthAndYear . fst) stats - , Chart._in_datasets = - Chart.Dataset - { Chart._dataset_label = Msg.get Msg.Statistics_Total - , Chart._dataset_data = totalSeries - , Chart._dataset_color = "#555555" - } : (map categoryDataset categories) + { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averagePayment averageIncome) + , Chart._in_labels = map (Format.monthAndYear . _monthStats_start) stats + , Chart._in_datasets = totalIncomeDataset : totalPaymentDataset : (map categoryDataset categories) } where - averageEachMonth = - Format.price currency $ sum totalSeries `div` length stats + averageIncome = + Format.price currency $ sum totalIncomes `div` length stats + + totalIncomeDataset = + Chart.Dataset + { Chart._dataset_label = Msg.get Msg.Statistics_TotalIncomes + , Chart._dataset_data = totalIncomes + , Chart._dataset_color = "#222222" + } + + totalIncomes = + map (sum . map snd . M.toList . _monthStats_incomeByUser) stats + + averagePayment = + Format.price currency $ sum totalPayments `div` length stats + + totalPaymentDataset = + Chart.Dataset + { Chart._dataset_label = Msg.get Msg.Statistics_TotalPayments + , Chart._dataset_data = totalPayments + , Chart._dataset_color = "#555555" + } - totalSeries = - map (sum . map snd . M.toList . snd) stats + totalPayments = + map (sum . map snd . M.toList . _monthStats_paymentsByCategory) stats categoryDataset category = Chart.Dataset { Chart._dataset_label = _category_name category - , Chart._dataset_data = map (M.findWithDefault 0 (_category_id category) . snd) stats + , Chart._dataset_data = map (M.findWithDefault 0 (_category_id category) . _monthStats_paymentsByCategory) stats , Chart._dataset_color = _category_color category } -- cgit v1.2.3