diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,676 @@ + 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/Manatee/Core/Config.hs b/Manatee/Core/Config.hs new file mode 100644 --- /dev/null +++ b/Manatee/Core/Config.hs @@ -0,0 +1,99 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +module Manatee.Core.Config where + +import Control.Exception +import Data.Binary +import System.Directory +import System.FilePath +import System.IO + +import qualified Control.Exception as Exc +import qualified Data.ByteString.Lazy as L + +-- | Config file directly. +getConfigDirectory :: IO FilePath +getConfigDirectory = do + home <- getHomeDirectory + return $ home ".manatee" + +-- | Browse history path. +browseHistoryPath :: FilePath +browseHistoryPath = "web/history" + +-- | Page type path. +pageTypeRulePath :: FilePath +pageTypeRulePath = "core/pageTypeRule" + +-- | File open rule. +fileOpenRulePath :: FilePath +fileOpenRulePath = "core/fileOpenRule" + +-- | Page mode rule. +pageModeRulePath :: FilePath +pageModeRulePath = "core/pageModeRule" + +-- | Duplicate tab list path. +pageModeDuplicateList :: FilePath +pageModeDuplicateList = "core/pageModeDuplicateList" + +-- | Write config file. +writeConfig :: Binary a => FilePath -> a -> IO () +writeConfig path config = do + configDir <- getConfigDirectory + let configPath = configDir path + bracket (openFile configPath WriteMode) + hClose + (\fileHandle -> L.hPutStr fileHandle (encode config)) + +-- | Read config file. +readConfig :: Binary a => FilePath -> a -> IO a +readConfig path emptyConfig = do + configDir <- getConfigDirectory + let configPath = configDir path + isExist <- doesFileExist configPath + if isExist + then + bracket (openFile configPath ReadMode) + hClose + (\ fileHandle -> do + -- Get file content. + content <- L.hGetContents fileHandle + -- Force evaluate file content. + -- Otherwise Lazy content perhaps access after FileHandle be closed. + str <- Exc.evaluate content + -- Return empty value when file is empty, otherwise decode content. + if str == L.empty + then return emptyConfig + else + -- Return empty value if decode operation failed. + Exc.catch (return $ decode str) + (\ (_ :: IOException) -> return emptyConfig)) + else do + -- Create directly first. + createDirectoryIfMissing True (takeDirectory configPath) + -- Create history file. + bracket (openFile configPath WriteMode) + hClose + (`L.hPutStr` L.empty) + -- Return empty config. + putStrLn ("Config file " ++ configPath ++ " doesn't exist, create it.") + return emptyConfig + diff --git a/Manatee/Core/DBus.hs b/Manatee/Core/DBus.hs new file mode 100644 --- /dev/null +++ b/Manatee/Core/DBus.hs @@ -0,0 +1,309 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Manatee.Core.DBus where + +import Control.Concurrent.MVar +import Control.Monad +import DBus.Client hiding (Signal) +import DBus.MatchRule +import DBus.Message (Signal, signalBody, MethodReturn, Error) +import DBus.Types +import Data.Maybe (fromMaybe) +import Data.Text.Lazy (Text, empty, append) +import Graphics.UI.Gtk.General.General +import Manatee.Core.TH +import Manatee.Core.Types +import Manatee.Toolkit.General.DBus +import Manatee.Toolkit.General.Misc +import System.Posix.Process +import System.Posix.Types (ProcessID) + +import qualified Data.Map as M + +-- | The daemon bus name. +daemonBusName :: Text +daemonBusName = "org.manatee.daemon" + +-- | The daemon interface name. +daemonInterfaceName :: Text +daemonInterfaceName = "org.manatee.daemon.interface" + +-- | The daemon path name. +daemonPathName :: Text +daemonPathName = "/path" + +-- | The damon broadcast interface name. +daemonBroadcastInterfaceName :: Text +daemonBroadcastInterfaceName = "org.manatee.daemon.broadcast.interface" + +-- | The damon broadcast path name. +daemonBroadcastPathName :: Text +daemonBroadcastPathName = "/broadcastpath" + +-- | The daemon interactive error name. +daemonInteractiveErrorName :: Text +daemonInteractiveErrorName = "org.manatee.daemon.interactive.error" + +-- | The render bus name. +-- This name just template name, +-- The real render name should add render process id behind. +renderBusName :: Text +renderBusName = "org.manatee.render" + +-- | The render interface name. +renderInterfaceName :: Text +renderInterfaceName = "org.manatee.daemon.interface" + +-- | The render path name. +renderPathName :: Text +renderPathName = "/path" + +-- | Build render client name. +-- Concat renderBusName and render process id. +mkRenderClientName :: ProcessID -> Text +mkRenderClientName processId = append renderBusName $ showText processId + +-- | Unpack daemon signal from Variant list. +-- unpackDaemonSignalArgs_ :: DaemonMember -> [Variant] -> Maybe DaemonSignalArgs +mkFunDec "unpackDaemonSignalArgs_" (unpackVariantList ''DaemonMember ''DaemonSignalArgs) + +-- | Unpack daemon signal from Variant list. +-- unpackDaemonBroadcastSignalArgs_ :: DaemonBroadcastMember -> [Variant] -> Maybe DaemonBroadcastSignalArgs +mkFunDec "unpackDaemonBroadcastSignalArgs_" (unpackVariantList ''DaemonBroadcastMember ''DaemonBroadcastSignalArgs) + +-- | Unpack render signal arguments from Variant list. +-- unpackRenderSignalArgs_ :: RenderMember -> [Variant] -> Maybe RenderSignalArgs +mkFunDec "unpackRenderSignalArgs_" (unpackVariantList ''RenderMember ''RenderSignalArgs) + +-- | Pack daemon signal argument to Variant list. +-- packDaemonSignalArgs :: DaemonSignalArgs -> [Variant] +$(packVariantList "packDaemonSignalArgs" ''DaemonSignalArgs) + +-- | Pack render signal arguments to Variant list. +$(packVariantList "packRenderSignalArgs" ''RenderSignalArgs) + +-- | Pack daemon broadcast signal arguments to Variant list. +-- packDaemonBroadcastSignalArgs :: DaemonBroadcastSignalArgs -> [Variant] +$(packVariantList "packDaemonBroadcastSignalArgs" ''DaemonBroadcastSignalArgs) + +-- | Check daemon signal argument. +-- Return False if mismatch. +mkFunDec "checkDaemonSignalArgs" (checkSignalArgs ''DaemonMember ''DaemonSignalArgs) + +-- | Check render signal arguments. +-- Return False is mismatch. +mkFunDec "checkRenderSignalArgs" (checkSignalArgs ''RenderMember ''RenderSignalArgs) + +-- | Check daemon broadcast signal argument. +-- Return False if mismatch. +mkFunDec "checkDaemonBroadcastSignalArgs" (checkSignalArgs ''DaemonBroadcastMember ''DaemonBroadcastSignalArgs) + +-- | Build daemon broadcast signal. +mkDaemonBroadcastSignal :: Client -> DaemonBroadcastMember -> DaemonBroadcastSignalArgs -> IO () +mkDaemonBroadcastSignal client memberName args + | checkDaemonBroadcastSignalArgs memberName args -- check signal argument before emit signal. + = emitSignal client signal + | otherwise + = putStrLn $ "mkDaemonBroadcastSignal CRITICAL: Invalid argument for dbus daemon broadcast member: " ++ show memberName + where signal = mkMessageSignal + daemonBroadcastPathName + (showText memberName) + daemonBroadcastInterfaceName + empty -- send to any client that interested this signal + (packDaemonBroadcastSignalArgs args) + +-- | Build daemon broadcast match rule. +mkDaemonBroadcastMatchRule :: Client -> (DaemonBroadcastMember, DaemonBroadcastSignalArgs -> IO ()) -> IO () +mkDaemonBroadcastMatchRule client (member, fun) = + onSignal client matchRule $ \_ signal -> + fun $ pickDaemonBroadcastSignalArgs member signal + where matchRule = mkMatchRule + (Just Signal) + empty + daemonBroadcastInterfaceName + (showText member) + daemonBroadcastPathName + empty + [] + +-- | Build daemon signal. +-- If signal argument not match daemon member name. +mkDaemonSignal :: Client -> DaemonMember -> DaemonSignalArgs -> IO () +mkDaemonSignal client memberName args + | checkDaemonSignalArgs memberName args -- check signal argument before emit signal. + = emitSignal client signal + | otherwise + = putStrLn $ "mkDaemonSignal CRITICAL: Invalid argument for dbus daemon member: " ++ show memberName + where signal = mkMessageSignal + daemonPathName + (showText memberName) + daemonInterfaceName + daemonBusName + (packDaemonSignalArgs args) + +-- | Build daemon match rule. +-- Use 'postGUIAsync' wrap all signal handler. +mkDaemonMatchRule :: Client -> (DaemonMember, DaemonSignalArgs -> IO ()) -> IO () +mkDaemonMatchRule client (member, fun) = + -- Use postGUIAsync wrap DBus action to protect gtk+ main thread. + onSignal client matchRule $ \_ signal -> + postGUIAsync $ fun $ pickDaemonSignalArgs member signal + where matchRule = mkMatchRule + (Just Signal) + empty + daemonInterfaceName + (showText member) + daemonPathName + daemonBusName + [] + +-- | Build daemon match rule list. +mkDaemonMatchRules :: Client -> [(DaemonMember, DaemonSignalArgs -> IO ())] -> IO () +mkDaemonMatchRules client = mapM_ (mkDaemonMatchRule client) + +-- | Pick DaemonSignalArgs. +pickDaemonSignalArgs :: DaemonMember -> Signal -> DaemonSignalArgs +pickDaemonSignalArgs member signal = unpackDaemonSignalArgs member $ signalBody signal + +-- | Pick DaemonBroadcastSignalArgs. +pickDaemonBroadcastSignalArgs :: DaemonBroadcastMember -> Signal -> DaemonBroadcastSignalArgs +pickDaemonBroadcastSignalArgs member signal = unpackDaemonBroadcastSignalArgs member $ signalBody signal + +-- | Build render signal. +-- If signal argument not match render member name. +mkRenderSignal :: Client -> ProcessID -> RenderMember -> RenderSignalArgs -> IO () +mkRenderSignal client processId memberName args + | checkRenderSignalArgs memberName args -- check signal argument before emit signal. + = emitSignal client signal + | otherwise + = putStrLn $ "mkRenderSignal CRITICAL: Invalid argument for dbus render member: " ++ show memberName + where signal = mkMessageSignal + renderPathName + (showText memberName) + renderInterfaceName + (mkRenderClientName processId) + (packRenderSignalArgs args) + +-- | Build render process match rule for catch signal. +-- Use 'postGUIAsync' wrap all signal handler. +-- If signal handler need long time calculation, +-- please use 'mkRenderMatchRuleUnsafe' for better performance. +mkRenderMatchRule :: Client -> (RenderMember, RenderSignalArgs -> IO ()) -> IO () +mkRenderMatchRule client (member, fun) = do + processId <- getProcessID + let matchRule = mkMatchRule + (Just Signal) + empty + renderInterfaceName + (showText member) + renderPathName + (mkRenderClientName processId) + [] + -- Use postGUIAsync wrap DBus action to protect gtk+ main thread. + onSignal client matchRule $ \_ signal -> + postGUIAsync $ fun $ pickRenderSignalArgs member signal + +-- | Build render process match rule for catch signal. +-- Simliar 'mkRenderMatchRule', but don't use 'postGUIAsync' wrap all signal handler. +-- This function design for signal handler that need long time calculation. +-- So you need use 'postGUIAsync' wrap GTK+ code explicitly to protect GTK+ main thread won't crash. +mkRenderMatchRuleUnsafe :: Client -> (RenderMember, RenderSignalArgs -> IO ()) -> IO () +mkRenderMatchRuleUnsafe client (member, fun) = do + processId <- getProcessID + let matchRule = mkMatchRule + (Just Signal) + empty + renderInterfaceName + (showText member) + renderPathName + (mkRenderClientName processId) + [] + onSignal client matchRule $ \_ signal -> + fun $ pickRenderSignalArgs member signal + +-- | Build render math rule list. +mkRenderMatchRules :: Client -> [(RenderMember, RenderSignalArgs -> IO ())] -> IO () +mkRenderMatchRules client = mapM_ (mkRenderMatchRule client) + +-- | Pick RenderSignalArgs. +pickRenderSignalArgs :: RenderMember -> Signal -> RenderSignalArgs +pickRenderSignalArgs member signal = unpackRenderSignalArgs member $ signalBody signal + +-- | Unpack daemon signal from Variant list. +-- Report error if mismatch. +unpackDaemonSignalArgs member args = + fromMaybe + (error $ "unpackDaemonSignalArgs: Miss pattern for " ++ show member) + (unpackDaemonSignalArgs_ member args) + +-- | Unpack daemon signal from Variant list. +-- Report error if mismatch. +unpackDaemonBroadcastSignalArgs member args = + fromMaybe + (error $ "unpackDaemonBroadcastSignalArgs: Miss pattern for " ++ show member) + (unpackDaemonBroadcastSignalArgs_ member args) + +-- | Unpack render signal arguments from Variant list. +-- Report error when mismatch. +unpackRenderSignalArgs member args = + fromMaybe + (error $ "unpackRenderSignalArgs: Miss pattern for " ++ show member) + (unpackRenderSignalArgs_ member args) + +-- | Wait broadcast exit signal. +-- This function is useful for listen exit status of main process of manatee. +-- Most for manatee extension daemon process. +waitBroadcastExitSignal :: Client -> IO () +waitBroadcastExitSignal client = do + -- Quit process when received exit signal from manatee daemon process. + exitSignal :: MVar String <- newEmptyMVar + mkDaemonBroadcastMatchRule client (ExitDaemonProcess, \_ -> putMVar exitSignal "Exit") + readMVar exitSignal -- read exit signal to exit + return () + +-- | Build daemon local object. +mkDaemonMethods :: [(Text, Member)] -> IO () +mkDaemonMethods methods = + forM_ methods $ \ (name, member) -> do + let object = LocalObject $ M.fromList [(mkInterfaceName_ daemonInterfaceName + ,Interface $ M.fromList [(mkMemberName_ name, member)])] + client <- mkSessionClientWithName (append daemonBusName name) + export client (mkObjectPath_ daemonPathName) object + +-- | Call daemon method. +callDaemonMethod :: Client -> Text -> [Variant] -> IO (Either Error MethodReturn) +callDaemonMethod client methodName = + callProxyBlocking client (Proxy (RemoteObject + (mkBusName_ (append daemonBusName methodName)) + (mkObjectPath_ daemonPathName)) + (mkInterfaceName_ daemonInterfaceName)) + (mkMemberName_ methodName) [] + +-- | Call daemon method asynchronously. +callDaemonMethodAsync :: Client -> Text -> [Variant] -> (Error -> IO ()) -> (MethodReturn -> IO ()) -> IO () +callDaemonMethodAsync client methodName = + callProxy client (Proxy (RemoteObject + (mkBusName_ (append daemonBusName methodName)) + (mkObjectPath_ daemonPathName)) + (mkInterfaceName_ daemonInterfaceName)) + (mkMemberName_ methodName) [] + diff --git a/Manatee/Core/Debug.hs b/Manatee/Core/Debug.hs new file mode 100644 --- /dev/null +++ b/Manatee/Core/Debug.hs @@ -0,0 +1,40 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Core.Debug where + +import Control.Monad + +-- | Debug flag for dbus message. +debugDBusFlag :: Bool +debugDBusFlag = True +-- debugDBusFlag = False + +-- | Debug flag for test event. +debugEventFlag :: Bool +debugEventFlag = True + +-- | Debug message for dbus message. +debugDBusMessage :: String -> IO () +debugDBusMessage str = + when debugDBusFlag $ putStrLn str + +-- | Debug message for event. +debugEventMessage :: String -> IO () +debugEventMessage str = + when debugEventFlag $ putStrLn str diff --git a/Manatee/Core/FileOpenRule.hs b/Manatee/Core/FileOpenRule.hs new file mode 100644 --- /dev/null +++ b/Manatee/Core/FileOpenRule.hs @@ -0,0 +1,80 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE OverloadedStrings #-} +module Manatee.Core.FileOpenRule where + +import Control.Monad +import DBus.Client hiding (Signal) +import Data.ByteString.UTF8 +import Manatee.Core.DBus +import Manatee.Core.Config +import Manatee.Core.Types +import System.GIO.File.AppInfo +import System.GIO.File.File +import Text.Regex.TDFA + +import qualified Data.Map as M + +-- | The rule how to open file. +fileOpenRule :: FilePath -> String -> IO [(String, Client -> IO ())] +fileOpenRule filePath contentType = do + -- The default rule. + (FileOpenRule ruleMap) <- readConfig fileOpenRulePath (FileOpenRule M.empty) + let rule = M.toList ruleMap + getDefalutRule [] = [] + getDefalutRule ((fileMatch, rules) :xs) = + let isMatch = case fileMatch of + ContentTypeMatch match -> + contentType == match + RegexpMatch match -> + contentType =~ match + in if isMatch + then + map (\ (name, pType, prefix) -> + (name, + \client -> + mkDaemonSignal client NewTab (NewTabArgs pType (prefix ++ filePath))) + ) rules + else getDefalutRule xs + let defaultRule = getDefalutRule rule + + -- Try open file by default editor. + let editorRule = if contentType =~ ("^text/*" :: String) + then [("Open file", openByDefaultEditor filePath)] + else [] + + -- Get system rule. + systemRule <- systemOpenRule filePath contentType + + return $ defaultRule ++ editorRule ++ systemRule + +-- | The open rule that handle by system. +systemOpenRule :: FilePath -> String -> IO [(String, Client -> IO ())] +systemOpenRule filePath contentType = do + infos <- appInfoGetAllForType contentType + rule <- forM infos $ \info -> do + let appName = appInfoGetDisplayName info + file = (fileFromPath . fromString) filePath + return ("Open by " ++ appName, \_ -> appInfoLaunch info [file] Nothing >> return ()) + return rule + +-- | Open by default editor. +openByDefaultEditor :: FilePath -> Client -> IO () +openByDefaultEditor filePath client = + mkDaemonSignal client NewTab (NewTabArgs "PageEditor" filePath) diff --git a/Manatee/Core/Interactive.hs b/Manatee/Core/Interactive.hs new file mode 100644 --- /dev/null +++ b/Manatee/Core/Interactive.hs @@ -0,0 +1,48 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE ExistentialQuantification, RankNTypes, DeriveDataTypeable, NoMonomorphismRestriction, FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +module Manatee.Core.Interactive where + +import Data.Text.Lazy (Text) + +-- | Parse interactive string. +-- Return error reason if parse failed. +parseInteractiveString :: String -> Either Text [(String, String)] +parseInteractiveString interactiveStr + | null prompts + = Left "Empty interactive string." + | any null prompts + = Left "Have null line in interactive string." + | any (`notElem` "cdfsn") types + = Left "Have invalid type character in interactive string." + | otherwise + = Right $ + map (\x -> (interactiveCandidateName (head x), tail x)) prompts + where prompts = lines interactiveStr + types = map head prompts + +-- | Get candidate name for type character. +interactiveCandidateName :: Char -> String +interactiveCandidateName 'c' = "InteractiveChar" +interactiveCandidateName 'd' = "InteractiveDirectory" +interactiveCandidateName 'f' = "InteractiveFile" +interactiveCandidateName 'n' = "InteractiveNumber" +interactiveCandidateName 's' = "InteractiveString" + diff --git a/Manatee/Core/Page.hs b/Manatee/Core/Page.hs new file mode 100644 --- /dev/null +++ b/Manatee/Core/Page.hs @@ -0,0 +1,43 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE RankNTypes #-} +module Manatee.Core.Page where + +import Graphics.UI.Gtk hiding (Frame, frameNew, Signal, Plug) +import Manatee.Core.Types +import Manatee.Toolkit.Gtk.Struct +import Manatee.Toolkit.Widget.Plug + +-- | New page. +pageNew :: PageId -> PageType -> PagePlug -> PageViewWrap -> IO Page +pageNew pId pType plug pvw = + return $ Page pId pType plug pvw + +-- | Page scrolled window. +pageScrolledWindow :: Page -> ScrolledWindow +pageScrolledWindow page = + pageApplyViewWrap page pageViewScrolledWindow + +-- | Applying function with page buffer. +pageApplyViewWrap :: Page -> (forall a . PageView a => a -> b) -> b +pageApplyViewWrap (Page {pageView = (PageViewWrap x)}) f = f x + +-- | Page plug id. +pagePlugId :: Page -> GWindowId +pagePlugId = plugId . pagePlug diff --git a/Manatee/Core/PageMode.hs b/Manatee/Core/PageMode.hs new file mode 100644 --- /dev/null +++ b/Manatee/Core/PageMode.hs @@ -0,0 +1,56 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, RankNTypes, OverloadedStrings #-} +module Manatee.Core.PageMode where + +import Manatee.Core.Config +import Manatee.Core.Types +import Manatee.Toolkit.General.Map +import Text.Regex.TDFA + +import qualified Data.Map as M + +-- | Default mode. +defaultMode :: PageMode +defaultMode = + PageMode {pageModeName = "Default" + ,pageModeRegexp = "" + ,pageModeKeymap = M.empty + ,pageModeLoad = \_ -> return ()} + +-- | Get duplicate tab list. +getDuplicateTabList :: IO [PageModeName] +getDuplicateTabList = do + (PageModeDuplicateList list) <- readConfig pageModeDuplicateList (PageModeDuplicateList []) + return list + +-- | Get page mode name. +getPageModeName :: PageType -> String -> IO PageModeName +getPageModeName pType path = do + (PageModeRule ruleMap) <- readConfig pageModeRulePath (PageModeRule M.empty) + return $ + case findMinMatch ruleMap (\ typ _ -> pType == typ) of + Just (_, rule) -> + case rule of + Left name -> name + Right map -> + case findMinMatch map (\ regexp _ -> path =~ regexp) of + Just (_, name) -> name + Nothing -> pageModeName defaultMode + Nothing -> pageModeName defaultMode diff --git a/Manatee/Core/PageView.hs b/Manatee/Core/PageView.hs new file mode 100644 --- /dev/null +++ b/Manatee/Core/PageView.hs @@ -0,0 +1,158 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE ExistentialQuantification, RankNTypes, DeriveDataTypeable, NoMonomorphismRestriction, FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +module Manatee.Core.PageView where + +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import DBus.Client hiding (Signal) +import DBus.Message +import DBus.Types +import Manatee.Core.DBus +import Manatee.Core.Interactive +import Manatee.Core.Types +import Manatee.Toolkit.General.Basic +import Manatee.Toolkit.General.Maybe +import Manatee.Toolkit.General.String +import Graphics.UI.Gtk.General.General + +import qualified Data.Map as M + +-- | PageViewKeymap. +pageViewKeymap :: PageViewKeymap +pageViewKeymap = + M.fromList + [("M-u", pageViewScrollStepUp) + ,("M-i", pageViewScrollStepDown) + ,("M-U", pageViewScrollPageUp) + ,("M-I", pageViewScrollPageDown) + ,("C-I", pageViewScrollToTop) + ,("C-U", pageViewScrollToBottom) + ,("PageDown", pageViewScrollPageUp) + ,("PageUp", pageViewScrollPageDown) + ,("Home", pageViewScrollToTop) + ,("End", pageViewScrollToBottom) + ,("M-y", pageViewScrollStepRight) + ,("M-o", pageViewScrollStepLeft) + ,("M-Y", pageViewScrollPageRight) + ,("M-O", pageViewScrollPageLeft) + ,("C-Y", pageViewScrollToLeft) + ,("C-O", pageViewScrollToRight) + ,("M-x", pageViewCutAction) + ,("M-c", pageViewCopyAction) + ,("M-v", pageViewPasteAction) + ] + +-- | Basic scroll action. +pageViewScrollStepUp, pageViewScrollStepDown, pageViewScrollPageUp, pageViewScrollPageDown :: PageView a => a -> IO () +pageViewScrollStepUp = pageViewScrollVerticalStep True +pageViewScrollStepDown = pageViewScrollVerticalStep False +pageViewScrollPageUp = pageViewScrollVerticalPage True +pageViewScrollPageDown = pageViewScrollVerticalPage False + +pageViewScrollStepRight, pageViewScrollStepLeft, pageViewScrollPageRight, pageViewScrollPageLeft :: PageView a => a -> IO () +pageViewScrollStepRight = pageViewScrollHorizontalStep False +pageViewScrollStepLeft = pageViewScrollHorizontalStep True +pageViewScrollPageRight = pageViewScrollHorizontalPage False +pageViewScrollPageLeft = pageViewScrollHorizontalPage True + +-- | Get plug id of page view. +pageViewGetPlugId :: forall a . PageView a => a -> IO PagePlugId +pageViewGetPlugId = readTVarIO . pageViewPlugId + +-- | Update output. +pageViewUpdateOutputStatus :: forall a . PageView a => a -> String -> Maybe Int -> IO () +pageViewUpdateOutputStatus view output limit = do + plugId <- pageViewGetPlugId view + let str = case limit of + Just l -> stripFormat output l + Nothing -> output + mkDaemonSignal (pageViewClient view) + LocalOutputbarUpdate + (LocalOutputbarUpdateArgs plugId str) + +-- | Update progress. +pageViewUpdateProgressStatus :: forall a . PageView a => a -> Double -> IO () +pageViewUpdateProgressStatus view progress = do + plugId <- pageViewGetPlugId view + mkDaemonSignal (pageViewClient view) + LocalProgressUpdate + (LocalProgressUpdateArgs plugId progress) + + +-- | Update status. +pageViewUpdateInfoStatus :: forall a . PageView a => a -> String -> String -> IO () +pageViewUpdateInfoStatus view item status = do + plugId <- pageViewGetPlugId view + mkDaemonSignal (pageViewClient view) + LocalStatusbarUpdate + (LocalStatusbarUpdateArgs plugId item status) + +-- | Get dbus client. +pageViewClient :: forall a . PageView a => a -> Client +pageViewClient view = + case pageViewBuffer view of + (PageBufferWrap b) -> pageBufferClient b + +-- | Cut action. +pageViewCutAction :: forall a . PageView a => a -> IO () +pageViewCutAction view = + unlessM (pageViewCut view) $ + pageViewUpdateOutputStatus view "Haven't implement pageViewCut" Nothing + +-- | Copy action. +pageViewCopyAction :: forall a . PageView a => a -> IO () +pageViewCopyAction view = + unlessM (pageViewCopy view) $ + pageViewUpdateOutputStatus view "Haven't implement pageViewCopy" Nothing + +-- | Paste action. +pageViewPasteAction :: forall a . PageView a => a -> IO () +pageViewPasteAction view = + unlessM (pageViewPaste view) $ + pageViewUpdateOutputStatus view "Haven't implement pageViewPaste" Nothing + +-- | Call local interactive. +localInteractive :: forall a . PageView a => a -> String -> ([String] -> IO ()) -> IO () +localInteractive view args action = + case parseInteractiveString args of + -- Don't do anything if parse failed. + Left err -> putStrLn $ "localInteractive : Failed with reason : " ++ show err + Right strList -> do + plugId <- pageViewGetPlugId view + callDaemonMethodAsync + (pageViewClient view) + "Interactive" + [toVariant (plugId, args)] + (\ err -> putStrLn $ "localInteractive : Failed with reason : " ++ show err) + (\ methodReturn -> do + let variants = messageBody methodReturn + unless (null variants) $ + (fromVariant (head variants) :: Maybe [String]) + ?>= \ list -> + -- Just do action if return list match. + when (length strList == length list) $ + -- Use `postGUIAsync` to protected GTK+ main thread. + postGUIAsync (bracketOnError + (return list) + -- Print error message if exception rasied when do action. + (\ _ -> putStrLn "localInteractive: exception rasied.") + action)) diff --git a/Manatee/Core/Render.hs b/Manatee/Core/Render.hs new file mode 100644 --- /dev/null +++ b/Manatee/Core/Render.hs @@ -0,0 +1,210 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Core.Render where + +import Control.Monad.State +import DBus.Client hiding (Signal) +import GHC.Conc +import Graphics.UI.Gtk hiding (Window, windowNew, Frame, frameNew, Signal, Frame, Variant, Action, plugNew, plugGetId, get) +import Manatee.Core.DBus +import Manatee.Core.Debug +import Manatee.Core.Page +import Manatee.Core.PageView +import Manatee.Core.Types +import Manatee.Toolkit.General.DBus +import Manatee.Toolkit.General.Maybe +import Manatee.Toolkit.General.STM +import Manatee.Toolkit.General.Set hiding (mapM) +import Manatee.Toolkit.General.State +import Manatee.Toolkit.Widget.Plug +import System.Environment +import System.Posix.Process +import System.Posix.Types (ProcessID) + +import qualified Data.Map as M +import qualified Data.Set as Set + +-- | Irc client render process. +startupRender :: PageBufferNewFun -> IO () +startupRender bufferNewFun = do + -- Get program arguments. + args <- getArgs + + case args of + [x] -> + case (read x :: SpawnProcessArgs) of + arg@(SpawnRenderProcessArgs {}) -> renderMain arg bufferNewFun + _ -> return () + _ -> return () + +-- | Render process main entry. +renderMain :: SpawnProcessArgs -> PageBufferNewFun -> IO () +renderMain (SpawnRenderProcessArgs pageId pType sId pagePath) bufferNewFun = do + -- Init. + unsafeInitGUIForThreadedRTS + + -- Create page list. + pageList <- newTVarIO Set.empty + + -- Get render process id. + processId <- getProcessID + + -- Make client name. + let clientName = mkRenderClientName processId + + -- Create client. + client <- mkSessionClientWithName clientName + + -- Create page buffer. + bufferWrap <- bufferNewFun pagePath client pageId + + -- Build render client for listen dbus signal. + mkRenderClient client bufferWrap processId pageList pType + + -- Create first page. + renderPageNew client bufferWrap pageList processId (pageId, pType, sId) True + + -- Loop. + mainGUI + +-- | Build render client for listen dbus signal. +mkRenderClient :: Client -> PageBufferWrap -> ProcessID -> TVar PageList -> PageType -> IO () +mkRenderClient client bufferWrap processId pageList pType = + -- Build match rule. + mkRenderMatchRules client + [(CloneRenderPage, renderHandleClonePage client bufferWrap pageList processId pType) + ,(ReparentRenderPage, renderHandleReparentPage client bufferWrap pageList processId) + ,(FocusRenderPage, renderHandleFocusPage pageList) + ,(PageViewKeyPress, renderHandleKeyPress pageList) + ,(DestroyRenderPage, renderHandleDestroyPage pageList) + ,(ExitRenderProcess, renderHandleExitProcess client processId)] + +-- | Handle clone render page signal. +renderHandleClonePage :: Client -> PageBufferWrap -> TVar PageList -> ProcessID -> PageType -> RenderSignalArgs -> IO () +renderHandleClonePage client bufferWrap pageList processId pType (CloneRenderPageArgs pageId sId) = do + debugDBusMessage $ "renderHandleClonePage: Catch CloneRenderPage signal. Box id: " ++ show sId + + renderPageNew client bufferWrap pageList processId (pageId, pType, sId) False + + debugDBusMessage $ "renderHandleClonePage: Finish clone page. Box id : " ++ show sId + +-- | Handle re-parent render page signal. +renderHandleReparentPage :: Client -> PageBufferWrap -> TVar PageList -> ProcessID -> RenderSignalArgs -> IO () +renderHandleReparentPage client (PageBufferWrap buffer) pageList processId (ReparentRenderPageArgs pageId oldPlugId sId) = do + debugDBusMessage $ "renderHandleReparentPage: Catch ReparentRenderPage signal. Box id: " ++ show sId + + -- Get old plug. + pList <- readTVarIO pageList + let oldPage = maybeFindMin pList (\x -> pagePlugId x == oldPlugId) + + -- Try to re-parent children from old plug. + case oldPage of + Just op -> do + -- Create new plug. + newPlug <- plugNew Nothing + let pId = plugId newPlug + pType = pageType op + + -- Reparent. + writeTVarIO (pageApplyViewWrap op pageViewPlugId) pId -- update new page plug id + widgetReparent (pageScrolledWindow op) (plugBody newPlug) + widgetShowAll $ plugBody newPlug + + -- New page. + page <- pageNew pageId pType newPlug (pageView op) + + -- Add page to page list. + runTVarStateT pageList $ put . Set.insert page + + -- Destroy old plug. + renderHandleDestroyPage pageList (DestroyRenderPageArgs pageId oldPlugId) + + -- Send `NewRenderPageConfirm` signal. + let modeName = pageModeName $ pageBufferMode buffer + path <- pageBufferGetName buffer + mkDaemonSignal client + NewRenderPageConfirm + (NewRenderPageConfirmArgs pageId pType sId pId processId modeName path False) + + debugDBusMessage $ "renderHandleReparentPage: Finish reparent page. Box id : " ++ show sId + Nothing -> debugDBusMessage $ "Warning (renderHandleReparentPage): Cant find old plug " ++ show oldPlugId ++ " to reparent." + +-- | Handle new render page signal. +renderPageNew :: Client -> PageBufferWrap -> TVar PageList -> ProcessID -> (PageId, PageType, SignalBoxId) -> Bool -> IO () +renderPageNew client (PageBufferWrap buffer) pageList processId (pageId, pType, sId) isFirstPage = do + -- Create page plug. + plug <- plugNew Nothing + let pId = plugId plug + + -- Create page. + viewWrap <- pageBufferCreateView buffer pId + page <- pageNew pageId pType plug viewWrap + + -- Create page and pageView. + plugBody plug `containerAdd` pageScrolledWindow page + widgetShowAll $ plugBody plug + + -- Add page to page list. + runTVarStateT pageList $ put . Set.insert page + + -- Send `NewRenderPageConfirm` signal. + let modeName = pageModeName $ pageBufferMode buffer + path <- pageBufferGetName buffer + mkDaemonSignal client + NewRenderPageConfirm + (NewRenderPageConfirmArgs pageId pType sId pId processId modeName path isFirstPage) + +-- | Handle focus render page signal. +renderHandleFocusPage :: TVar PageList -> RenderSignalArgs -> IO () +renderHandleFocusPage pageList (FocusRenderPageArgs plugId) = do + pl <- readTVarIO pageList + maybeFindMin pl (\x -> pagePlugId x == plugId) + ?>= \ page -> pageApplyViewWrap page pageViewFocus + +-- | Handle page view key press signal. +renderHandleKeyPress :: TVar PageList -> RenderSignalArgs -> IO () +renderHandleKeyPress pageList (PageViewKeyPressArgs plugId keystoke sEvent) = do + pl <- readTVarIO pageList + maybeFindMin pl (\x -> pagePlugId x == plugId) + ?>= \ (Page {pageView = PageViewWrap view}) -> + case M.lookup keystoke pageViewKeymap of + -- Execute page view common action when match. + Just action -> action view + -- Otherwise pass key to page view instance. + Nothing -> pageViewHandleKeyAction view keystoke sEvent + +-- | Handle destroy render page signal. +renderHandleDestroyPage :: TVar PageList -> RenderSignalArgs -> IO () +renderHandleDestroyPage pageList (DestroyRenderPageArgs _ plugId) = + runTVarStateT pageList $ \pl -> + maybeFindMin pl (\x -> pagePlugId x == plugId) ?>= \mp -> do + lift $ debugDBusMessage $ "renderHandleDestroyPage: Catch DestroyRenderPage signal. Plug id : " ++ show plugId + -- Delete page from page list. + put (Set.delete mp pl) + -- Destroy page. + lift $ plugDestroy $ pagePlug mp + +-- | Handle exit process signal. +renderHandleExitProcess :: Client -> ProcessID -> RenderSignalArgs -> IO () +renderHandleExitProcess client processId (ExitRenderProcessArgs pageId) = do + -- Send RenderProcessExit signal to daemon process. + mkDaemonSignal client RenderProcessExit (RenderProcessExitArgs pageId processId) + + -- Quit process. + mainQuit diff --git a/Manatee/Core/TH.hs b/Manatee/Core/TH.hs new file mode 100644 --- /dev/null +++ b/Manatee/Core/TH.hs @@ -0,0 +1,126 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, FlexibleInstances #-} +module Manatee.Core.TH where + +import Control.Applicative +import Control.Monad +import DBus.Types +import Language.Haskell.TH + +-- | Unpack variant with corresponding type. +unpackVariantList :: Name -> Name -> ExpQ +unpackVariantList tagt dty = do + -- getCons :: Info -> [(Name, Int)] + let getCons (TyConI (DataD _ _ _ x _)) = [ (n,length ts) | NormalC n ts <- x ] + -- :: Name -> Q [Name] + tags <- (map fst . getCons) `fmap` reify tagt + -- :: Name -> Q [(Name, Int)] + dats <- getCons `fmap` reify dty + [| \tag ls -> + -- caseE :: ExpQ -> [MatchQ] -> ExpQ + $( caseE [| (tag,ls) |] + -- [MatchQ] + [do + -- [DatArg] with length `n`. + xs <- replicateM n (newName "x") + match + -- (TagName, DatName arg1 arg2 ... argn) + (tupP [recP t [],listP (map varP xs)]) + -- BodyQ + (normalB $ foldl + (\f x -> [| $f <*> $x |]) + [| pure $(conE d) |] + (map (\x -> [| fromVariant $(varE x) |] ) xs)) + -- [DecQ] + [] + -- [(Name, (Name, Int))] + | (t,(d,n)) <- tags `zip` dats ] + ) + |] + +-- | This string is append in SignalArgs with MemberName. +-- Example dbus member named `Foo`, and SignalArgs should be `FooArgs`. +-- Otherwise, function `checkSignalArgs` will failed. +signalArgsTemplate :: String +signalArgsTemplate = "Args" + +-- | Unpack variant with corresponding type. +checkSignalArgs :: Name -> Name -> ExpQ +checkSignalArgs tagt dty = do + let getCons (TyConI (DataD _ _ _ x _)) = [ (n, ts) | NormalC n ts <- x ] + tags <- (map fst . getCons) `fmap` reify tagt + dats <- (map fst . getCons) `fmap` reify dty + [| \tag ls -> + $( caseE [| (tag,ls) |] + [do + -- Get base name. + let memberName = nameBase t ++ signalArgsTemplate + signalArgsName = nameBase d + match + (tupP [recP t [], recP d []]) + (normalB [| memberName == signalArgsName |]) + [] + | (t,d) <- tags `zip` dats ] + ) + |] + +-- | Pack variant with corresponding type. +packVariantList :: String -> Name -> Q [Dec] +packVariantList = packListTemplate (\x -> [| toVariant $(varE x) |]) + +-- | Pack variant with corresponding type. +packStringList :: String -> Name -> Q [Dec] +packStringList = packListTemplate (\x -> [| show $(varE x) |]) + +-- | This is template code for transform typ to [a] +packListTemplate :: (Name -> ExpQ) -> String -> Name -> Q [Dec] +packListTemplate fun str args = do + TyConI (DataD _ _ _ constructors _) <- reify args + let packList (NormalC name fields) = do + vars <- replicateM (length fields) (newName "x") + let pats = map varP vars + clause [conP name pats] -- build [PatQ], don't empty, otherwise got "unbound variable" + (normalB (listE $ map fun vars)) + [] + + body <- forM constructors (return . packList) + fmap (: []) $ funD (mkName str) body + +-- | Build declaration. +-- If this function got "unbound variable", try use `packVariantList` +-- style to build [PatQ] explicitly. +mkDec :: String -> ExpQ -> DecQ +mkDec str f = funD (mkName str) [clause [] (normalB f) []] + +-- | Build function declaration. +mkFunDec :: String -> ExpQ -> Q [Dec] +mkFunDec str f = fmap (: []) $ mkDec str f + +-- | Generate n unique variables and return them in form of patterns and expressions. +genPE fields = do + ids <- replicateM (length fields) (newName "x") + return (map varP ids, map varE ids) + +-- | Generate Variable instance. +deriveVariable _t = [d| + instance Variable $_t where + toVariant = toVariant . show + fromVariant x = fmap (\v -> read v :: $_t) $ fromVariant x|] + diff --git a/Manatee/Core/Types.hs b/Manatee/Core/Types.hs new file mode 100644 --- /dev/null +++ b/Manatee/Core/Types.hs @@ -0,0 +1,304 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, TypeSynonymInstances, RankNTypes, FlexibleInstances, GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +module Manatee.Core.Types where + +import Control.Concurrent.STM +import DBus.Client hiding (Signal) +import DBus.Types +import Data.Binary +import Data.Derive.Ord +import Data.Derive.Read +import Data.DeriveTH +import Data.Function +import Data.Map (Map) +import Data.Ord +import Data.Sequence (Seq) +import Data.Set +import Data.Text.Lazy (Text) +import Data.Typeable +import Graphics.UI.Gtk hiding (on, get, Action, Statusbar, statusbarNew, Window, Frame, frameNew, Plug) +import Graphics.UI.Gtk.Gdk.SerializedEvent +import Language.Haskell.TH +import Manatee.Core.TH +import Manatee.Toolkit.Gtk.ScrolledWindow +import Manatee.Toolkit.Gtk.Struct +import Manatee.Toolkit.Widget.Plug +import System.Posix.Types (ProcessID) + +-- | Page is widget container for render view. +data Page = Page {pageId :: PageId + ,pageType :: PageType + ,pagePlug :: Plug + ,pageView :: PageViewWrap + } + +type PagePlug = Plug + +instance Eq Page where + (==) = (==) `on` (plugId . pagePlug) + +instance Ord Page where + compare = comparing (plugId . pagePlug) + +-- | PageList +-- Contain pages (different view for same buffer) in child process. +-- Build index for looking for corresponding page. +type PageList = Set Page + +-- | PageType for different type page. +type PageType = String + +data PageTypeRule = + PageTypeRule (Map PageType String) + deriving (Show, Read, Eq, Ord, Typeable) + +data FileOpenRule = + FileOpenRule (Map FileMatch [(FileOpenName, PageType, FilePrefix)]) + deriving (Show, Read, Eq, Ord, Typeable) + +type FileOpenName = String +type FilePrefix = String + +data PageModeRule = + PageModeRule (Map PageType (Either + PageModeName + (Map String PageModeName))) + deriving (Show, Read, Eq, Ord, Typeable) + +data PageModeDuplicateList = + PageModeDuplicateList [PageModeName] + deriving (Show, Read, Eq, Ord, Typeable) + +data FileMatch = ContentTypeMatch String + | RegexpMatch String + deriving (Show, Read, Eq, Ord, Typeable) + +-- | BufferList +newtype BufferList = + BufferList (Map PageModeName (Seq Buffer)) + deriving Show + +data Buffer = + Buffer {bufferProcessId :: ProcessID + ,bufferPageId :: PageId + ,bufferPageType :: PageType + ,bufferPath :: String + ,bufferName :: String + } + deriving (Show, Read, Eq, Ord) + +data BufferInfo = + BufferInfo {bufferInfoMode :: PageModeName + ,bufferInfoPath :: PagePath + ,bufferInfoName :: String + ,bufferInfoId :: PageId} + deriving (Show, Read, Eq, Ord, Typeable) + +data BufferHistory = + BufferHistory {bufferHistoryMode :: PageModeName + ,bufferHistoryType :: PageType + ,bufferHistoryPath :: PagePath} + deriving (Show, Read, Eq, Ord, Typeable) + +data BrowseHistoryList = + BrowseHistoryList (Map String String) + deriving (Show, Read, Eq, Ord, Typeable) + +type BufferInfoList = [BufferInfo] +type BufferHistoryList = [BufferHistory] + +-- | PageMode +type PageModeName = String +type PageModeRegexp = String + +data PageMode = + PageMode {pageModeName :: PageModeName + ,pageModeRegexp :: PageModeRegexp + ,pageModeKeymap :: PageViewKeymap + ,pageModeLoad :: forall a . PageView a => a -> IO ()} + +-- | PageBuffer +class Typeable a => PageBuffer a where + pageBufferGetName :: a -> IO String + pageBufferSetName :: a -> String -> IO () + pageBufferClient :: a -> Client + pageBufferCreateView :: a -> PagePlugId -> IO PageViewWrap + pageBufferMode :: a -> PageMode + +data PageBufferWrap = forall a . PageBuffer a => PageBufferWrap a + +-- | Page buffer new function. +type PageBufferNewFun = FilePath -> Client -> PageId -> IO PageBufferWrap + +-- | PageView class. +class Typeable a => PageView a where + pageViewBuffer :: a -> PageBufferWrap + pageViewPlugId :: a -> TVar PagePlugId + pageViewHandleKeyAction :: a -> Text -> SerializedEvent -> IO () + pageViewFocus :: a -> IO () + pageViewCopy :: a -> IO Bool + pageViewCopy _ = return False + pageViewCut :: a -> IO Bool + pageViewCut _ = return False + pageViewPaste :: a -> IO Bool + pageViewPaste _ = return False + pageViewScrolledWindow :: a -> ScrolledWindow + pageViewScrollToTop :: a -> IO () + pageViewScrollToTop = + scrolledWindowScrollToTop . pageViewScrolledWindow + pageViewScrollToBottom :: a -> IO () + pageViewScrollToBottom = + scrolledWindowScrollToBottom . pageViewScrolledWindow + pageViewScrollVerticalPage :: Bool -> a -> IO () + pageViewScrollVerticalPage isDown a = + scrolledWindowScrollVerticalPage isDown (pageViewScrolledWindow a) + pageViewScrollVerticalStep :: Bool -> a -> IO () + pageViewScrollVerticalStep isDown a = + scrolledWindowScrollVerticalStep isDown (pageViewScrolledWindow a) + pageViewScrollToLeft :: a -> IO () + pageViewScrollToLeft = + scrolledWindowScrollToLeft . pageViewScrolledWindow + pageViewScrollToRight :: a -> IO () + pageViewScrollToRight = + scrolledWindowScrollToRight . pageViewScrolledWindow + pageViewScrollHorizontalPage:: Bool -> a -> IO () + pageViewScrollHorizontalPage isDown a = + scrolledWindowScrollHorizontalPage isDown (pageViewScrolledWindow a) + pageViewScrollHorizontalStep:: Bool -> a -> IO () + pageViewScrollHorizontalStep isDown a = + scrolledWindowScrollHorizontalStep isDown (pageViewScrolledWindow a) + +data PageViewWrap = forall a . PageView a => PageViewWrap a + +type PageViewKeymap = forall a . PageView a => Map Text (a -> IO ()) + +data AnythingInteractiveType = GlobalSearch + | GlobalInteractive + | LocalInteractive + deriving (Show, Ord, Eq, Read) + +-- | DBus +type AnythingKeyPressId = Int +type PageId = Int +type PageSocketId = GWindowId +type PagePlugId = GWindowId +type PagePath = String +type SignalBoxId = Int +type InteractiveString = (PagePlugId, String) +type InteractiveResult = [String] + +$(derive makeOrd ''Color) +$(derive makeRead ''Color) + +-- | Variant instance for serialize value to DBus system. +deriveVariable (conT ''ProcessID) +deriveVariable (conT ''GWindowId) +deriveVariable (conT ''Color) +deriveVariable (conT ''Maybe `appT` conT ''Color) +deriveVariable (conT ''Int) +deriveVariable (conT ''Maybe `appT` conT ''Char) +deriveVariable (conT ''Maybe `appT` conT ''Int) +deriveVariable (conT ''SerializedEvent) +deriveVariable (conT ''BufferInfoList) +deriveVariable (conT ''BufferHistoryList) +deriveVariable (conT ''Maybe `appT` conT ''Point) +deriveVariable (conT ''InteractiveString) +deriveVariable (conT ''InteractiveResult) +deriveVariable (conT ''AnythingInteractiveType) + +data DaemonMember = NewRenderPageConfirm + | NewAnythingProcessConfirm + | RenderProcessExit + | RenderProcessException + | NewTab + | AnythingViewOutput + | LocalInteractivebarExit + | LocalOutputbarUpdate + | LocalStatusbarUpdate + | LocalProgressUpdate + | SynchronizationPathName + | ChangeTabName + | SwitchBuffer + | ShowTooltip + | LocalInteractiveReturn + | GlobalInteractiveReturn + deriving (Show, Eq, Ord) + +data DaemonSignalArgs = NewRenderPageConfirmArgs PageId PageType SignalBoxId PagePlugId ProcessID PageModeName String Bool + | NewAnythingProcessConfirmArgs PagePlugId ProcessID + | RenderProcessExitArgs PageId ProcessID + | RenderProcessExceptionArgs PageId + | NewTabArgs PageType PagePath + | AnythingViewOutputArgs String String (Maybe Int) AnythingKeyPressId + | LocalInteractivebarExitArgs + | LocalOutputbarUpdateArgs PagePlugId String + | LocalStatusbarUpdateArgs PagePlugId String String + | LocalProgressUpdateArgs PagePlugId Double + | SynchronizationPathNameArgs PageModeName PageId String + | ChangeTabNameArgs PageModeName PageId String + | SwitchBufferArgs PageModeName PageId + | ShowTooltipArgs String (Maybe Point) Int (Maybe Color) (Maybe Color) Bool (Maybe PageId) + | LocalInteractiveReturnArgs [String] + | GlobalInteractiveReturnArgs [String] + deriving (Show, Eq, Ord) + +data RenderMember = CloneRenderPage + | ReparentRenderPage + | FocusRenderPage + | PageViewKeyPress + | DestroyRenderPage + | ExitRenderProcess + | AnythingViewKeyPress + | AnythingViewChangeCandidate + | AnythingViewChangeInteractiveType + deriving (Show, Eq, Ord) + +data RenderSignalArgs = CloneRenderPageArgs PageId SignalBoxId + | ReparentRenderPageArgs PageId PagePlugId SignalBoxId + | FocusRenderPageArgs PagePlugId + | PageViewKeyPressArgs PagePlugId Text SerializedEvent + | DestroyRenderPageArgs PageId PagePlugId + | ExitRenderProcessArgs PageId + | AnythingViewKeyPressArgs Text String String AnythingKeyPressId Bool + | AnythingViewChangeCandidateArgs [String] + | AnythingViewChangeInteractiveTypeArgs AnythingInteractiveType + deriving (Show, Eq, Ord) + +data DaemonBroadcastMember = ExitDaemonProcess + deriving (Show, Eq, Ord) + +data DaemonBroadcastSignalArgs = ExitDaemonProcessArgs + deriving (Show, Eq, Ord) + +data AnythingSearchArgs = GlobalSearchArgs + | InteractiveSearchArgs AnythingInteractiveType [String] + deriving (Show, Eq, Ord, Read) + +data SpawnProcessArgs = SpawnRenderProcessArgs PageId PageType SignalBoxId PagePath + | SpawnAnythingProcessArgs AnythingSearchArgs + deriving (Show, Eq, Ord, Read) + +$(derive makeBinary ''BrowseHistoryList) +$(derive makeBinary ''PageTypeRule) +$(derive makeBinary ''FileMatch) +$(derive makeBinary ''FileOpenRule) +$(derive makeBinary ''PageModeRule) +$(derive makeBinary ''PageModeDuplicateList) diff --git a/Manatee/Toolkit/Data/ListZipper.hs b/Manatee/Toolkit/Data/ListZipper.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Data/ListZipper.hs @@ -0,0 +1,246 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Data.ListZipper where + +import Data.Maybe +import Manatee.Toolkit.General.List + +import qualified Data.List as List + +data ListZipper a = ListZipper ![a] ![a] + +instance Show a => Show (ListZipper a) where + show (ListZipper ls rs) = show (reverse ls) ++ show rs + +instance Functor ListZipper where + fmap f (ListZipper ls rs) = ListZipper (map f ls) (map f rs) + +-- | Create an empty ListZipper. +empty :: ListZipper a +empty = ListZipper [] [] + +-- | Create a ListZipper with a single element. +singleton :: a -> ListZipper a +singleton a = ListZipper [] [a] + +-- | Create a ListZipper from list, and focus focus to first element in list. +fromList :: [a] -> ListZipper a +fromList = ListZipper [] + +-- | Create a ListZipper from list end, and focus focus to end element in list. +fromListEnd :: [a] -> ListZipper a +fromListEnd as = ListZipper (reverse as) [] + +-- | Convert ListZipper to List. +toList :: ListZipper a -> [a] +toList (ListZipper ls rs) = reverse ls ++ rs + +-- | Whether is first element. +atStart :: ListZipper a -> Bool +atStart (ListZipper [] _ ) = True +atStart _ = False +-- | Whether is last element. +atEnd :: ListZipper a -> Bool +atEnd (ListZipper _ []) = True +atEnd _ = False +-- | Whether is empty. +isEmpty :: ListZipper a -> Bool +isEmpty (ListZipper [] []) = True +isEmpty _ = False + +-- | Get current node, return Nothing if haven't found anything at current node. +-- This function won't change current focus node. +getCurrent :: ListZipper a -> Maybe a +getCurrent list = get list $ currentIndex list +-- | Get left node, return Nothing if haven't found anything at left node. +-- This function won't change current focus node. +getLeft :: ListZipper a -> Maybe a +getLeft list = get list $ leftIndex list +-- | Get right node, return Nothing if haven't found anything at right node. +-- This function won't change current focus node. +getRight :: ListZipper a -> Maybe a +getRight list = get list $ rightIndex list +-- | Get first node, return Nothing if haven't found anything at first node. +-- This function won't change current focus node. +getFirst :: ListZipper a -> Maybe a +getFirst list = get list $ firstIndex list +-- | Get last node, return Nothing if haven't found anything at last node. +-- This function won't change current focus node. +getLast :: ListZipper a -> Maybe a +getLast list = get list $ lastIndex list + +-- | Get left node, return Nothing if haven't found anything at left node. +-- If reach first node, circular to end node. +-- This function won't change current focus node. +getLeftCircular :: ListZipper a -> Maybe a +getLeftCircular list + | prevIndex < firstIndex list + = get list $ lastIndex list + | otherwise + = get list prevIndex + where + prevIndex = leftIndex list +-- | Get right node, return Nothing if haven't found anything at right node. +-- If reach last node, circular to first node. +-- This function won't change current focus node. +getRightCircular :: ListZipper a -> Maybe a +getRightCircular list + | nextIndex > lastIndex list + = get list $ firstIndex list + | otherwise + = get list nextIndex + where + nextIndex = rightIndex list + +-- | Get node with given index. +-- This function won't change current focus node. +get :: ListZipper a -> Int -> Maybe a +get = (?!) . toList + +-- | Focus left node. +focusLeft :: ListZipper a -> Maybe (ListZipper a) +focusLeft (ListZipper (a:ls) rs) = Just $ ListZipper ls (a:rs) +focusLeft _ = Nothing +-- | Focus right node. +focusRight :: ListZipper a -> Maybe (ListZipper a) +focusRight (ListZipper ls (a:rs)) = Just $ ListZipper (a:ls) rs +focusRight _ = Nothing +-- | Focus first node. +focusFirst :: ListZipper a -> Maybe (ListZipper a) +focusFirst list = focus (firstIndex list) list +-- | Focus last node. +focusLast :: ListZipper a -> Maybe (ListZipper a) +focusLast list = focus (lastIndex list) list + +-- | Focus node with given index. +focus :: Int -> ListZipper a -> Maybe (ListZipper a) +focus n list + | n < 0 + = Nothing + | n >= lenList + = Nothing + | n == currIndex + = Just list + | n < currIndex + = (=<<) (focus n) leftList + | otherwise + = (=<<) (focus n) rightList + where + lenList = Manatee.Toolkit.Data.ListZipper.length list + currIndex = currentIndex list + leftList = focusLeft list + rightList = focusRight list + +-- | Focus node. +focusNode :: Eq a => a -> ListZipper a -> Maybe (ListZipper a) +focusNode a list = + (=<<) (`focus` list) index + where + index = List.findIndex (a ==) (toList list) + +-- | Insert node to right side and keep current focus. +insertLeft :: a -> ListZipper a -> ListZipper a +insertLeft a (ListZipper ls rs) = ListZipper (a:ls) rs +-- | Insert node to left side and keep current focus. +-- Except it will focus first element when list is empty. +insertRight :: a -> ListZipper a -> ListZipper a +insertRight a (ListZipper ls (r:rs)) = ListZipper ls (r:a:rs) +insertRight a (ListZipper ls _) = ListZipper ls [a] +-- | Insert node to first and keep current focus. +insertFirst :: a -> ListZipper a -> ListZipper a +insertFirst a (ListZipper (l:ls) rs) = ListZipper ((l:ls) ++ [a]) rs +insertFirst a (ListZipper _ rs) = ListZipper [a] rs +-- | Insert node to last end and keep current focus. +insertLast :: a -> ListZipper a -> ListZipper a +insertLast a (ListZipper ls (r:rs)) = ListZipper ls ((r:rs) ++ [a]) +insertLast a (ListZipper ls _) = ListZipper ls [a] + +-- | Delete current node and focus focus right node. +delete :: ListZipper a -> Maybe (ListZipper a) +delete (ListZipper ls (_:rs)) = Just $ ListZipper ls rs +delete _ = Nothing +-- | Delete left node and keep current focus. +deleteLeft :: ListZipper a -> Maybe (ListZipper a) +deleteLeft (ListZipper (_:ls) rs) = Just $ ListZipper ls rs +deleteLeft _ = Nothing +-- | Delete right node and keep current focus. +deleteRight :: ListZipper a -> Maybe (ListZipper a) +deleteRight (ListZipper ls (r:_:rs)) = Just $ ListZipper ls (r:rs) +deleteRight _ = Nothing +-- | Delete first node and keep current focus. +deleteFirst :: ListZipper a -> Maybe (ListZipper a) +deleteFirst (ListZipper (l:ls) rs) = Just $ ListZipper (init (l:ls)) rs +deleteFirst (ListZipper [] (_:rs)) = Just $ ListZipper [] rs +deleteFirst _ = Nothing +-- | Delete last node and keep current focus. +deleteLast :: ListZipper a -> Maybe (ListZipper a) +deleteLast (ListZipper ls (r:rs)) = Just $ ListZipper ls (init (r:rs)) +deleteLast (ListZipper (_:ls) rs) = Just $ ListZipper ls rs +deleteLast _ = Nothing +-- | Delete other node except current node. +deleteOthers :: ListZipper a -> Maybe (ListZipper a) +deleteOthers (ListZipper _ (r:_)) = Just $ ListZipper [] [r] +deleteOthers _ = Nothing + +-- | Delete specify node. +deleteNode :: Eq a => a -> ListZipper a -> Maybe (ListZipper a) +deleteNode a (ListZipper ls rs) + | isJust leftIndex + = Just $ ListZipper (deleteAt (fromJust leftIndex) ls) rs + | isJust rightIndex + = Just $ ListZipper ls (deleteAt (fromJust rightIndex) rs) + | otherwise + = Nothing + where + leftIndex = List.findIndex (a ==) ls + rightIndex = List.findIndex (a ==) rs + +-- | Swap with left node, and focus swap node. +swapLeft :: ListZipper a -> Maybe (ListZipper a) +swapLeft (ListZipper (l:ls) (r:rs)) = Just $ ListZipper (r:ls) (l:rs) +swapLeft (ListZipper (l:ls) _) = Just $ ListZipper ls [l] +swapLeft _ = Nothing +-- | Swap with right node, and focus swap node. +swapRight :: ListZipper a -> Maybe (ListZipper a) +swapRight (ListZipper ls (r:x:rs)) = Just $ ListZipper ls (x:r:rs) +swapRight _ = Nothing + +-- | Replace current node. +replace :: a -> ListZipper a -> Maybe (ListZipper a) +replace a (ListZipper ls (_:rs)) = Just $ ListZipper ls (a:rs) +replace _ _ = Nothing + +-- | Get length. +length :: ListZipper a -> Int +length (ListZipper ls rs) = Prelude.length ls + Prelude.length rs +-- | Get current index. +currentIndex :: ListZipper a -> Int +currentIndex (ListZipper ls _) = Prelude.length ls +-- | Get left index. +leftIndex :: ListZipper a -> Int +leftIndex = pred . currentIndex +-- | Get right index. +rightIndex :: ListZipper a -> Int +rightIndex = succ . currentIndex +-- | Get first index. +firstIndex :: ListZipper a -> Int +firstIndex _ = 0 +-- | Get last index. +lastIndex :: ListZipper a -> Int +lastIndex = pred . Manatee.Toolkit.Data.ListZipper.length diff --git a/Manatee/Toolkit/Data/SetList.hs b/Manatee/Toolkit/Data/SetList.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Data/SetList.hs @@ -0,0 +1,79 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Data.SetList where + +import Data.Set (Set) +import Manatee.Toolkit.General.Set + +import qualified Data.Set as Set + +data Ord a => SetList a = + SetList {listCounter :: Int -- counter for build unique id use in Set + ,listSet :: Set a} + +-- | New SetList. +setListNew :: Ord a => SetList a +setListNew = SetList 0 Set.empty + +-- | Get counter for SetList. +setListGetCounter :: Ord a => SetList a -> Int +setListGetCounter = listCounter + +-- | Increase counter and then get new counter. +-- Return new setList and new id. +setListGetNewCounter :: Ord a => SetList a -> (Int, SetList a) +setListGetNewCounter sl = (newId, newSetList) + where newSetList = setListIncCounter sl + newId = setListGetCounter newSetList + +-- | Set counter. +setListSetCounter :: Ord a => SetList a -> Int -> SetList a +setListSetCounter sl c = sl {listCounter = c} + +-- | Increase counter. +setListIncCounter :: Ord a => SetList a -> SetList a +setListIncCounter sl@(SetList {listCounter = c}) = sl {listCounter = succ c} + +-- | Add new node in SetList. +setListAddNode :: Ord a => SetList a -> a -> SetList a +setListAddNode sl@(SetList {listSet = s}) e = sl {listSet = Set.insert e s} + +-- | Remove node from SetList. +setListRemoveNode :: Ord a => SetList a -> a -> SetList a +setListRemoveNode sl@(SetList {listSet = s}) e = sl {listSet = Set.delete e s} + +-- | Remove others node except current one. +setListRemoveOthersNode :: Ord a => SetList a -> a -> SetList a +setListRemoveOthersNode sl = setListAddNode (setListEmptySet sl) + +-- | Find some node and return. +setListGetNode :: Ord a => SetList a -> (a -> Bool) -> Maybe a +setListGetNode = maybeFindMin . listSet + +-- | Like `setListGetNode`, but use Monad wrap search condition. +setListGetNodeM :: (Ord a, Monad m) => SetList a -> (a -> m Bool) -> m (Maybe a) +setListGetNodeM = maybeFindMinM . listSet + +-- | Empty List, but keep counter. +setListEmptySet :: Ord a => SetList a -> SetList a +setListEmptySet sl = sl {listSet = Set.empty} + +-- | Convert from SetList to list. +setListGetList :: Ord a => SetList a -> [a] +setListGetList (SetList {listSet = s}) = Set.toList s diff --git a/Manatee/Toolkit/Data/Unique.hs b/Manatee/Toolkit/Data/Unique.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Data/Unique.hs @@ -0,0 +1,110 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Data.Unique where + +import Control.Arrow +import Data.List +import Manatee.Toolkit.General.Basic +import Manatee.Toolkit.General.FilePath +import Manatee.Toolkit.General.List +import System.FilePath + +import qualified Data.Map as M + +-- | Unique file path list. +unique :: [FilePath] -> [(FilePath, FilePath)] +unique filePathList = + -- Zip file name and different directory name. + zip fnl + -- Get file path. + $ map snd + -- To list. + $ M.toList + $ M.fromList + -- Swap filepath and page index. + $ map swap + -- Get different directory name for unique. + $ concatMap uniqueDiff + -- Group page name with same filename. + (uniqueGroup (pairPred fpl) uniquePick) + -- Trailing path separator when filepath is directory name. + where fpl = map dropTrailingPathSeparator filePathList + fnl = map takeFileNameExceptRoot fpl + +-- | Different file path. +uniqueDiff :: [(FilePath, Int)] -> [(FilePath, Int)] +-- Don't do different when just alone file path. +uniqueDiff (xs:[]) = [first (const "") xs] +-- Generate minimum different directory between filepathes. +uniqueDiff list = concatMap uniqueDiffInternal (uniqueGroup list uniquePick_) + +-- | Internal function for different file path. +uniqueDiffInternal :: [(FilePath, Int)] -> [(FilePath, Int)] +uniqueDiffInternal [] = [] +-- Just add previous directory when alone file path. +uniqueDiffInternal (xs:[]) = [first getUpperDirectoryName xs] +-- Generate minimum different directory between filepathes. +uniqueDiffInternal list = + map (\(a,b) -> (uniqueMinDiffDir a (uniqueCommon $ map fst list), b)) list + +-- | Get min diff directory. +uniqueMinDiffDir :: FilePath -> FilePath -> FilePath +uniqueMinDiffDir filepath common = + addTrailingPathSeparator $ take (length filepath - length common) filepath + +-- | Group file path with same file name. +uniqueGroup :: [(FilePath, Int)] -> ([(FilePath, Int)] -> [(FilePath, Int)]) -> [[(FilePath, Int)]] +uniqueGroup [] _ = [] +uniqueGroup list@(_:[]) _ = group list +uniqueGroup list@(_:xs) f = pl : uniqueGroup ys f + where + pl = f list + ys = if length pl == 1 + -- If pick list just have one element, get remain elements. + then xs + -- Otherwise delete pick list from current list. + else (\\) list pl + +-- | Pick same file name from list. +uniquePick :: [(FilePath, Int)] -> [(FilePath, Int)] +uniquePick [] = [] +uniquePick (x:[]) = [x] +uniquePick (x@(a,_):y@(b,_):ys) + | takeFileName a == takeFileName b + = x : uniquePick (y:ys) + | otherwise + = uniquePick (x : ys) + +-- | Pick same path part from list. +uniquePick_ :: [(FilePath, Int)] -> [(FilePath, Int)] +uniquePick_ [] = [] +uniquePick_ (x:[]) = [x] +uniquePick_ (x@(a,_):y@(b,_):ys) + | fileIntersectEnd a b == takeFileName a + = uniquePick_ (x : ys) + | otherwise + = x : uniquePick_ (y:ys) + +-- | Get common path with all file path. +uniqueCommon :: [FilePath] -> FilePath +uniqueCommon [] = [] +-- Remove otiose characters before path separator. +uniqueCommon (x:[]) = dropWhile (/= pathSeparator) x +-- Compare all element in list for get common part. +uniqueCommon (x:y:ys) = uniqueCommon (intersectEnd x y : ys) diff --git a/Manatee/Toolkit/GConf/GConf.hs b/Manatee/Toolkit/GConf/GConf.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/GConf/GConf.hs @@ -0,0 +1,39 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.GConf.GConf where + +import Data.Char +import System.Gnome.GConf + +data BackgroundOption = None + | Wallpaper + | Centered + | Scaled + | Stretched + | Zoom + | Spanned + deriving (Show, Ord, Eq, Read) + +-- | Set background, just for gnome. +setDesktopBackground :: FilePath -> Int -> BackgroundOption -> IO () +setDesktopBackground imagePath opacity option = do + conf <- gconfGetDefault + gconfSet conf "/desktop/gnome/background/picture_filename" imagePath + gconfSet conf "/desktop/gnome/background/picture_opacity" opacity + gconfSet conf "/desktop/gnome/background/picture_options" (map toLower (show option)) diff --git a/Manatee/Toolkit/General/Arrow.hs b/Manatee/Toolkit/General/Arrow.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Arrow.hs @@ -0,0 +1,55 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.Arrow where + +import Control.Arrow +import Manatee.Toolkit.General.Basic + +-- | Arrow with delicate. +dupA :: Arrow a => a b (b, b) +dupA = arr dup + +-- | Arrow with curry. +curryA :: Arrow a => a ((b, c) -> d) (b -> c -> d) +curryA = arr curry + +-- | Arrow with uncurry. +uncurryA :: Arrow a => a (b -> c -> d) ((b, c) -> d) +uncurryA = arr uncurry + +-- | Arrow with swap. +swapA :: Arrow a => a (b, c) (c, b) +swapA = arr swap + +-- | Arrow with liftM2. +liftA2 :: Arrow a => (b -> c -> d) -> a e b -> a e c -> a e d +liftA2 f g h = g &&& h >>> arr (uncurry f) + +-- | Arrow with id. +idA :: Arrow a => a b b +idA = arr id + +-- | Fst with arrow. +fstA :: Arrow a => a (b, c) b +fstA = arr fst + +-- | Snd with arrow. +sndA :: Arrow a => a (b, c) c +sndA = arr snd + diff --git a/Manatee/Toolkit/General/Basic.hs b/Manatee/Toolkit/General/Basic.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Basic.hs @@ -0,0 +1,117 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.Basic where + +import Control.Arrow + +import Control.Monad hiding (filterM, mapM) + +-- | Swap tuple. +swap :: (a,b) -> (b,a) +swap (a,b) = (b,a) + +-- | Try to swap tuple. +ifSwap :: Bool -> (a, a) -> (a, a) +ifSwap b x = + if b then swap x else x + +-- | Duplicate current value with tuple. +dup :: a -> (a, a) +dup a = (a,a) + +-- | Transform Int to Double +integralToDouble :: Integral a => a -> Double +integralToDouble v = + fromIntegral v :: Double + +-- | Integer to Int. +integerToInt :: Integer -> Int +integerToInt t = + fromInteger t :: Int + +-- | Flip >> +(<<) :: Monad m => m b -> m a -> m b +(<<) = flip (>>) + +-- | Like LiftM2, but make function at middle of two arguments. +liftM2' :: Monad m => m a -> (a -> b -> c) -> m b -> m c +liftM2' xs f = liftM2 f xs + +liftM2_ :: Monad m => (a -> b -> c) -> m a -> m b -> m () +liftM2_ f x y = liftM2 f x y >> return () + +-- | If monad. +ifM :: Monad m => m Bool -> m a -> m a -> m a +ifM f g h = f >>= \b -> if b then g else h + +-- | If monad. +ifF :: Monad m => a -> (a -> m Bool) -> (a -> m b) -> (a -> m b) -> m b +ifF a f g h = f a >>= \b -> if b then g a else h a + +-- | When monad. +whenM :: Monad m => m Bool -> m () -> m () +whenM f g = f >>= \x -> when x g + +-- | Unless monad. +unlessM :: Monad m => m Bool -> m () -> m () +unlessM f g = f >>= \x -> unless x g + +-- | Zip' +zip' :: a -> b -> (a, b) +zip' a b = (a, b) + +-- | ZipM' +zipM' :: Monad m => m a -> m b -> m (a, b) +zipM' = liftM2 zip' + +-- | FirstMap. +firstMap :: (b -> c) -> [(b, d)] -> [(c, d)] +firstMap = map . first + +-- | Zip with map. +zipMap :: (a -> b, a -> c) -> a -> (b, c) +zipMap (g, h) s = (g s, h s) + +-- | Unzip with map. +unzipMap :: (a -> (b,c)) -> (a -> b, a -> c) +unzipMap h = (fst . h, snd . h) + +-- | Trace. +trace :: ((a, c) -> (b, c)) -> a -> b +trace f b = c + where (c, d) = f (b, d) + +-- | Floor to multiple. +floorToMultiple :: Integral a => a -> a -> a +floorToMultiple x y = x - x `mod` y + +-- | Like a switch statement, and less cluttered than if else if +-- +-- > cond [ (t1,a1), (t2,a2), ... ] +cond :: Monad m => [(Bool, m ())] -> m () +cond [] = return () +cond ((True,action) : _) = action +cond ((False,_) : rest) = cond rest + +-- | Like a switch statement, and less cluttered than if else if +-- +-- > condM [ (t1,a1), (t2,a2), ... ] +condM :: Monad m => [(m Bool, m ())] -> m () +condM [] = return () +condM ((test,action) : rest) = test >>= \t -> if t then action else condM rest diff --git a/Manatee/Toolkit/General/ByteString.hs b/Manatee/Toolkit/General/ByteString.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/ByteString.hs @@ -0,0 +1,62 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE OverloadedStrings #-} +module Manatee.Toolkit.General.ByteString where + +import Data.ByteString (ByteString) +import Data.ByteString.Internal (isSpaceWord8, c2w) +import System.FilePath (pathSeparator) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B + +-- | Like `System.FilePath.combine`, except for ByteString. +combine :: ByteString -> ByteString -> ByteString +combine dir file + | B.isSuffixOf separator dir + = B.concat [dir, file] + | otherwise + = B.concat [dir, separator, file] + where separator = B.singleton pathSeparator + +-- | Is blank string. +isBlankByteString :: ByteString -> Bool +isBlankByteString = + BS.all isSpaceWord8 + +-- | Wraps a list of words to a list of lines of words of a particular width. +wrapLine :: Int -> [ByteString] -> [[ByteString]] +wrapLine width = wrap 0 [] + where wrap :: Int -> [ByteString] -> [ByteString] -> [[ByteString]] + wrap 0 [] (w:ws) + | B.length w + 1 > width + = wrap (B.length w) [w] ws + wrap col line (w:ws) + | col + B.length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + B.length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +-- | Like `words`, but just split with first space char, don't truncates rest space char. +splitWords :: ByteString -> [ByteString] +splitWords bytestring = + map (BS.map (\x -> if isSpaceWord8 x then c2w ' ' else x)) $ BS.splitWith isSpaceWord8 bytestring diff --git a/Manatee/Toolkit/General/Concurrent.hs b/Manatee/Toolkit/General/Concurrent.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Concurrent.hs @@ -0,0 +1,27 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.Concurrent where + +import Control.Concurrent +import Control.Monad + +-- | Build new thread do *forever*. +forkForever :: IO a -> IO () +forkForever action = + forkIO (forever action) >> return () diff --git a/Manatee/Toolkit/General/DBus.hs b/Manatee/Toolkit/General/DBus.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/DBus.hs @@ -0,0 +1,158 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE OverloadedStrings #-} +module Manatee.Toolkit.General.DBus where + +import Control.Arrow (first) +import DBus.Bus +import DBus.Client +import DBus.MatchRule +import DBus.Message (messageBody) +import DBus.Types +import Data.Maybe (fromMaybe) +import Data.Text.Lazy hiding (zip, map, head) + +import qualified DBus.Client as DC +import qualified DBus.Message as DM +import qualified DBus.NameReservation as DNR +import qualified Data.Map as M + +type ObjectPathText = Text +type MemberNameText = Text +type InterfaceNameText = Text +type BusNameText = Text +type SignatureText = Text + +-- | Member name prefix for some name that beginning with digit. +memberNamePrefix :: Text +memberNamePrefix = "member_" + +-- | Handy function for build DBus message signal. +mkMessageSignal :: ObjectPathText + -> MemberNameText + -> InterfaceNameText + -> BusNameText + -> [Variant] + -> DM.Signal +mkMessageSignal oPath mName iName bName = + DM.Signal (mkObjectPath_ oPath) + (mkMemberName_ mName) + (mkInterfaceName_ iName) + (mkBusName bName) + +-- | Build system bus client. +mkSystemClient :: IO Client +mkSystemClient = mkClient =<< getSystemBus + +-- | Build system bus client with name. +mkSystemClientWithName :: Text -> IO Client +mkSystemClientWithName clientName = do + client <- mkSystemClient + requestName' client clientName [] + return client + +-- | Build session bus client. +mkSessionClient :: IO Client +mkSessionClient = mkClient =<< getSessionBus + +-- | Build session bus client with name. +mkSessionClientWithName :: Text -> IO Client +mkSessionClientWithName clientName = do + client <- mkSessionClient + requestName' client clientName [] + return client + +-- | Build starter bus client. +mkStarterClient :: IO Client +mkStarterClient = mkClient =<< getStarterBus + +-- | Request name. +requestName' :: Client -> BusNameText -> [DNR.RequestNameFlag] -> IO DNR.RequestNameReply +requestName' client name = requestName client (mkBusName_ name) + +-- | Build LoaclObject with Text information, handy!. +mkLocalObject :: [(InterfaceNameText, [(MemberNameText, Member)])] -> LocalObject +mkLocalObject list = LocalObject $ M.fromList $ zip interfaceName interface + where interfaceNameList = fst $ unzip list -- [InterfaceNameText] + interfaceList = snd $ unzip list -- [[(MemberNameText, Member)]] + interfaceName = map mkInterfaceName_ interfaceNameList -- [interfaceName] + interface = map (Interface . M.fromList . map (first mkMemberName_)) interfaceList -- [Interface] + +-- | Like `export`, but instead ObjectPath with ObjectPathText. +export' :: Client -> ObjectPathText -> LocalObject -> IO () +export' client path = export client (mkObjectPath_ path) + +-- | Export LocalObject. +exportLocalObject :: Client -> ObjectPathText -> [(InterfaceNameText, [(MemberNameText, Member)])] -> IO () +exportLocalObject client path info = export' client path (mkLocalObject info) + +-- | Build MatchRule. +mkMatchRule :: Maybe MessageType + -> BusNameText + -> InterfaceNameText + -> MemberNameText + -> ObjectPathText + -> BusNameText + -> [ParameterValue] + -> MatchRule +mkMatchRule mType sender interface member path dest = + MatchRule mType + (mkBusName sender) + (mkInterfaceName interface) + (mkMemberName member) + (mkObjectPath path) + (mkBusName dest) + +-- | Create Signal Memeber. +mkSignalMember :: SignatureText -> Member +mkSignalMember = + DC.Signal . mkSignature_ + +-- | Create Method Member. +mkMethodMember :: SignatureText -> SignatureText -> (MethodCall -> IO ()) -> Member +mkMethodMember input output = + DC.Method (mkSignature_ input) (mkSignature_ output) + +-- | Pack digit member name for protocol. +packDigitMemberName :: Text -> Text +packDigitMemberName name = + memberNamePrefix `append` name + +-- | Unpack digit member name for protocol. +unpackDigitMemberName :: Text -> Text +unpackDigitMemberName = + replace memberNamePrefix empty + +-- | Check specify bus name whether exist. +-- This function very useful to check dbus process whether exist +-- by check bus name in dbus list. +isBusNameExist :: Text -> IO Bool +isBusNameExist busName = do + -- Request a list of connected clients from the bus + client <- mkSessionClient + reply <- callProxyBlocking_ client dbus "ListNames" [] [] + + -- Get bus name list. + let names = fromMaybe [] (fromArray =<< fromVariant (head $ messageBody reply)) + + -- Whether dbus name exist? + return (busName `elem` names) + where + dbus :: Proxy + dbus = Proxy (RemoteObject "org.freedesktop.DBus" "/org/freedesktop/DBus") "org.freedesktop.DBus" diff --git a/Manatee/Toolkit/General/Either.hs b/Manatee/Toolkit/General/Either.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Either.hs @@ -0,0 +1,40 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.Either where + +-- | Map left. +mapLeft :: (t1 -> a) -> Either t1 t -> Either a t +mapLeft _ (Right a) = Right a +mapLeft f (Left a) = Left (f a) + +-- | Map right. +mapRight :: (t1 -> b) -> Either t t1 -> Either t b +mapRight _ (Left a) = Left a +mapRight f (Right a) = Right (f a) + +-- | Apply either left. +applyEitherLeft :: (a -> c) -> Either a b -> Maybe c +applyEitherLeft f (Left l) = Just $ f l +applyEitherLeft _ (Right _) = Nothing + +-- | Apply either right. +applyEitherRight :: (b -> c) -> Either a b -> Maybe c +applyEitherRight _ (Left _) = Nothing +applyEitherRight f (Right r) = Just $ f r + diff --git a/Manatee/Toolkit/General/FilePath.hs b/Manatee/Toolkit/General/FilePath.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/FilePath.hs @@ -0,0 +1,118 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.FilePath where + +import Data.Array +import Data.List +import Manatee.Toolkit.General.List +import System.FilePath +import System.Process +import Text.Regex.TDFA + +-- | Intersect two file path from end. +fileIntersectEnd :: FilePath -> FilePath -> FilePath +fileIntersectEnd xs ys = + -- Remove otiose characters before path separator + -- if have previous directory. + case findIndex (== pathSeparator) zs of + Just i -> drop (succ i) zs + Nothing -> zs + -- Get common string from end. + where zs = intersectEnd xs ys + +-- | Get upper directory name. +getUpperDirectoryName :: FilePath -> FilePath +getUpperDirectoryName = takeFileName . dropTrailingPathSeparator . dropFileName + +-- | Get upper directory path. +getUpperDirectory :: FilePath -> FilePath +getUpperDirectory = dropFileName . dropTrailingPathSeparator + +-- | Try to expand file path that start with backtick. +-- Just return original one when file path not start with backtick. +expandBacktickFilePath :: FilePath -> IO FilePath +expandBacktickFilePath filepath + | filepath =~ "^~.*" :: Bool + = expandFilePath filepath + | otherwise + = return filepath + +-- | Expand file name, +-- including expand backtick and fill blank in filepath. +expandFileName :: FilePath -> IO FilePath +expandFileName = expandBacktickFilePath . fillFilePathBlank + +-- | Expand file path. +expandFilePath :: FilePath -> IO FilePath +expandFilePath filepath = fmap (head . lines) (readProcess "bash" ["-c", "echo " ++ filepath] []) + +-- | Fill blank in filepath with `\\ `. +fillFilePathBlank :: FilePath -> FilePath +fillFilePathBlank filepath = replaceRegex filepath "[^\\][ ]+" "\\ " + where + -- Replace regex match string with target string. + replaceRegex string regex target = do + -- Test match. + let matchTextList = string =~ regex :: [MatchText String] + if null matchTextList + then + -- Return original string if match nothing. + string + else do + -- Replace regex match sting with target string. + let indexList = map (snd . head . elems) matchTextList + replaceMatchText indexList target string + -- Replace match text. + replaceMatchText indexList target string + -- Return current string when list null. + | null indexList + = string + -- Continue replace. + | otherwise + = matchBefore ++ newMatch ++ replaceMatchText newList target matchAfter + where + (matchOffset, matchLength) = head indexList + (matchBefore, afterString) = splitAt matchOffset string + (match, matchAfter) = splitAt matchLength afterString + newMatch = head match : target + adjust = matchOffset + matchLength + newList = map (\(a,b) -> (a - adjust, b)) $ tail indexList + +-- | Filter dot directory. +filterDotDirectory :: [FilePath] -> [FilePath] +filterDotDirectory = filter notDotDirectory + +-- | Filter dot directory apply list. +filterDotDirectoryApply :: (a -> FilePath) -> [a] -> [a] +filterDotDirectoryApply = + filter . (notDotDirectory .) + +-- | File not directory. +notDotDirectory :: FilePath -> Bool +notDotDirectory = (`notElem` [".", ".."]) + +-- | Like takeFileName, but won't return empty when filepath is root path '/' +-- Instead return '/'. +takeFileNameExceptRoot :: FilePath -> FilePath +takeFileNameExceptRoot filepath + | filepath == "/" + = filepath + | otherwise + = takeFileName filepath + diff --git a/Manatee/Toolkit/General/Functor.hs b/Manatee/Toolkit/General/Functor.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Functor.hs @@ -0,0 +1,34 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE FlexibleContexts #-} +module Manatee.Toolkit.General.Functor where + +import Control.Arrow () + +(<<<=) :: Functor f => (b -> c) -> (a -> f b) -> a -> f c +(<<<=) = (.) . fmap + +(=>>>) :: Functor f => (a -> f b) -> (b -> c) -> a -> f c +(=>>>) = flip (fmap . fmap) + +(<<=<) :: Functor f => (b -> f c) -> (a -> b) -> a -> f c +(<<=<) = (.) + +(>=>>) :: Functor f => (a -> b) -> (b -> f c) -> a -> f c +(>=>>) = flip (<<=<) diff --git a/Manatee/Toolkit/General/List.hs b/Manatee/Toolkit/General/List.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/List.hs @@ -0,0 +1,206 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE TransformListComp #-} +module Manatee.Toolkit.General.List where + +import Control.Arrow +import Control.Monad +import Data.List +import Data.Maybe +import Data.Monoid +import Manatee.Toolkit.General.Basic + +-- | Return element of list with given index. +(?!) :: [a] -> Int -> Maybe a +[] ?! _ = Nothing +xs ?! n + | n < 0 + = Nothing + | n >= length xs + = Nothing + | otherwise + = listToMaybe . drop n $ xs + +-- | Intersect element with list from end, don't including front or middle element. +-- Return null if haven't intersection element. +intersectEnd :: Ord a => [a] -> [a] -> [a] +intersectEnd xs ys = reverse $ intersectFront (reverse xs) (reverse ys) + +-- | Intersect element with list from front, don't including end or middle element. +-- Return null if haven't intersection element. +intersectFront :: Ord a => [a] -> [a] -> [a] +intersectFront xs ys = [x | (x,y) <- zip xs ys, then takeWhile by x == y] + +-- | Delay list with given start index. +delay :: Int -> [a] -> [Int] +delay n (_:xs) = n : delay (n + 1) xs +delay _ _ = [] + +-- | Index of list +listIndex :: [a] -> [Int] +listIndex = delay 0 + +-- | Pair with list index. +pairPred :: [a] -> [(a, Int)] +pairPred xs = zip xs $ listIndex xs + +-- | Different two list, and two lists must have same length. +-- otherwise throw a error. +different :: Ord a => [a] -> [a] -> [a] +different (x:xs) (y:ys) + | x == y = different xs ys + | otherwise = x : different xs ys +different [] [] = [] +different _ _ = error "different: lists not the same length!" + +-- | Do action when list not empty. +unlessNull :: [a] -> IO () -> IO () +unlessNull = unless . null + +-- | not . null +has :: [a] -> Bool +has = not . null + +-- | Head monad list. +headM :: Monad m => m [a] -> m a +headM = liftM head + +-- | Last monad list. +lastM :: Monad m => m [a] -> m a +lastM = liftM last + +-- | ConcatM. +concatM :: Monad m => m [a] -> m [a] -> m [a] +concatM = liftM2 (++) + +-- | Replace n'th element (count from 0) in `xs` to `x` +replaceAt :: Int -> [a] -> a -> [a] +replaceAt n xs x = take n xs ++ x : drop (n + 1) xs + +-- | Split list with given condition. +splitWith :: (a -> Bool) -> [a] -> [[a]] +splitWith _ [] = [] +splitWith f xs = fst tuple : splitWith f (dropWhile f $ snd tuple) + where tuple = break f xs + +-- | concatMapM. +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = liftM concat $ forM xs f + +-- | Like find, but works with monadic computation instead of pure function. +-- In expression `find FUNCTION list`, if FUNCTION is "IO Bool", you can use +-- `findM FUNCTION list` to instead. +findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) +findM _ [] = return Nothing +findM f (x:xs) = ifM (f x) (return $ Just x) (findM f xs) + +-- | Apply two monad function with list. +-- And return new monad tuples list. +apply2M :: Monad m => [a] -> (a -> m b) -> (a -> m c) -> m [(b, c)] +apply2M xs f g = forM xs (\x -> zipM' (f x) (g x)) + +-- | Apply two function with list. +-- And return new tuples list. +apply2 :: [a] -> (a -> b) -> (a -> c) -> [(b, c)] +apply2 xs f g = map (f &&& g) xs + +-- | Partition list. +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = return ([], []) +partitionM f (x:xs) = + liftM2 mappend (ifM (f x) (return ([x], [])) (return ([], [x]))) (partitionM f xs) + +-- | Like `init`, but accept empty list. +init_ [] = [] +init_ xs = init xs + +-- | Like `foldl1`, but accept empty list. +foldl1_ _ [] = [] +foldl1_ f xs = foldl1 f xs + +-- | Find next element. +findNext :: (a -> Bool) -> [a] -> Maybe a +findNext x = listToMaybe . drop 1 . dropWhile (not . x) + +-- | Find next cycle. +findNextCycle :: (a -> Bool) -> [a] -> Maybe a +findNextCycle _ [] = Nothing +findNextCycle f list = + case dropWhile (not . f) list of + [] -> Nothing -- `Nothing` when element not found in list + [_] -> Just $ head list -- Get head when element at last of list + ls -> listToMaybe $ drop 1 ls -- Otherwise get next element in list + +-- | Find previous cycle. +findPrevCycle :: (a -> Bool) -> [a] -> Maybe a +findPrevCycle _ [] = Nothing +findPrevCycle f list + | length dropList == length list + = Nothing -- `Nothing` when element not found in list + | null dropList + = Just $ last list -- Get last when element at first position of list + | otherwise + = Just $ last dropList -- Otherwise get previous element in list + where dropList = takeWhile (not . f) list + +-- | Delete at. +deleteAt :: Int -> [a] -> [a] +deleteAt _ [] = [] +deleteAt i xs + | i < 0 + = [] + | i >= length xs + = [] + | otherwise + = (\(a, b) -> a ++ tail b) (splitAt i xs) + +-- | Get last one. +getLast :: [a] -> Maybe a +getLast [] = Nothing +getLast xs = Just $ last xs + +-- | Get first one. +getFirst :: [a] -> Maybe a +getFirst [] = Nothing +getFirst xs = Just $ head xs + +-- | Zip with list index. +zipWithIndex :: [a] -> (a -> Int -> c) -> [c] +zipWithIndex xs f = zipWith f xs [0..] + +-- | Zip with list index. +zipWithIndexM :: Monad m => [a] -> (a -> Int -> m c) -> m [c] +zipWithIndexM xs f = zipWithM f xs [0..] + +-- | Zip with list index. +zipWithIndexM_ :: Monad m => [a] -> (a -> Int -> m c) -> m () +zipWithIndexM_ xs f = zipWithM_ f xs [0..] + +-- | Like 'concatMap', but don't concat last one. +addMap :: ([a] -> [a]) -> [[a]] -> [a] +addMap _ [] = [] +addMap _ [x] = x +addMap f xs = concatMap f (init xs) ++ last xs + +-- | Like 'insert' but just insert unique element. +insertUnique :: Ord a => a -> [a] -> [a] +insertUnique x xs + | x `elem` xs = xs + | otherwise = insert x xs + diff --git a/Manatee/Toolkit/General/Map.hs b/Manatee/Toolkit/General/Map.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Map.hs @@ -0,0 +1,32 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.Map where + +import Data.Map (Map) + +import qualified Data.Map as M + +-- | Find min match one. +findMinMatch :: Ord k => Map k a -> (k -> a -> Bool) -> Maybe (k, a) +findMinMatch map fun = match + where filterMap = M.filterWithKey fun map + match = if M.null filterMap + then Nothing + else Just $ M.findMin filterMap + diff --git a/Manatee/Toolkit/General/Maybe.hs b/Manatee/Toolkit/General/Maybe.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Maybe.hs @@ -0,0 +1,75 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.Maybe where + +import Control.Monad +import Data.Maybe + +-- | Indicate error or return a. +-- This function for replace `fromJust`, expression `fromJust x` is bad +-- when `x` is `Nothing`, so `maybeError` allowed you customize error +-- information. +maybeError :: Maybe a -> String -> a +maybeError m str = fromMaybe (error $ "Just crash : " ++ str) m + +-- | Maybe boolean. +maybeBool :: Maybe a -> Bool -> Bool +maybeBool (Just _) b = b +maybeBool Nothing b = not b + +-- | Maybe alternative. +maybeAlternate :: Maybe a -> a -> a +maybeAlternate = flip fromMaybe + +-- | Maybe alternative monad. +maybeAlternateM :: Monad m => Maybe a -> m a -> m a +maybeAlternateM x = maybeBranch x return + +-- | Apply maybe. +maybeApply :: Maybe a -> (a -> b) -> Maybe b +maybeApply = flip fmap + +-- | Apply maybe with monad. +maybeApplyM :: Monad m => Maybe a -> (a -> m b) -> m (Maybe b) +maybeApplyM m f = maybe (return Nothing) (liftM Just . f) m + +-- | Maybe transform monad. +(?>=>) :: Monad m => Maybe a -> (a -> m (Maybe b)) -> m (Maybe b) +m ?>=> f = maybe (return Nothing) f m + +-- | +(>?>=>) :: Monad m => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b) +g >?>=> f = g >>= (?>=> f) + +-- | Maybe tranform (). +(?>=) :: Monad m => Maybe a -> (a -> m ()) -> m () +m ?>= f = maybe (return ()) f m + +-- | +(>?>=) :: Monad m => m (Maybe a) -> (a -> m ()) -> m () +g >?>= f = g >>= (?>= f) + +-- | Maybe branch. +maybeBranch :: Monad m => Maybe a -> (a -> m b) -> m b -> m b +maybeBranch (Just a) f _ = f a +maybeBranch Nothing _ g = g + +-- | Maybe head. +maybeHead :: [a] -> Maybe a +maybeHead = listToMaybe diff --git a/Manatee/Toolkit/General/Misc.hs b/Manatee/Toolkit/General/Misc.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Misc.hs @@ -0,0 +1,60 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE FlexibleContexts #-} +module Manatee.Toolkit.General.Misc where + +import Data.List.Split (splitEvery) +import Data.Text.Lazy (Text, pack) +import Manatee.Toolkit.General.Basic +import Text.Printf +import Text.Regex.TDFA + +-- | Like =~ , but don't care case sensitive. +(=~^) :: (RegexLike Regex source1, RegexMaker Regex CompOption ExecOption source) => source1 -> source -> Bool +source =~^ regex = matchTest (makeRegexOpts (defaultCompOpt {caseSensitive = False}) defaultExecOpt regex) source + +-- | Show to text. +showText :: (Show a) => a -> Text +showText = pack . show + +-- | Format file size (bytes) to hummable size. +formatFileSizeForDisplay :: Integer -> String +formatFileSizeForDisplay size + | size < 2 ^ 10 = humanSize 1 ++ " B" + | size < 2 ^ 20 = humanSize (2 ^ 10) ++ " KB" + | size < 2 ^ 30 = humanSize (2 ^ 20) ++ " MB" + | size < 2 ^ 40 = humanSize (2 ^ 30) ++ " GB" + | size < 2 ^ 50 = humanSize (2 ^ 40) ++ " TB" + | size < 2 ^ 60 = humanSize (2 ^ 50) ++ " PB" + | size < 2 ^ 70 = humanSize (2 ^ 60) ++ " EB" + | size < 2 ^ 80 = humanSize (2 ^ 70) ++ " ZB" + | size < 2 ^ 90 = humanSize (2 ^ 80) ++ " YB" + | size < 2 ^ 100 = humanSize (2 ^ 90) ++ " NB" + | size < 2 ^ 110 = humanSize (2 ^ 100) ++ " DB" + where humanSize base = printf "%.1f" (integralToDouble size / base) :: String + +-- | Format float with specify precision. +formatFloatN :: Double -> Int -> Double +formatFloatN n d = + fromIntegral (floor $ n * 10 ^ d) / 10 ^ d + +-- | splitInt 1000000 => "1,000,000" +splitInt :: Int -> String +splitInt xx = init $ concatMap (++ ",") $ reverse $ splitEvery 3 (reverse $ show xx) + diff --git a/Manatee/Toolkit/General/Process.hs b/Manatee/Toolkit/General/Process.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Process.hs @@ -0,0 +1,71 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.Process where + +import Control.Concurrent +import Distribution.Simple.Program +import Distribution.Verbosity +import System.Process +import Text.Printf + +-- | Like `runProcessDefault`, but wait for child process terminate. +-- To avoid *zombie* child process. +-- You will got zombie child process when child process exist before +-- parent process, and parent process don't wait process. +runProcess_ :: FilePath -> [String] -> IO () +runProcess_ path args = + runProcessDefault path args + >>= \handle -> + forkIO (waitForProcess handle >> return ()) + >> return () + +-- | Like `runProcess`, but just accept path and args. +runProcessDefault :: FilePath -> [String] -> IO ProcessHandle +runProcessDefault path args = runProcess path args Nothing Nothing Nothing Nothing Nothing + +-- | Like run `runCommand`, but return IO () +runCommand_ :: String -> IO () +runCommand_ command = + runCommand command >> return () + +-- | Run external command and won't kill when parent process exit. +runExternalCommand :: String -> IO () +runExternalCommand command = + -- nohup for ignore all hup signal. + -- `> /dev/null 2>&1` redirect all stdout (1) and stderr (2) to `/dev/null` + -- that make external command running quiet! + runCommand_ $ printf "nohup %s > /dev/null 2>&1" command + +-- | Check command whether exist before exectue it. +-- Return reason when not found command. +execute :: String -> String -> Bool -> IO (Maybe String) +execute command args isShutup = do + path <- programFindLocation (simpleProgram command) normal + case path of + Just p -> do + runCommand_ (printf args p + ++ (if isShutup + -- `> /dev/null 2>&1` redirect all stdout (1) and stderr (2) to `/dev/null` + -- that make external command running quiet! + then " > /dev/null 2>&1" + else "")) + return Nothing + Nothing -> + return $ Just (printf "Cannot find command : %s" command) + diff --git a/Manatee/Toolkit/General/STM.hs b/Manatee/Toolkit/General/STM.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/STM.hs @@ -0,0 +1,82 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.STM where + +import Control.Applicative hiding (empty) +import Control.Concurrent.STM +import Manatee.Toolkit.General.Basic + +-- | Read an STM variable, apply some transformation function to it, +-- and write the transformed value back to the same variable. +modifyTVar :: TVar a -> (a -> a) -> STM () +modifyTVar var f = do + x <- readTVar var + writeTVar var (f x) + +-- | The IO version of `modifyTVar`. +modifyTVarIO :: TVar a -> (a -> a) -> IO () +modifyTVarIO var f = atomically $ modifyTVar var f + +-- | Replace TVar field. +replaceTVarField :: a -> a -> (a -> TVar b) -> IO () +replaceTVarField old new field = + readTVarIO (field new) >>= writeTVarIO (field old) + +-- | The IO version of `modifyTVar`. +modifyTVarIOM :: TVar a -> (a -> IO a) -> IO () +modifyTVarIOM var f = do + oldVar <- readTVarIO var + newVar <- f oldVar + writeTVarIO var newVar + +-- | The IO version of `writeTVar`. +writeTVarIO :: TVar a -> a -> IO () +writeTVarIO a b = atomically $ writeTVar a b + +-- | Ticket TVar. +tickTVar :: TVar Int -> STM Int +tickTVar x = readTVar x << modifyTVar x succ + +-- | Like `tickTVar` but output with io monad. +tickTVarIO :: TVar Int -> IO Int +tickTVarIO = atomically . tickTVar + +-- | Crock TVar. +crockTVar :: TVar Int -> STM Int +crockTVar x = readTVar x << modifyTVar x pred + +-- | Like `crockTVar` but output with io monad. +crockTVarIO :: TVar Int -> IO Int +crockTVarIO = atomically . crockTVar + +-- | Query TVar with some function. +queryTVarIO :: TVar a -> (a -> b) -> IO b +queryTVarIO var f = f <$> readTVarIO var + +-- | dupTChanIO +dupTChanIO :: TChan a -> IO (TChan a) +dupTChanIO = atomically . dupTChan + +-- | readTChanIO +readTChanIO :: TChan a -> IO a +readTChanIO = atomically . readTChan + +-- | writeTChanIO +writeTChanIO :: TChan a -> a -> IO () +writeTChanIO tchan a = atomically $ writeTChan tchan a diff --git a/Manatee/Toolkit/General/Seq.hs b/Manatee/Toolkit/General/Seq.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Seq.hs @@ -0,0 +1,92 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.Seq where + +import Data.Sequence (Seq, (><), (<|), (|>), findIndexL, adjust) + +import qualified Data.Sequence as Seq + +-- | Filter min. +filterMin :: (a -> Bool) -> Seq a -> Maybe a +filterMin f seq + | Seq.null filterSeq + = Nothing + | otherwise + = Just $ Seq.index filterSeq 0 + where filterSeq = Seq.filter f seq + +-- | Maybe index. +maybeIndex :: Seq a -> Int -> Maybe a +maybeIndex seq index + | index < min || index > max + = Nothing + | otherwise + = Just $ Seq.index seq index + where + min = 0 + max = Seq.length seq - 1 + +-- | Insert element in sequence. +insertAt :: Int -> a -> Seq a -> Seq a +insertAt n x xs = ys >< (x <| zs) + where + (ys, zs) = Seq.splitAt n xs + +-- | Delete element in sequence. +deleteAt :: Int -> Seq a -> Seq a +deleteAt n xs = ys >< Seq.drop 1 zs + where + (ys, zs) = Seq.splitAt n xs + +-- | Swap two element in sequence. +swap :: Int -> Int -> Seq a -> Seq a +swap deleteId insertId xs + | deleteId < min || deleteId > max = xs + | insertId < min || insertId > max = xs + | otherwise = zs + where + min = 0 + max = Seq.length xs - 1 + x = Seq.index xs deleteId + ys = deleteAt deleteId xs + zs = insertAt insertId x ys + +-- | Delete match element in sequence. +deleteMatch :: (a -> Bool) -> Seq a -> Seq a +deleteMatch f seq = newSeq + where index = findIndexL f seq + newSeq = case index of + Just i -> deleteAt i seq + Nothing -> seq + +-- | Replace element if found match. +tryReplace :: (a -> Bool) -> a -> Seq a -> Seq a +tryReplace f a seq = + case findIndexL f seq of + Just i -> adjust (const a) i seq + Nothing -> seq + +-- | Replace or add. +replaceOrAdd :: (a -> Bool) -> a -> Seq a -> Seq a +replaceOrAdd f a seq = + case findIndexL f seq of + -- Replace old value if found match + Just i -> adjust (const a) i seq + -- Otherwise add new value to end. + Nothing -> (|>) seq a diff --git a/Manatee/Toolkit/General/Set.hs b/Manatee/Toolkit/General/Set.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Set.hs @@ -0,0 +1,88 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.Set where + +import Control.Monad hiding (filterM, mapM) +import Data.Set + +import qualified Control.Monad as CM +import qualified Data.Set as Set + +-- | Find min element match in +maybeFindMin :: Ord a => Set a -> (a -> Bool) -> Maybe a +maybeFindMin s f + | Set.null set + = Nothing + | otherwise + = Just $ findMin set + where + set = Set.filter f s + +-- | maybeFindMinM. +maybeFindMinM :: (Ord a, Monad m) => Set a -> (a -> m Bool) -> m (Maybe a) +maybeFindMinM s f = do + set <- filterM f s + return $ + if Set.null set + then Nothing + else Just $ findMin set + +-- | filterM for Data. +filterM :: (Ord a, Monad m) => (a -> m Bool) -> Set a -> m (Set a) +filterM f xs = fromList `liftM` CM.filterM f (toList xs) + +-- | mapM for Data.Set +mapM :: (Ord a, Ord b, Monad m) => (a -> m b) -> Set a -> m (Set b) +mapM f sa = fromList `liftM` CM.mapM f (toList sa) + +-- | Next element +nextElement :: (Ord a) => Set a -> a -> Maybe a +nextElement set a + | hasA + = if Set.null nextSet + then Nothing + else Just $ findMin nextSet + | otherwise + = Nothing + where (_, hasA, nextSet) = splitMember a set + +-- | Prev element +prevElement :: (Ord a) => Set a -> a -> Maybe a +prevElement set a + | hasA + = if Set.null prevSet + then Nothing + else Just $ findMax prevSet + | otherwise + = Nothing + where (prevSet, hasA, _) = splitMember a set + +-- | Try find min element. +tryFindMin :: (Ord a) => Set a -> Maybe a +tryFindMin set + | Set.null set = Nothing + | otherwise = Just $ findMin set + +-- | Try find min element. +tryFindMax :: (Ord a) => Set a -> Maybe a +tryFindMax set + | Set.null set = Nothing + | otherwise = Just $ findMax set + + diff --git a/Manatee/Toolkit/General/State.hs b/Manatee/Toolkit/General/State.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/State.hs @@ -0,0 +1,106 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +module Manatee.Toolkit.General.State where + +import Control.Concurrent.STM +import Control.Monad.State +import Manatee.Toolkit.General.STM + +-- | Like `modify`, except use Monad wrap update function. +modifyM :: (Monad m, MonadTrans t, MonadState a (t m)) => (a -> m a) -> t m () +modifyM f = do + oldState <- get + newState <- lift $ f oldState + put newState + +-- | Like `modifyM`, +-- but add two functions filter new state and return value. +-- This is handy when function return result including state. +-- Example, state is (a,b), and function return (a,b,c), +-- then you can write: "result <- modifyM_ f fst snd". +modifyM_ :: (Monad m, MonadTrans t, MonadState a1 (t m)) => (a1 -> m a) -> (a -> a1) -> (a -> a2) -> t m a2 +modifyM_ f g h = do + oldState <- get + newState <- lift $ f oldState + put $ g newState + return $ h newState + +-- | Like `modifyM_`, except don't return value. +modifyM' :: (Monad m, MonadTrans t, MonadState a1 (t m)) => (a1 -> m a) -> (a -> a1) -> t m () +modifyM' f g = do + oldState <- get + newState <- lift $ f oldState + put $ g newState + +-- | Modify fst state of tuple. +modifyFst :: (MonadState (t, t1) m) => ((t, t1) -> t) -> m () +modifyFst f = do + oldState@(_, b) <- get + put (f oldState, b) + +-- | Modify snd state of tuple. +modifySnd :: (MonadState (t, t1) m) => ((t, t1) -> t1) -> m () +modifySnd f = do + oldState@(a, _) <- get + put (a, f oldState) + +-- | Like `modifyFst`, except use moand wrap function. +modifyFstM :: (Monad m, MonadTrans t1, MonadState (a, t) (t1 m)) => ((a, t) -> m a) -> t1 m () +modifyFstM f = do + oldState@(_, b) <- get + a' <- lift $ f oldState + put (a', b) + +-- | Like `modifySnd`, except use moand wrap function. +modifySndM :: (Monad m, MonadTrans t1, MonadState (t, a) (t1 m)) => ((t, a) -> m a) -> t1 m () +modifySndM f = do + oldState@(a, _) <- get + b' <- lift $ f oldState + put (a, b') + +-- | Like `get`, except use Monad wrap function. +getM :: (MonadState a (t m), MonadTrans t, Monad m) => (a -> m a1) -> t m a1 +getM f = get >>= lift . f + +-- | Like `runStateT`, just reverse arguments order. +runStateT_ :: b -> StateT b m a -> m (a, b) +runStateT_ = flip runStateT + +-- | Like `runStateT_`, but just return last argument. +-- It's useful that you just want use runStateT wrap *one* state. +runStateT' :: (Functor f) => b -> StateT b f a -> f b +runStateT' b f = fmap snd $ runStateT_ b f + +-- | Use runStateT' wrap TVar. +runTVarStateT :: TVar a -> (a -> StateT a IO b) -> IO () +runTVarStateT tvar fun = do + state <- readTVarIO tvar + newState <- runStateT' state (fun state) + writeTVarIO tvar newState + +-- | Like `runTVarStateT`, but handle tuple TVar. +runTVarTupeStateT :: (TVar a, TVar b) -> (a -> b -> StateT (a, b) IO c) -> IO () +runTVarTupeStateT (tvarA, tvarB) fun = do + stateA <- readTVarIO tvarA + stateB <- readTVarIO tvarB + (newStateA, newStateB) <- runStateT' (stateA, stateB) (fun stateA stateB) + writeTVarIO tvarA newStateA + writeTVarIO tvarB newStateB + diff --git a/Manatee/Toolkit/General/String.hs b/Manatee/Toolkit/General/String.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/String.hs @@ -0,0 +1,98 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.String where + +import Data.Char +import Data.List (isSuffixOf) +import Control.Arrow + +-- | Search forward word. +-- Return (Word, RestStr) if found word at beginning. +-- Otherwise return ("", AllStr). +searchForwardWord :: String -> (String, String) +searchForwardWord "" = ("", "") +searchForwardWord (x:xs) + | isAlphaNum x + = let (word, rest) = searchForwardWord xs + in (x : word, rest) + | otherwise + = ("", x : xs) + +-- | Like `searchForwardWord` except reverse ordering. +searchBackwardWord :: String -> (String, String) +searchBackwardWord str = + (reverse *** reverse) $ searchForwardWord (reverse str) + +-- | Whether string is blank. +isBlankString :: String -> Bool +isBlankString [] = True +isBlankString (x:xs) + | isSpace x + = isBlankString xs + | otherwise + = False +-- | Convert string to int. +stringToInt :: Int -> String -> Int +stringToInt base digits + = sign * (foldl acc 0 $ concatMap digToInt digits1) + where + splitSign ('-' : ds) = ((-1), ds) + splitSign ('+' : ds) = ( 1 , ds) + splitSign ds = ( 1 , ds) + (sign, digits1) = splitSign digits + digToInt c + | c >= '0' && c <= '9' + = [ord c - ord '0'] + | c >= 'A' && c <= 'Z' + = [ord c - ord 'A' + 10] + | c >= 'a' && c <= 'z' + = [ord c - ord 'a' + 10] + | otherwise + = [] + acc i1 i0 + = i1 * base + i0 + +-- | Convert a string of hexadecimal digits into an Int +hexStringToInt :: String -> Int +hexStringToInt = stringToInt 16 + +-- | Drop suffix. +dropSuffix :: [String] -> String -> String +dropSuffix [] str = str +dropSuffix (x:xs) str + | x `isSuffixOf` str + = take (length str - length x) str + | otherwise + = dropSuffix xs str + +-- | Strip and format. +stripFormat :: String -> Int -> String +stripFormat str limit + | limit < 0 + = str + | length str <= limit + = str + | otherwise + = take limit str ++ "..." + +-- | Unlines except last one. +unlinesExceptLast :: [String] -> String +unlinesExceptLast [] = "" +unlinesExceptLast list = init $ unlines list + diff --git a/Manatee/Toolkit/General/Time.hs b/Manatee/Toolkit/General/Time.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Time.hs @@ -0,0 +1,74 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.Time where + +import Control.Applicative +import Control.Monad +import Data.DateTime hiding (getCurrentTime) +import Data.Time +import System.Glib.GDateTime +import System.Locale +import System.Time + +instance Show GTimeVal where + show GTimeVal {gTimeValSec = seconds + ,gTimeValUSec = microseconds} + = show seconds ++ " : " ++ show microseconds + +-- | Get local time. +getCurrentLocalTime :: IO LocalTime +getCurrentLocalTime = liftM2 utcToLocalTime getCurrentTimeZone getCurrentTime + +-- | Different two time with second. +diffUTCTimeWithSecond :: UTCTime -> UTCTime -> Integer +diffUTCTimeWithSecond t1 t2 = diffUTCTimeWithQuantify t1 t2 1 + +-- | Different two time with millisecond. +diffUTCTimeWithMillisecond :: UTCTime -> UTCTime -> Integer +diffUTCTimeWithMillisecond t1 t2 = diffUTCTimeWithQuantify t1 t2 (10 ^ 3) + +-- | Different two time with microsecond. +diffUTCTimeWithMicrosecond :: UTCTime -> UTCTime -> Integer +diffUTCTimeWithMicrosecond t1 t2 = diffUTCTimeWithQuantify t1 t2 (10 ^ 6) + +-- | Different two time with quantify. +diffUTCTimeWithQuantify :: UTCTime -> UTCTime -> NominalDiffTime -> Integer +diffUTCTimeWithQuantify t1 t2 quantify = truncate $ (quantify *) $ diffUTCTime t1 t2 + +-- | Convert GTimeVale to ClockTime. +gTimeValToClockTime :: GTimeVal -> ClockTime +gTimeValToClockTime GTimeVal {gTimeValSec = seconds + ,gTimeValUSec = microseconds} = + TOD (toInteger seconds) (toInteger microseconds * 1000) + +-- | Get local time stamp with your format! +getTimeStamp :: String -> IO String +getTimeStamp format = + formatTime <$> pure defaultTimeLocale + <*> pure format + <*> (utcToLocalTime <$> getCurrentTimeZone + <*> getCurrentTime) + +-- | Get diff time that seconds from 1970. +getSecondsTimeStamp :: Integer -> String -> IO String +getSecondsTimeStamp seconds format = + formatTime <$> pure defaultTimeLocale + <*> pure format + <*> (utcToLocalTime <$> getCurrentTimeZone + <*> pure (fromSeconds seconds)) diff --git a/Manatee/Toolkit/General/Typeable.hs b/Manatee/Toolkit/General/Typeable.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Typeable.hs @@ -0,0 +1,45 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.Typeable where + +import Data.ByteString.Lazy.UTF8 (ByteString) +import Data.Dynamic +import Manatee.Toolkit.General.Maybe + +import qualified Data.ByteString.Lazy.UTF8 as U + +-- | Get type string of dynamic type. +dynTypeString :: Dynamic -> String +dynTypeString = tyConString . typeRepTyCon . dynTypeRep + +-- | Type String. +typeString :: Typeable a => a -> String +typeString = tyConString . typeRepTyCon . typeOf + +-- | Cast to Type with String. +castType :: Typeable a => String -> Maybe a +castType str = cast $ mkTyCon str + +-- | Type of byte string. +typeByteString :: Typeable a => a -> ByteString +typeByteString = U.fromString . tyConString . typeRepTyCon . typeOf + +-- | Convert Type. +convertType :: (Typeable a, Typeable b) => a -> b +convertType a = maybeError (cast a) (typeString a) diff --git a/Manatee/Toolkit/General/Url.hs b/Manatee/Toolkit/General/Url.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/General/Url.hs @@ -0,0 +1,26 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.General.Url where + +import qualified Codec.Binary.Url as Url +import qualified Codec.Binary.UTF8.String as UTF8 + +-- | Encode url. +encodeUrl :: String -> String +encodeUrl = Url.encode . UTF8.encode diff --git a/Manatee/Toolkit/Gio/Gio.hs b/Manatee/Toolkit/Gio/Gio.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gio/Gio.hs @@ -0,0 +1,200 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Gio.Gio where + +import Control.Monad (liftM) +import Control.Applicative hiding (empty) +import Data.Map (Map) +import Data.List (nub) +import Data.ByteString.UTF8 +import Distribution.Simple.Utils +import Graphics.UI.Gtk.Gdk.Pixbuf +import Graphics.UI.Gtk.General.IconTheme +import Manatee.Toolkit.General.List +import Manatee.Toolkit.General.Map +import Manatee.Toolkit.General.Maybe +import System.FilePath +import System.GIO +import Manatee.Toolkit.Glib.GError + +import qualified Data.Map as M +import qualified Data.ByteString.Char8 as B +import qualified Manatee.Toolkit.General.ByteString as GB + +type FileContentType = String +type FileIconPixbufDatabase = Map FileContentType Pixbuf + +-- | Check file is exist. +fileDoesExist :: ByteString -> Bool +fileDoesExist filepath = + fileQueryExists (fileFromPath filepath) Nothing + +-- | Check directory is exist. +directoryDoesExist :: ByteString -> Bool +directoryDoesExist directory = + fileDoesExist directory && isDirectory directory + +-- | Check file path whether directory. +isDirectory :: ByteString -> Bool +isDirectory directory = + FileTypeDirectory == fileQueryFileType (fileFromPath directory) [] Nothing + +-- | Get files from given directory. +directoryGetFiles :: ByteString -> IO [ByteString] +directoryGetFiles directory = + map fileInfoGetNameWithType <$> directoryGetFileInfos directory + +-- | Get files recursive. +directoryGetFilesRecursive :: ByteString -> IO [ByteString] +directoryGetFilesRecursive dir = do + infos <- directoryGetFileInfos dir + liftM concat $ mapM (\info -> do + let fType = fileInfoGetFileType info + fName = maybeError (fileInfoGetName info) + "directoryGetFilesRecursive - `fileInfoGetName`." + fPath = GB.combine dir fName + if fType == FileTypeDirectory + -- Get files recursively if current path is directory. + then directoryGetFilesRecursive fPath + -- Otherwise return current file. + else return [fPath] + ) infos + +-- | Get info name with type. +fileInfoGetNameWithType :: FileInfoClass info => info -> ByteString +fileInfoGetNameWithType info + | fType == FileTypeDirectory + = B.concat [fName, B.singleton pathSeparator] + | otherwise + = fName + where fType = fileInfoGetFileType info + fName = maybeError (fileInfoGetName info) + "fileInfoGetNameWithType - `fileInfoGetName`." + +-- | Get info name with type. +fileInfoGetDisplayNameWithType :: FileInfoClass info => info -> String +fileInfoGetDisplayNameWithType info + | fType == FileTypeDirectory + = fName ++ [pathSeparator] + | otherwise + = fName + where fType = fileInfoGetFileType info + fName = maybeError (fileInfoGetDisplayName info) + "fileInfoGetDisplayNameWithType - `fileInfoGetDisplayName`." + +-- | Get display name for given filepath. +filepathGetDisplayName :: ByteString -> FilePath +filepathGetDisplayName = + fileParseName . fileFromPath + +-- | Get FileInfo list from given directory. +directoryGetFileInfos :: ByteString -> IO [FileInfo] +directoryGetFileInfos directory = catchGErrorM (return []) $ do + let dir = fileFromPath directory + enumerator <- fileEnumerateChildren dir "*" [] Nothing + fileEnumeratorGetFileInfos enumerator + +-- | We need use absolute *byte string* to identifier a filepath in filesystem. +-- So we need 'directory name' and 'file name' are valid 'byte string', no encoding information. +-- 'Byte string file name' can get by 'fileEnumeratorNextFile' and 'fileInfoGetName'. +-- 'Byte string directory name ' can get by 'fileEnumerateChildren' and 'fileEnumeratorGetContainer' +-- So this function is convert user input directory name (UTF8) to 'byte string'. +getDirectoryPath :: String -> IO ByteString +getDirectoryPath dirStr = do + let dir = fileFromParseName dirStr + enumerator <- fileEnumerateChildren dir "*" [] Nothing + dirFile <- fileEnumeratorGetContainer enumerator + return $ filePath dirFile + +-- | Get FileInfo list from given FileEnumerator. +fileEnumeratorGetFileInfos :: FileEnumeratorClass enumerator => enumerator -> IO [FileInfo] +fileEnumeratorGetFileInfos enum = do + fileInfo <- fileEnumeratorNextFile enum Nothing + case fileInfo of + Just info -> do + infos <- fileEnumeratorGetFileInfos enum + return $ info : infos + Nothing -> return [] + +-- | Compare file name with file type. +-- Directory first, then sort file. +-- All sort is alpha sort. +compareFileWithType :: (FilePath, FileType) -> (FilePath, FileType) -> Ordering +compareFileWithType (fPath1, fType1) (fPath2, fType2) + | fType1 == fType2 + = compare fName1 fName2 + | fType1 == FileTypeDirectory + = LT + | fType2 == FileTypeDirectory + = GT + | otherwise + = compare fName1 fName2 + -- Don't care file case. + where fName1 = lowercase fPath1 + fName2 = lowercase fPath2 + +-- | Get description for file info. +fileInfoGetDescription :: FileInfoClass info => info -> String +fileInfoGetDescription info = + case contentType of + Just ct -> contentTypeGetDescription ct + Nothing -> "" + where contentType = fileInfoGetContentType info + +-- | Get all execute files. +getAllExecuteFiles :: IO [ByteString] +getAllExecuteFiles = + catchGErrorM (return []) $ do + paths <- liftM (filter directoryDoesExist . map fromString . nub) getSearchPath + liftM nub $ concatMapM directoryGetFiles paths + +-- | Launch command in terminal. +launchCommandInTerminal :: String -> IO () +launchCommandInTerminal command = do + appinfo <- appInfoCreateFromCommandline command Nothing [AppInfoCreateNeedsTerminal] + appInfoLaunch appinfo [] Nothing + return () + +-- | Get icon pixbuf. +fileInfoGetIconPixbuf :: FileInfoClass info => info -> IO Pixbuf +fileInfoGetIconPixbuf info = + getIconPixbuf =<< fileInfoGetIcon info + +-- | Get icon pixbuf. +getIconPixbuf :: IconClass icon => icon -> IO Pixbuf +getIconPixbuf icon = do + iconTheme <- iconThemeGetDefault + iconInfo <- iconThemeLookupByGIcon iconTheme icon 24 IconLookupUseBuiltin + case iconInfo of + Just ii -> iconInfoLoadIcon ii + Nothing -> do + pixbuf <- iconThemeLoadIcon iconTheme "unknown" 24 IconLookupUseBuiltin + return $ maybeError pixbuf "getFileIconPixbuf: can't get `unknown` icon pixbuf." + +-- | Update file icon database. +updateFileIconPixbufDatabase :: FileInfoClass info => info -> FileIconPixbufDatabase -> IO FileIconPixbufDatabase +updateFileIconPixbufDatabase info database = do + let fMime = maybeError (fileInfoGetContentType info) + "getFileIconPixbuf: can't get file content type." + case findMinMatch database (\ mime _ -> mime == fMime) of + Just _ -> return database + Nothing -> do + pixbuf <- fileInfoGetIconPixbuf info + return $ M.insert fMime pixbuf database + diff --git a/Manatee/Toolkit/Glib/GError.hs b/Manatee/Toolkit/Glib/GError.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Glib/GError.hs @@ -0,0 +1,28 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Glib.GError where + +import System.Glib.GError + +-- | Like `catchGError`, but easier to use. +catchGErrorM :: IO a -> IO a -> IO a +catchGErrorM errorResult action = + catchGError action $ \ (GError _ _ msg) -> do + putStrLn msg + errorResult diff --git a/Manatee/Toolkit/Gtk/Box.hs b/Manatee/Toolkit/Gtk/Box.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/Box.hs @@ -0,0 +1,41 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Gtk.Box where + +import Control.Monad +import Data.Maybe +import Graphics.UI.Gtk +import Manatee.Toolkit.General.Maybe + +-- | Try to packing widget in box. +-- If @child@ have exist parent, do nothing, +-- otherwise, add @child@ to @parent@. +boxTryPack :: (BoxClass parent, WidgetClass child) => parent -> child -> Packing -> Maybe Int -> Maybe Int -> IO () +boxTryPack box widget packing order space = do + parent <- widgetGetParent widget + when (isNothing parent) $ do + boxPackStart box widget packing (fromMaybe 0 space) + order ?>= boxReorderChild box widget + +-- | Change box child Packing. +boxChangeChildPacking :: (BoxClass parent, WidgetClass child) => parent -> child -> Packing -> IO () +boxChangeChildPacking box widget packing = do + (_, index, packType) <- boxQueryChildPacking box widget + boxSetChildPacking box widget packing index packType + diff --git a/Manatee/Toolkit/Gtk/Cairo.hs b/Manatee/Toolkit/Gtk/Cairo.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/Cairo.hs @@ -0,0 +1,62 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Gtk.Cairo where + +import Graphics.Rendering.Cairo + +-- | Like `Cairo.rectangle`, but with round corner. +roundRectangle :: Double -> Double -> Double -> Double -> Double -> Render () +roundRectangle x y w h r = do + -- Draw top line. + moveTo (x + r) y + lineTo (x + w - r) y + + -- Draw bottom line. + moveTo (x + w - r) (y + h) + lineTo (x + r) (y + h) + + -- Draw right line. + moveTo (x + w) (y + r) + lineTo (x + w) (y + h - r) + + -- Draw left line. + moveTo x (y + h - r) + lineTo x (y + r) + + -- Draw top-left corner. + arcDegree (x + r) (y + r) r 180 270 + + -- Draw top-right corner. + arcDegree (x + w - r) (y + r) r 270 360 + + -- Draw bottom-right corner. + arcDegree (x + w - r) (y + h - r) r 0 90 + + -- Draw bottom-left corner + arcDegree (x + r) (y + h - r) r 90 180 + +-- | Convert from degree to radian. +degreeToRadian :: Double -> Double +degreeToRadian degrees = degrees * pi / 180 + +-- | Like `Cairo.arc` except use degree as arguments. +arcDegree :: Double -> Double -> Double -> Double -> Double -> Render () +arcDegree xc yc radius angleStart angleEnd = + arc xc yc radius (degreeToRadian angleStart) (degreeToRadian angleEnd) + diff --git a/Manatee/Toolkit/Gtk/Concurrent.hs b/Manatee/Toolkit/Gtk/Concurrent.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/Concurrent.hs @@ -0,0 +1,105 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE ScopedTypeVariables #-} +module Manatee.Toolkit.Gtk.Concurrent where + +import Control.Monad +import Control.Concurrent +import Control.Concurrent.STM +import Graphics.UI.Gtk +import Manatee.Toolkit.General.STM + +import qualified Control.Exception as Exc + +data ViewChannel a = + ViewChannel {viewChannel :: TChan a + ,viewChannelLock :: TVar Bool} + +-- | Fork GUI IO. +forkGuiIO :: IO a -> (a -> IO ()) -> IO (MVar a, ThreadId, ThreadId) +forkGuiIO calcAction guiAction = do + -- Create signal MVar variable. + signal <- newEmptyMVar + -- Build new thread for long-time calculation. + calcThreadId <- forkIO $ calcAction >>= putMVar signal -- fill signal when calculation finish + -- Build new thread for listen signal. + guiThreadId <- onGuiSignal signal guiAction -- post GUI action to Gtk+ thread when catch finish signal + return (signal, calcThreadId, guiThreadId) + +-- | Similar `forkGuiIO`, except return () +forkGuiIO_ :: IO a -> (a -> IO ()) -> IO () +forkGuiIO_ calcAction guiAction = + forkGuiIO calcAction guiAction + >> return () + +-- | Post GUI Action to Gtk+ thread when catch signal. +onGuiSignal :: MVar a -> (a -> IO ()) -> IO ThreadId +onGuiSignal signal guiAction = + forkIO $ takeMVar signal >>= postGUIAsync . guiAction + +-- | Create view channel. +-- If widget destroy, stop read broadcast channel. +createViewChannel :: WidgetClass widget + => TChan a + -> widget + -> IO (ViewChannel a) +createViewChannel channel widget = do + -- Create channel and lock. + chan <- dupTChanIO channel + lock <- newTVarIO True + + -- After render view widget destroy lock channel stop read thread. + widget `onDestroy` writeTVarIO lock False + + -- Return ViewChannel. + return $ ViewChannel chan lock + +-- | Listen view channel. +listenViewChannel :: ViewChannel a -> (a -> IO ()) -> IO () +listenViewChannel vChannel@(ViewChannel {viewChannel = channel + ,viewChannelLock = channelLock}) + action = do + forkIO $ + readTChanIO channel + >>= \x -> do + isLive <- readTVarIO channelLock + when isLive $ + postGUIAsync $ + Exc.catch + (do + action x + listenViewChannel vChannel action) + (\ (_ :: Exc.SomeException) -> + putStrLn "listenViewChannel : Catch exception, stop read broadcast channel.") + return () + +-- | Listen buffer channel. +listenBufferChannel :: TChan a -> (a -> IO ()) -> IO () +listenBufferChannel channel action = do + forkIO $ + readTChanIO channel + >>= \x -> + postGUIAsync $ + Exc.catch + (do + action x + listenBufferChannel channel action) + (\ (_ :: Exc.SomeException) -> + putStrLn "listenBufferChannel : Catch exception, stop read broadcast channel.") + return () diff --git a/Manatee/Toolkit/Gtk/Container.hs b/Manatee/Toolkit/Gtk/Container.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/Container.hs @@ -0,0 +1,70 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Gtk.Container where + +import Control.Applicative hiding (empty) +import Control.Monad +import Data.Maybe +import Graphics.UI.Gtk +import Manatee.Toolkit.General.List + +-- | Get first child. +containerGetFirstChild :: ContainerClass self => self -> IO (Maybe Widget) +containerGetFirstChild self = do + children <- containerGetChildren self + return $ if null children + then Nothing + else Just $ head children + +-- | Get last child. +containerGetLastChild :: ContainerClass self => self -> IO (Maybe Widget) +containerGetLastChild self = do + children <- containerGetChildren self + return $ if null children + then Nothing + else Just $ last children + +-- | Remove all child of container. +containerRemoveAll :: ContainerClass self => self -> IO () +containerRemoveAll self = containerForeach self $ containerRemove self + +-- | Try to remove child from parent. +containerTryRemove :: (ContainerClass parent, WidgetClass child) => parent -> child -> IO () +containerTryRemove parent widget = do + hasParent <- widgetGetParent widget + unless (isNothing hasParent) $ containerRemove parent widget + +-- | Apply container size and won't change widget's size. +containerApplySize :: ContainerClass self => self -> (Int -> Int -> IO ()) -> IO () +containerApplySize container childFun = + widgetGetSize container + >>= \(width, height) -> do + -- Run user's function with container size. + childFun width height + + -- Why set size request with 0? + -- Answer: because set size request can make container as small as possible, + -- example, when you un-fullscreen and maximum window, + -- window will adjust it's size make it can display in screen area. + widgetSetSizeRequest container 0 0 + +-- | Whether has children. +containerHasChildren :: ContainerClass self => self -> IO Bool +containerHasChildren self = + has <$> containerGetChildren self diff --git a/Manatee/Toolkit/Gtk/DrawWindow.hs b/Manatee/Toolkit/Gtk/DrawWindow.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/DrawWindow.hs @@ -0,0 +1,34 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Gtk.DrawWindow where + +import Graphics.UI.Gtk.Abstract.Widget +import Graphics.UI.Gtk.Gdk.DrawWindow + +-- | Invalidate rectangle stroke. +drawWindowInvalidateRectStroke :: DrawWindowClass self => self -> Rectangle -> Int -> Bool -> IO () +drawWindowInvalidateRectStroke drawWin (Rectangle x y w h) lw invalidateChildren = do + -- Invalid left stroke. + drawWindowInvalidateRect drawWin (Rectangle x y lw (y + h)) invalidateChildren + -- Invalid right stroke. + drawWindowInvalidateRect drawWin (Rectangle (x + w - lw) y lw (y + h)) invalidateChildren + -- Invalid top stroke. + drawWindowInvalidateRect drawWin (Rectangle x y (x + w) lw) invalidateChildren + -- Invalid bottom stroke. + drawWindowInvalidateRect drawWin (Rectangle x y (x + w) (y + h - lw)) invalidateChildren diff --git a/Manatee/Toolkit/Gtk/Editable.hs b/Manatee/Toolkit/Gtk/Editable.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/Editable.hs @@ -0,0 +1,127 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Gtk.Editable where + +import Control.Monad +import Graphics.UI.Gtk +import Manatee.Toolkit.General.List +import Manatee.Toolkit.General.String + +type EditableContent = String +type EditableBound = (Int, Int) +type EditableStatus = (EditableContent, EditableBound) + +-- | Focus editable and keep status. +editableFocus :: EditableClass self => self -> IO () +editableFocus ed = do + bound <- editableGetSelectionBounds ed + widgetGrabFocus $ castToWidget ed + editableSetBound ed bound + +-- | Get unselect text. +editableGetUnselectText :: EditableClass self => self -> IO String +editableGetUnselectText ed = do + allText <- editableGetAllText ed -- get editable content + (start, _) <- editableGetSelectionBounds ed -- get highlight bound + return $ take start allText -- remove highlight completion part from content + +-- | Select from current position to end. +editableSelectToEnd :: EditableClass self => self -> Int -> IO () +editableSelectToEnd ed current = + editableSelectRegion ed current (-1) + +-- | Get all text. +editableGetAllText :: EditableClass self => self -> IO String +editableGetAllText ed = editableGetChars ed 0 (-1) + +-- | Set text. +editableSetText :: EditableClass self => self -> String -> IO () +editableSetText ed content = do + editableDeleteAllText ed + end <- editableInsertText ed content 0 + editableSetPosition ed end + +-- | Set completion text. +editableSetCompletionText :: EditableClass self => self -> String -> String -> IO () +editableSetCompletionText ed input common = do + editableSetText ed (input ++ common) + editableSelectToEnd ed (length input) + +-- | Set bound. +editableSetBound :: EditableClass self => self -> (Int, Int) -> IO () +editableSetBound ed (start, end) = do + editableSelectRegion ed start end + editableSetPosition ed start + +-- | Get status. +editableGetStatus :: EditableClass self => self -> IO EditableStatus +editableGetStatus ed = + liftM2 (,) (editableGetAllText ed) (editableGetSelectionBounds ed) + +-- | Set status. +editableSetStatus :: EditableClass self => self -> EditableStatus -> IO () +editableSetStatus ed (content, bound) = do + editableSetText ed content + editableSetBound ed bound + +-- | Delete all text. +editableDeleteAllText :: EditableClass self => self -> IO () +editableDeleteAllText ed = editableDeleteText ed 0 (-1) + +-- | Expand completion. +editableExpandCompletion :: EditableClass self => self -> IO () +editableExpandCompletion ed = + editableSetPosition ed (-1) + +-- | Delete backward char. +editableDeleteBackwardChar :: EditableClass self => self -> IO () +editableDeleteBackwardChar ed = do + unselectText <- editableGetUnselectText ed + editableSetText ed (init_ unselectText) + +-- | Delete backward word. +editableDeleteBackwardWord :: EditableClass self => self -> IO () +editableDeleteBackwardWord ed = do + unselectText <- editableGetUnselectText ed + let (word, restStr) = searchBackwardWord unselectText + text = if null word + -- If not word at last, delete char. + then init_ unselectText + -- Otherwise delete word. + else restStr + editableSetText ed text + +-- | Backward char. +editableBackwardChar :: EditableClass self => self -> IO () +editableBackwardChar ed = do + pos <- editableGetPosition ed + editableSetPosition ed (if pos >= 1 then pos - 1 else 0) + +-- | Whether changed after do editable action? +editableIsChanged :: EditableClass self => self -> IO () -> IO Bool +editableIsChanged ed action = do + let getState = do + text <- editableGetAllText ed + (start, end) <- editableGetSelectionBounds ed + return (text, start, end) + beforeState <- getState + action + afterState <- getState + return (beforeState /= afterState) + diff --git a/Manatee/Toolkit/Gtk/Event.hs b/Manatee/Toolkit/Gtk/Event.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/Event.hs @@ -0,0 +1,135 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +{-# LANGUAGE OverloadedStrings #-} +module Manatee.Toolkit.Gtk.Event where + +import Control.Applicative hiding (empty) +import Control.Monad.Trans +import Data.List +import Data.Map (Map) +import Data.Maybe +import Data.Text.Lazy (Text, pack, singleton, empty, append, snoc) +import Graphics.UI.Gtk + +import qualified Data.Map as M +import qualified Data.Text.Lazy as DTL + +-- | Get keystroke value as a text. +eventKeystoke :: EventM EKey Text +eventKeystoke = do + -- liftIO $ putStrLn "Debug test" + + -- Get key modifier and name. + keyModifier <- eventModifier + keyName <- eventKeyName' + + -- Debug. + -- liftIO $ do + -- putStrLn $ "Key modifier: " ++ show keyModifier + -- putStrLn $ "Key name: " ++ show keyName + + case M.lookup keyName eventModifierMap of + -- When user just press modifier keys. + Just m -> do + -- Return all modifier alias list. + let modifierList = (:) m keyModifier + return $ eventModifierAliasList modifierList + -- Otherwise. + Nothing -> do + -- Remove `Shift` modifier from modifier list if key name is corresponding Unicode character. + removeShift <- isUnicodeKey + let modifierList = (if removeShift + then filter (/= Shift) + else id) keyModifier + + -- Get key name. + shortName <- eventKeyName_ + + -- Return result. + return $ eventModifierAliasList modifierList `append` shortName + +-- | Get key char. +eventKeyChar :: EventM EKey (Maybe Char) +eventKeyChar = keyToChar <$> eventKeyVal + +-- | Like `eventKeyName` just return Text. +eventKeyName' :: EventM EKey Text +eventKeyName' = fmap (pack . eventKeyNameAlias) eventKeyName + +-- | Like `eventKeyName` return key name, +-- but return symbol when key is corresponding Unicode character. +eventKeyName_ :: EventM EKey Text +eventKeyName_ = do + -- Get event char. + keyChar <- eventKeyChar + + case keyChar of + -- Return character symbol when key is corresponding Unicode character. + Just c -> return $ singleton c + -- Otherwise return key name. + Nothing -> eventKeyName' + +-- | Modifier alias. +eventModifierAlias :: Modifier -> Text +eventModifierAlias = singleton . aliasMatch + where + aliasMatch Control = 'C' + aliasMatch Shift = 'S' + aliasMatch Alt = 'M' + aliasMatch Meta = 'M' + aliasMatch Super = 'P' + +-- | Event key name alias +eventKeyNameAlias :: String -> String +eventKeyNameAlias "Page_Down" = "PageDown" +eventKeyNameAlias "Page_Up" = "PageUp" +eventKeyNameAlias key = key + +-- | Concat modifier list as alias. +eventModifierAliasList :: [Modifier] -> Text +eventModifierAliasList [] = empty +eventModifierAliasList list = DTL.concat $ map (`snoc` '-') (nub $ sort $ map eventModifierAlias list) + +-- | Modifier name map. +eventModifierMap :: Map Text Modifier +eventModifierMap = + M.fromList + [("Control_L", Control) + ,("Control_R", Control) + ,("Shift_L", Shift) + ,("Shift_R", Shift) + ,("Alt_L", Alt) + ,("Alt_R", Alt) + ,("Meta_L", Alt) + ,("Meta_R", Alt) + ,("Super_L", Super) + ,("Super_R", Super)] + +-- | Whether key is Unicode character. +isUnicodeKey :: EventM EKey Bool +isUnicodeKey = isJust <$> eventKeyChar + +-- | Get size of event window. +eventWindowSize :: EventM EExpose (Double, Double) +eventWindowSize = do + dr <- eventWindow + (w,h) <- liftIO $ drawableGetSize dr + return $ if w * h > 1 + then (fromIntegral w, fromIntegral h) + else (1,1) diff --git a/Manatee/Toolkit/Gtk/Gtk.hs b/Manatee/Toolkit/Gtk/Gtk.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/Gtk.hs @@ -0,0 +1,161 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Gtk.Gtk where + +import Control.Applicative hiding (empty) +import Data.Maybe +import Graphics.UI.Gtk hiding (Statusbar, statusbarNew) +import Graphics.UI.Gtk.Gdk.SerializedEvent +import Graphics.UI.Gtk.SourceView.SourceLanguage +import Graphics.UI.Gtk.SourceView.SourceLanguageManager +import Manatee.Toolkit.General.Basic + +-- | Get source language along with file name. +sourceLanguageForFilename :: SourceLanguageManager -> Maybe String -> IO (Maybe String, Maybe SourceLanguage) +sourceLanguageForFilename lm filename = do + mbLang <- + case filename of + Just f -> sourceLanguageManagerGuessLanguage lm (Just f) Nothing + Nothing -> sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-text") + case mbLang of + Nothing -> return (Nothing,Nothing) + Just lang -> do + name <- sourceLanguageGetName lang + return (Just name, Just lang) + +-- | Add window with special window group. +windowNewWithWindowGroup :: WindowGroup -> IO Window +windowNewWithWindowGroup windowGroup = do + window <- windowNew + windowGroupAddWindow windowGroup window + return window + +-- | Get x coordinate of Rectangle. +rectangleX :: Rectangle -> Int +rectangleX (Rectangle x _ _ _) = x + +-- | Get y coordinate of Rectangle. +rectangleY :: Rectangle -> Int +rectangleY (Rectangle _ y _ _) = y + +-- | Get width of Rectangle. +rectangleW :: Rectangle -> Int +rectangleW (Rectangle _ _ w _) = w + +-- | Get height of Rectangle. +rectangleH :: Rectangle -> Int +rectangleH (Rectangle _ _ _ h) = h + +-- | This function like `socketNew`, +-- but call `widgetShow` when create. +-- Because Gtk+ said must show GtkScoekt before add to container. +socketNew_ :: IO Socket +socketNew_ = do + socket <- socketNew + widgetShow socket + return socket + +-- | Window is full-screen. +-- Notes, just call this function when you have realized window. +windowIsFullscreen :: Window -> IO Bool +windowIsFullscreen window = + widgetGetDrawWindow window + >>= drawWindowGetState + >>= \states -> + return $ WindowStateFullscreen `elem` states + +-- | Frame new with shadow type. +frameNewWithShadowType :: Maybe ShadowType -> IO Frame +frameNewWithShadowType Nothing = frameNew +frameNewWithShadowType (Just shadow) = do + frame <- frameNew + frameSetShadowType frame shadow + return frame + +-- | Redraw rectangle frame. +widgetRedrawRectangleFrame :: WidgetClass self => self + -> Int -- rectangle x + -> Int -- rectangle y + -> Int -- rectangle width + -> Int -- rectangle height + -> Int -- rectangle line width + -> IO () +widgetRedrawRectangleFrame widget x y w h lw = do + -- Redraw left stroke. + widgetQueueDrawArea widget x y lw (y + h) + -- Redraw right stroke. + widgetQueueDrawArea widget (x + w - lw) y lw (y + h) + -- Redraw top stroke. + widgetQueueDrawArea widget x y (x + w) lw + -- Redraw bottom stroke. + widgetQueueDrawArea widget x (y + h - lw) (x + w) lw + +-- | Whether the widget has parent. +widgetHasParent :: WidgetClass widget => widget -> IO Bool +widgetHasParent widget = + isJust <$> widgetGetParent widget + +-- | Propagate event on specify widget. +widgetPropagateEvent :: WidgetClass widget => widget -> SerializedEvent -> IO () +widgetPropagateEvent widget sEvent = do + drawWindow <- widgetGetDrawWindow widget + postGUIAsync $ deserializeEvent sEvent drawWindow (widgetEvent widget) >> return () + +-- | Get screen size. +widgetGetScreenSize :: WidgetClass widget => widget -> IO (Int, Int) +widgetGetScreenSize widget = do + screen <- widgetGetScreen widget + width <- screenGetWidth screen + height <- screenGetHeight screen + return (width, height) + +-- | Create image widget with given icon name and size. +imageNewFromIcon :: String -> Int -> IO Image +imageNewFromIcon iconName size = do + iconTheme <- iconThemeGetDefault + pixbuf <- do + -- Function 'iconThemeLoadIcon' can scale icon with specified size. + pixbuf <- iconThemeLoadIcon iconTheme iconName size IconLookupUseBuiltin + case pixbuf of + Just p -> return p + Nothing -> error $ "imageNewFromIcon : search icon " ++ iconName ++ " failed." + imageNewFromPixbuf pixbuf + +-- | Set position of paned. +panedAdjustSize :: PanedClass self => self -> Int -> IO () +panedAdjustSize paned adjustSize = do + -- Get position of paned. + position <- get paned panedPosition + minPosition <- get paned panedMinPosition + maxPosition <- get paned panedMaxPosition + -- Calculate new position. + let adjustPosition = position + adjustSize + newPosition + -- Don't lower than min position. + | adjustPosition < minPosition = minPosition + -- Don't bigger than max position. + | adjustPosition > maxPosition = maxPosition + | otherwise = adjustPosition + -- Set new position to parent node paned. + panedSetPosition paned newPosition + +-- | Convert Color to RGB value. +colorToRGB :: Color -> (Double, Double, Double) +colorToRGB (Color r g b) = + (integralToDouble r / 65535, integralToDouble g / 65535, integralToDouble b / 65535) diff --git a/Manatee/Toolkit/Gtk/ModelView.hs b/Manatee/Toolkit/Gtk/ModelView.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/ModelView.hs @@ -0,0 +1,335 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Gtk.ModelView where + +import Control.Applicative hiding (empty) +import Control.Monad +import Data.Maybe +import Graphics.UI.Gtk +import Manatee.Toolkit.General.Basic +import Manatee.Toolkit.General.List +import Manatee.Toolkit.General.Maybe +import Manatee.Toolkit.Gtk.Gtk + +-- | Focus first toplevel node. +-- It focus first node if model is list model. +treeViewFocusFirstToplevelNode :: TreeViewClass view => view -> IO () +treeViewFocusFirstToplevelNode view = + treeViewSetCursor view [0] Nothing + +-- | Focus last toplevel node. +-- It focus last node if model is list model. +treeViewFocusLastToplevelNode :: TreeViewClass view => view -> IO () +treeViewFocusLastToplevelNode view = + treeViewApplyModel view $ \model -> do + lastPath <- treeModelLastToplevelPath model + treeViewSetCursor view lastPath Nothing + +-- | Get number of toplevel node in TreeView. +treeViewGetToplevelNodeCount :: TreeViewClass view => view -> IO Int +treeViewGetToplevelNodeCount view = do + model <- treeViewGetModel view + case model of + Just ml -> treeModelGetToplevelNodeCount ml + Nothing -> return 0 + +-- | Get number of toplevel node in TreeModel. +treeModelGetToplevelNodeCount :: TreeModelClass model => model -> IO Int +treeModelGetToplevelNodeCount model = + treeModelIterNChildren model Nothing + +-- | Apply treeView model. +treeViewApplyModel :: TreeViewClass view => view -> (TreeModel -> IO ()) -> IO () +treeViewApplyModel view f = + treeViewGetModel view >?>= f + +-- | Get current selection. +-- Don't *store* TreeIter, it's wrong value after model change. +-- It's should just as a argument for another IO function. +treeViewGetSelectedPath :: TreeViewClass view => view -> IO (Maybe TreePath) +treeViewGetSelectedPath view = + fmap maybeHead $ + treeViewGetSelection view + >>= treeSelectionGetSelectedRows + +-- | Get tree coordinate of cell. +treeViewGetCellTreeCoordinate :: TreeViewClass view => view -> Maybe TreePath -> TreeViewColumn -> IO Rectangle +treeViewGetCellTreeCoordinate view treePath column = do + -- Get coordinate relative to *visible area* of tree. + (Rectangle cx cy cw ch) <- treeViewGetBackgroundArea view treePath column + + -- Try to get adjustment value. + hAdjust <- treeViewGetHAdjustment view + adjustX <- case hAdjust of + Just ha -> ceiling <$> adjustmentGetValue ha + Nothing -> return 0 + + vAdjust <- treeViewGetVAdjustment view + adjustY <- case vAdjust of + Just va -> ceiling <$> adjustmentGetValue va + Nothing -> return 0 + + -- Because `treeViewGetSelectedBound` just return coordinate + -- relative to visible area of tree. + -- For get coordinate relative to full scrollable area of tree, + -- We need add value of adjustment. + return (Rectangle (cx + adjustX) (cy + adjustY) cw ch) + +-- | Get selection bound. +treeViewGetSelectedTreeCoordidnate :: TreeViewClass view => view -> IO (Maybe Rectangle) +treeViewGetSelectedTreeCoordidnate view = do + treePath <- treeViewGetSelectedPath view + treePath + ?>=> \ tp -> treeViewGetColumn view 0 + >?>=> (\x -> Just <$> treeViewGetCellTreeCoordinate view (Just tp) x) + +-- | Get selection widget coordinate. +treeViewGetSelectedWidgetCoordinate :: TreeViewClass view => view -> IO (Maybe Rectangle) +treeViewGetSelectedWidgetCoordinate view = + treeViewGetSelectedTreeCoordidnate view + >?>=> \(Rectangle rx ry rw rh) -> do + -- Transform tree coordinate to widget coordinate. + (wx, wy) <- treeViewConvertTreeToWidgetCoords view (rx, ry) + + return $ Just (Rectangle wx wy rw rh) + +-- | Focus next toplevel node. +treeViewFocusNextToplevelNode :: TreeViewClass view => view -> IO () +treeViewFocusNextToplevelNode view = + treeViewGetSelectedPath view + >?>= \ currentPath -> do + number <- treeViewGetToplevelNodeCount view + let currentRootNode = head currentPath + when (currentRootNode < number - 1) $ + treeViewSetCursor view [currentRootNode + 1] Nothing + +-- | Focus prev toplevel node. +-- Return True if focus prev toplevel node, +-- Otherwise return False. +treeViewFocusPrevToplevelNode :: TreeViewClass view => view -> IO () +treeViewFocusPrevToplevelNode view = + treeViewGetSelectedPath view + >?>= \ currentPath -> do + let currentRootNode = head currentPath + when (currentRootNode > 0) $ + treeViewSetCursor view [currentRootNode - 1] Nothing + +-- | Last toplevel node path of TreeModel. +treeModelLastToplevelPath :: TreeModelClass model => model -> IO TreePath +treeModelLastToplevelPath model = do + number <- treeModelGetToplevelNodeCount model + return $ if number > 0 then [number - 1] else [0] + +-- | Whether at first toplevel node? +-- It at first node if model is list model. +treeViewAtFirstToplevelNode :: TreeViewClass view => view -> IO Bool +treeViewAtFirstToplevelNode view = do + currentPath <- treeViewGetSelectedPath view + return $ case currentPath of + Just cp -> head cp == 0 + Nothing -> False + +-- | Whether at last toplevel node? +-- It at last node if model is list model. +treeViewAtLastToplevelNode :: TreeViewClass view => view -> IO Bool +treeViewAtLastToplevelNode view = do + currentPath <- treeViewGetSelectedPath view + nodeCount <- treeViewGetToplevelNodeCount view + return $ case currentPath of + Just cp -> head cp == nodeCount - 1 + Nothing -> False + +-- | Remove all column's from treeView. +treeViewRemoveColumns :: TreeViewClass self => self -> IO () +treeViewRemoveColumns treeView = + mapM_ (treeViewRemoveColumn treeView) + =<< treeViewGetColumns treeView + +-- | Have cell columns. +treeViewHaveColumn :: TreeViewClass self => self -> IO Bool +treeViewHaveColumn treeView = + has <$> treeViewGetColumns treeView + +-- | Un-select all. +treeViewUnselectAll :: TreeViewClass view => view -> IO () +treeViewUnselectAll view = + treeViewGetSelection view + >>= treeSelectionUnselectAll + +-- | Get default cell height. +treeViewGetDefaultCellHeight :: TreeViewClass view => view -> IO (Maybe Int) +treeViewGetDefaultCellHeight view = + treeViewGetColumn view 0 + >?>=> \col -> + (Just . rectangleH) <$> treeViewGetBackgroundArea view (Just [0]) col + +-- | Get attribute of cursor cell. +treeViewGetSelectedCellArea :: TreeViewClass self => (Rectangle -> Int) -> self -> IO Int +treeViewGetSelectedCellArea f treeView = do + (path, column) <- treeViewGetCursor treeView + case column of + -- Get attribute. + Just c -> (return . f) =<< treeViewGetCellArea treeView (Just path) c + -- Otherwise return 0. + Nothing -> return 0 + +-- | Get current cell height. +treeViewGetSelectedCellHeight :: TreeViewClass view => view -> IO Int +treeViewGetSelectedCellHeight = treeViewGetSelectedCellArea rectangleH + +-- | Get current cell height. +treeViewGetSelectedCellY :: TreeViewClass view => view -> IO Int +treeViewGetSelectedCellY = treeViewGetSelectedCellArea rectangleY + +-- | Get header height. +treeViewGetHeaderHeight :: TreeViewClass self => self -> IO Int +treeViewGetHeaderHeight treeView = do + (_, by) <- treeViewConvertTreeToBinWindowCoords treeView (0, 0) + (_, wy) <- treeViewConvertTreeToWidgetCoords treeView (0, 0) + return $ wy - by + +-- | Focus TreeView and keep current selected position. +treeViewFocus :: TreeViewClass self => self -> IO () +treeViewFocus view = do + selectedPath <- treeViewGetSelectedPath view + let focusPath = fromMaybe [0] selectedPath + treeViewSetCursor view focusPath Nothing + widgetGrabFocus view + +-- | Scroll vertical. +treeViewScrollVertical :: (TreeViewClass self, ScrolledWindowClass swc) => self -> swc -> Double -> IO () +treeViewScrollVertical view swc increment = do + -- Get adjustment arguments. + aj <- scrolledWindowGetVAdjustment swc + ps <- adjustmentGetPageSize aj + vl <- adjustmentGetValue aj + ur <- adjustmentGetUpper aj + lr <- adjustmentGetLower aj + + -- Get y coordinate and height of cell. + cellY <- do + cy <- treeViewGetSelectedCellY view + -- Transform to tree coordinate for compare with adjustment value. + (integralToDouble . snd) <$> treeViewConvertBinWindowToTreeCoords view (0, cy) + ch <- treeViewGetSelectedCellHeight view + let cellH = integralToDouble ch + + -- Update adjustment value. + let inc = integralToDouble $ floorToMultiple (truncate increment) ch + iv = vl + inc + top = if inc >= 0 + then min iv $ ur - cellH -- don't bigger than upper value when scroll up + else max iv lr -- don't less than lower value when scroll down + bottom = top + ps + + -- Calculate new y coordinate when cell at outside of visible area. + let adjustY | top >= cellY = Just topY + | bottom <= cellY + cellH = Just bottomY + | otherwise = Nothing + where topY = top + 1 + bottomY = integralToDouble $ floorToMultiple (truncate bottom) ch - 1 + + -- Selected new cell when got new y coordinate. + adjustY ?>= \ y -> do + p <- treeViewConvertTreeToBinWindowCoords view (0, truncate y) + treeViewGetPathAtPos view p >?>= + \ (path, _, _) -> treeViewSetCursor view path Nothing + + -- Set adjustment. + adjustmentSetValue aj top + +treeViewAddColumnWithTitle :: TreeViewClass self => self -> String -> SortColumnId -> IO TreeViewColumn +treeViewAddColumnWithTitle treeView title sortId = do + -- Get treeViewColumn. + tvc <- treeViewColumnNew + treeViewAppendColumn treeView tvc + + -- Set attribute. + set tvc [treeViewColumnTitle := title + ,treeViewColumnResizable := True + ,treeViewColumnSortIndicator := True + ,treeViewColumnSortColumnId := sortId] + + return tvc + +-- | Get row. +treeModelSortGetRow :: (TreeModelSortClass self, + TypedTreeModelClass model) + => model row + -> self + -> TreeIter + -> IO row +treeModelSortGetRow model = + (<=<) (treeModelGetRow model) . treeModelSortConvertIterToChildIter + +-- | Get next sort path. +-- Pass unsorted path to get next path in the given sorted model. +-- Very useful to track path after change sort rule. +treeViewNextSortPath :: (TreeViewClass view + ,TreeModelClass sortModel + ,TreeModelSortClass sortModel) + => view + -> sortModel + -> TreePath + -> IO TreePath +treeViewNextSortPath treeView sortModel path = do + -- Converts the given path to a path relative to the given sorted model. + currentIndex <- liftM head $ treeModelSortConvertChildPathToPath sortModel path + -- Get tree view size and index of next path. + size <- treeViewGetToplevelNodeCount treeView + let nextIndex = if currentIndex >= size - 1 + then 0 + else currentIndex + 1 + -- Converts path in the sorted model to a path on the unsorted model on which the given TreeModelSort is based. + treeModelSortConvertPathToChildPath sortModel [nextIndex] + +-- | Get previous sort path. +-- Pass unsorted path to get previous path in the given sorted model. +-- Very useful to track path after change sort rule. +treeViewPrevSortPath :: (TreeViewClass view + ,TreeModelClass sortModel + ,TreeModelSortClass sortModel) + => view + -> sortModel + -> TreePath + -> IO TreePath +treeViewPrevSortPath treeView sortModel path = do + -- Converts the given path to a path relative to the given sorted model. + currentIndex <- liftM head $ treeModelSortConvertChildPathToPath sortModel path + -- Get tree view size and index of prev path. + size <- treeViewGetToplevelNodeCount treeView + let prevIndex = if currentIndex <= 0 + then size - 1 + else currentIndex - 1 + -- Converts path in the sorted model to a path on the unsorted model on which the given TreeModelSort is based. + treeModelSortConvertPathToChildPath sortModel [prevIndex] + +-- | Get current value. +treeViewGetSelectedValue :: (TreeViewClass view + ,TreeModelSortClass self) + => view + -> self + -> ListStore a + -> IO (Maybe a) +treeViewGetSelectedValue view sortModel listStore = + treeViewGetSelectedPath view + >?>=> \ path -> do + currentPath <- treeModelSortConvertPathToChildPath sortModel path + liftM Just $ listStoreGetValue listStore (head currentPath) + diff --git a/Manatee/Toolkit/Gtk/Multiline.hs b/Manatee/Toolkit/Gtk/Multiline.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/Multiline.hs @@ -0,0 +1,1000 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Gtk.Multiline where + +import Control.Monad +import Data.ByteString (ByteString) +import Graphics.UI.Gtk hiding (Statusbar, statusbarNew) +import Manatee.Toolkit.General.Basic +import Manatee.Toolkit.General.Functor +import Manatee.Toolkit.General.Maybe +import System.IO.Unsafe + +-- | Wrap user action. +-- Then user can undo/redo this action. +textBufferWrapAction :: TextBufferClass self => self -> IO () -> IO () +textBufferWrapAction tb action = do + textBufferBeginUserAction tb -- entry in action + action -- execute action + textBufferEndUserAction tb -- entry out action + + +-- | Get text with given text tag. +textBufferGetTagTextWithIter :: TextBufferClass buffer => buffer + -> TextIter + -> TextTag + -> IO (Maybe String) +textBufferGetTagTextWithIter buffer iter tag = do + startIter <- textIterCopy iter + endIter <- textIterCopy iter + moveBackward <- textIterBackwardToTagToggle startIter (Just tag) + moveForward <- textIterForwardToTagToggle endIter (Just tag) + if moveBackward && moveForward + then liftM Just $ textBufferGetText buffer startIter endIter True + else return Nothing + +-- | Get insert text with given text tag. +textBufferGetTagText :: TextBufferClass buffer => buffer + -> TextTag + -> IO (Maybe String) +textBufferGetTagText buffer tag = do + iter <- textBufferGetInsertIter buffer + textBufferGetTagTextWithIter buffer iter tag + +-- | Get bytestring with give text tag. +textBufferGetTagByteStringWithIter :: TextBufferClass buffer => buffer + -> TextIter + -> TextTag + -> IO (Maybe ByteString) +textBufferGetTagByteStringWithIter buffer iter tag = do + startIter <- textIterCopy iter + endIter <- textIterCopy iter + moveBackward <- textIterBackwardToTagToggle startIter (Just tag) + moveForward <- textIterForwardToTagToggle endIter (Just tag) + if moveBackward && moveForward + then liftM Just $ textBufferGetByteString buffer startIter endIter True + else return Nothing + +-- | Get insert text with given text tag. +textBufferGetTagByteString :: TextBufferClass buffer => buffer + -> TextTag + -> IO (Maybe ByteString) +textBufferGetTagByteString buffer tag = do + iter <- textBufferGetInsertIter buffer + textBufferGetTagByteStringWithIter buffer iter tag + +-- | Text buffer keep selection to execute action. +textBufferKeepSelection :: TextBufferClass self => self -> Bool -> Bool -> IO () -> IO () +textBufferKeepSelection tb sLeft eLeft action = do + -- Get selection range. + (sIter, eIter) <- textBufferGetSelectionBounds tb + + -- Decide selection range. + fromUpToDown <- textBufferIsEqualInsertIter tb eIter + + -- Record iter mark. + sMark <- textBufferCreateMark tb Nothing sIter sLeft + eMark <- textBufferCreateMark tb Nothing eIter eLeft + + -- Execute action. + action + + -- Restore iter. + startIter <- textBufferGetIterAtMark tb sMark + endIter <- textBufferGetIterAtMark tb eMark + + -- Restore selection range. + if fromUpToDown + then textBufferSelectRange tb endIter startIter + else textBufferSelectRange tb startIter endIter + + -- Update selection iter. + textBufferUpdateSelectionIter tb + +-- | Move text, tags, and pixbufs between start and end (the order of start and end doesn't matter) to iter. +textBufferMoveRange :: TextBufferClass self => self -> TextIter -> TextIter -> TextIter -> IO () +textBufferMoveRange tb iter start end = + -- Don't do anything when range len is 0. + unlessM (textIterEqual start end) $ do + -- Order range iter first. + textIterOrder start end + -- Move range. + ifM (textIterInRange iter start end) + -- In range. + (do + -- Record iter mark for restore. + sMark <- textBufferCreateMark tb Nothing start True + + -- Get slice. + slice <- textBufferGetSlice tb start end True + + -- Delete old range. + textBufferDelete tb start end + + -- Insert new slice. + textBufferInsertAtMark tb sMark slice) + -- Out range. + (do + -- Record iter mark for restore. + sMark <- textBufferCreateMark tb Nothing start True + eMark <- textBufferCreateMark tb Nothing end True + + -- Insert range. + textBufferInsertRange tb iter start end + + -- Delete old range. + sIter <- textBufferGetIterAtMark tb sMark + eIter <- textBufferGetIterAtMark tb eMark + textBufferDelete tb sIter eIter) + +-- | Cancel selection. +textBufferCancelSelection :: TextBufferClass self => self -> IO () +textBufferCancelSelection tb = do + iter <- textBufferGetInsertIter tb + textBufferSelectRange tb iter iter + +-- | Get text iter at cursor. +textBufferGetInsertIter :: TextBufferClass self => self -> IO TextIter +textBufferGetInsertIter tb = + textBufferGetIterAtMark tb + =<< textBufferGetInsert tb + +-- | Create an iterator at start position of special line. +textBufferGetLineStartIter :: TextBufferClass self => self -> Int -> IO TextIter +textBufferGetLineStartIter = textBufferGetIterAtLine + +-- | Create an iterator at start position of current line. +textBufferGetCurrentLineStartIter :: TextBufferClass self => self -> IO TextIter +textBufferGetCurrentLineStartIter tb = + textBufferGetLineStartIter tb + =<< textBufferGetLine tb + +-- | Create an iterator line delimiter characters, +-- If incLimitincDelimiter is True which will be either a newline, a carriage return, a carriage return/newline in sequence. +-- Otherwise, not include delimiter characters. +textBufferGetLineEndIter :: TextBufferClass self => self -> Int -> Bool -> IO TextIter +textBufferGetLineEndIter tb line incDelimiter = do + -- Get iter. + iter <- textBufferGetInsertIter tb + -- Set line. + textIterSetLine iter line + -- Get chars in line. + chars <- (if incDelimiter + -- Get chars include delimiter. + then textIterGetCharsInLine + -- Get chars not include delimiter. + else textIterGetCharsInLine_ ) iter + -- Set line offset. + textIterSetLineOffset iter chars + return iter + +-- | Create an iterator line delimiter characters, +-- which will be either a newline, a carriage return, a carriage return/newline in sequence. +textBufferGetCurrentLineEndIter :: TextBufferClass self => self -> IO TextIter +textBufferGetCurrentLineEndIter tb = do + line <- textBufferGetLine tb + textBufferGetLineEndIter tb line True + +-- | Create an iterator line delimiter characters, +textBufferGetCurrentLineEndIter_ :: TextBufferClass self => self -> IO TextIter +textBufferGetCurrentLineEndIter_ tb = do + line <- textBufferGetLine tb + textBufferGetLineEndIter tb line False + +-- | Get line from text buffer. +textBufferGetLine :: TextBufferClass self => self -> IO Int +textBufferGetLine tb = + textIterGetLine + =<< textBufferGetInsertIter tb + +-- | Get line offset from text buffer. +textBufferGetLineOffset :: TextBufferClass self => self -> IO Int +textBufferGetLineOffset tb = + textIterGetLineOffset + =<< textBufferGetInsertIter tb + +{-# NOINLINE textBufferSelectionIter #-} +-- Don't use `TextBufferClass` replace `TextBuffer`, +-- Otherwise, every time you use this attribute, +-- it will be re-evaluate to the definition by compiler. +-- That's to say, you always `get` Nothing. +textBufferSelectionIter :: Attr TextBuffer (Maybe TextIter) +textBufferSelectionIter = unsafePerformIO objectCreateAttribute + +-- | Set text buffer selection iter. +textBufferSetSelectionIter :: TextBufferClass self => self -> TextIter -> IO () +textBufferSetSelectionIter tb ti = + set (toTextBuffer tb) [textBufferSelectionIter := Just ti] + +-- | Remove text buffer selection iter. +textBufferRemoveSelectionIter :: TextBufferClass self => self -> IO () +textBufferRemoveSelectionIter tb = + set (toTextBuffer tb) [textBufferSelectionIter := Nothing] + +-- | Get text buffer selection iter. +textBufferGetSelectionIter :: TextBufferClass self => self -> IO (Maybe TextIter) +textBufferGetSelectionIter tb = + get (toTextBuffer tb) textBufferSelectionIter + +-- | Update selection iter after buffer changed. +-- If selection active, just update SelectionIter, +-- otherwise set Nothing. +textBufferUpdateSelectionIter :: TextBufferClass self => self -> IO () +textBufferUpdateSelectionIter tb = + ifM (textBufferHasSelection tb) + (textBufferSetSelectionIter tb + =<< textBufferGetSelectionBoundIter tb) + (textBufferRemoveSelectionIter tb) + +-- | Get selection bound line. +textBufferGetSelectionBoundLines :: TextBufferClass self => self -> IO (TextIter, TextIter, Bool, Bool) +textBufferGetSelectionBoundLines tb = do + -- Whether active selection. + hasSelect <- textBufferHasSelection tb + if hasSelect + -- Get iterator of selection bound. + then do + (sIter, eIter) <- textBufferGetSelectionBounds tb + firstLine <- textIterIsFirstLine sIter + lastLine <- textIterIsLastLine eIter + textIterBackwardToLineStart sIter + chars <- textIterGetCharsInLine eIter + textIterSetLineOffset eIter chars + + return (sIter, eIter, firstLine, lastLine) + -- Get iterator of current line. + else do + sIter <- textBufferGetCurrentLineStartIter tb + eIter <- textBufferGetCurrentLineEndIter tb + firstLine <- textIterIsFirstLine sIter + lastLine <- textIterIsLastLine sIter + + return (sIter, eIter, firstLine, lastLine) + +-- | Get bound iter of selection region. +textBufferGetSelectionBoundIter :: TextBufferClass self => self -> IO TextIter +textBufferGetSelectionBoundIter tb = (<=<) (textBufferGetIterAtMark tb) textBufferGetSelectionBound tb + +-- | Get insert iter of selection region. +textBufferGetSelectionInsertIter :: TextBufferClass self => self -> IO TextIter +textBufferGetSelectionInsertIter = textBufferGetInsertIter + +-- | Is equal current InsertIter? +textBufferIsEqualInsertIter :: TextBufferClass self => self -> TextIter -> IO Bool +textBufferIsEqualInsertIter tb ti = + textIterEqual ti + =<< textBufferGetInsertIter tb + +-- | Delete last char. +textBufferDeleteLastChar :: TextBufferClass self => self -> IO () +textBufferDeleteLastChar tb = do + -- Get start and end iter for last char. + startIter <- textBufferGetEndIter tb + endIter <- textIterCopy startIter + textIterBackwardChar startIter + + -- Delete last char. + textBufferDelete tb startIter endIter + +-- | Text buffer newline at mark. +textBufferInsertNewlineAtMark :: TextBufferClass self => self -> TextMark -> IO () +textBufferInsertNewlineAtMark tb mark = + textBufferInsertAtMark tb mark "\n" + +-- | Text buffer insert at mark. +textBufferInsertAtMark :: TextBufferClass self => self -> TextMark -> String -> IO () +textBufferInsertAtMark tb mark str = do + -- Get iter. + iter <- textBufferGetIterAtMark tb mark + + -- Insert at mark. + textBufferInsert tb iter str + +-- | Text view place cursor. +-- Move insert to iter, then scroll text view to visible area of widget. +textViewPlaceCursor :: TextViewClass self => self -> TextIter -> IO () +textViewPlaceCursor tv ti = do + tb <- textViewGetBuffer tv + textBufferPlaceCursor tb ti + textViewScrollCursorOnscreen tv + +-- | Place cursor with mark. +textViewPlaceCursorWithMark :: TextViewClass self => self -> TextMark -> IO () +textViewPlaceCursorWithMark tv tm = do + tb <- textViewGetBuffer tv + iter <- textBufferGetIterAtMark tb tm + textViewPlaceCursor tv iter + +-- | Goto line. +-- If line number not in buffer bound, goto min/max line. +textViewGotoLine :: TextViewClass self => self -> Int -> IO () +textViewGotoLine tv line = do + tb <- textViewGetBuffer tv + lineCount <- textBufferGetLineCount tb + let lineNumber + | line <= 1 + = 1 + | line > lineCount + = lineCount + | otherwise + = line + -- Line number count from 0, so need increase '1' + iter <- textBufferGetIterAtLine tb (lineNumber - 1) + textViewPlaceCursor tv iter + +-- | Goto column. +-- If column number not in buffer bound, goto start/end of line. +textViewGotoColumn :: TextViewClass self => self -> Int -> IO () +textViewGotoColumn tv column = do + tb <- textViewGetBuffer tv + currentIter <- textBufferGetInsertIter tb + columnCount <- textIterGetCharsInLine_ currentIter + let columnNumber + | column <= 0 + = 0 + | column > columnCount + = columnCount + | otherwise + = column + currentLine <- textIterGetLine currentIter + columnIter <- textBufferGetIterAtLineOffset tb currentLine columnNumber + textViewPlaceCursor tv columnIter + +-- | Text view wrap user action. +textViewWrapAction :: TextViewClass self => self -> IO () -> IO () +textViewWrapAction tv action = do + tb <- textViewGetBuffer tv + textBufferWrapAction tb action + +-- | Text View load file. +textViewLoadFile :: TextViewClass self => self -> FilePath -> IO () +textViewLoadFile tv path = textViewSetText tv =<< readFile path + +-- | Set text. +textViewSetText :: TextViewClass self => self -> String -> IO () +textViewSetText tv str = do + tb <- textViewGetBuffer tv + textBufferSetText tb str + +-- | Get text iter from text view. +textViewGetTextIter :: TextViewClass self => self -> IO TextIter +textViewGetTextIter tv = + textBufferGetInsertIter + =<< textViewGetBuffer tv + +-- | Move text iter +textViewMoveTextIter :: (TextViewClass self, ScrolledWindowClass swc) => (TextIter -> IO Bool) -> self -> swc -> IO () +textViewMoveTextIter move tv sw = do + -- Action for text iter. + ti <- textViewGetTextIter tv + move ti + + -- Move cursor place. + tb <- textViewGetBuffer tv + textBufferPlaceCursor tb ti + + -- Scroll view to mark of iter. + aj <- scrolledWindowGetVAdjustment sw + vl <- adjustmentGetValue aj + y <- (<<<=) (integralToDouble . fst) (textViewGetLineYrange tv) + =<< textViewGetTextIter tv + if y <= vl + -- When mark below or equal current top y coordinate. + -- just scroll page to avoid screen jump from top to end. + then adjustmentSetValue aj y + -- Otherwise scroll screen to including mark. + else textViewScrollCursorOnscreen tv + + return () + +-- | Forward line. +textViewForwardLine :: (TextViewClass self, ScrolledWindowClass swc) => self -> swc -> IO () +textViewForwardLine = + textViewMoveTextIter $ \iter -> do + -- Whether at last line. + lastLine <- textIterIsLastLine iter + -- Do nothing when at last line. + unless lastLine $ textIterForwardLine iter >> return () + return True + +-- | Backward line. +textViewBackwardLine :: (TextViewClass self, ScrolledWindowClass swc) => self -> swc -> IO () +textViewBackwardLine = textViewMoveTextIter textIterBackwardLine + +-- | Forward char. +textViewForwardChar :: (TextViewClass self, ScrolledWindowClass swc) => self -> swc -> IO () +textViewForwardChar = textViewMoveTextIter textIterForwardChar + +-- | Backward char. +textViewBackwardChar :: (TextViewClass self, ScrolledWindowClass swc) => self -> swc -> IO () +textViewBackwardChar = textViewMoveTextIter textIterBackwardChar + +-- | Forward word. +textViewForwardWord :: (TextViewClass self, ScrolledWindowClass swc) => self -> swc -> IO () +textViewForwardWord = textViewMoveTextIter textIterForwardWordEnd + +-- | Backward word. +textViewBackwardWord :: (TextViewClass self, ScrolledWindowClass swc) => self -> swc -> IO () +textViewBackwardWord = textViewMoveTextIter textIterBackwardWordStart + +-- | Move to buffer beginning. +textViewBegin :: (TextViewClass self, ScrolledWindowClass swc) => self -> swc -> IO () +textViewBegin = + textViewMoveTextIter $ \t -> textIterBackwardToStart t >> return True + +-- | Move to buffer end. +textViewEnd :: (TextViewClass self, ScrolledWindowClass swc) => self -> swc -> IO () +textViewEnd = + textViewMoveTextIter $ \t -> textIterForwardToEnd t >> return True + +-- | Get text. +textViewGetText :: TextViewClass self => self -> IO String +textViewGetText tv = do + tb <- textViewGetBuffer tv + (start, end) <- textBufferGetBounds tb + textBufferGetText tb start end True + +-- | Get current line. +textViewGetCurrentLineContent :: TextViewClass self => self -> IO String +textViewGetCurrentLineContent tv = do + -- Get text buffer. + tb <- textViewGetBuffer tv + + -- Get line start and end iter. + startIter <- textBufferGetCurrentLineStartIter tb + endIter <- textBufferGetCurrentLineEndIter_ tb + + -- Get current line. + textBufferGetText tb startIter endIter True + +-- | Get current line number. +textViewGetLine :: TextViewClass self => self -> IO Int +textViewGetLine = + (<<<=) succ ((<=<) textIterGetLine textViewGetTextIter) + +-- | Get current column number +textViewGetColumn :: TextViewClass self => self -> IO Int +textViewGetColumn = + (<=<) textIterGetLineOffset textViewGetTextIter + +-- | Select all. +textViewSelectAll :: TextViewClass self => self -> IO () +textViewSelectAll tv = do + -- Get text buffer. + tb <- textViewGetBuffer tv + + -- Get start end iter. + (start, end) <- textBufferGetBounds tb + + -- Selection all. + textBufferSelectRange tb start end + + -- Update selection iter. + textBufferUpdateSelectionIter tb + +-- | Delete. +textViewDelete :: TextViewClass self => self -> Bool -> Bool -> IO Bool +textViewDelete tv interactive defaultEditable = do + tb <- textViewGetBuffer tv + textBufferDeleteSelection tb interactive defaultEditable + +-- | Cut. +textViewCut :: TextViewClass self => self -> IO () +textViewCut tv = do + tb <- textViewGetBuffer tv + clip <- clipboardGet selectionClipboard + textBufferCutClipboard tb clip True + +-- | Copy. +textViewCopy :: TextViewClass self => self -> IO () +textViewCopy tv = do + tb <- textViewGetBuffer tv + clip <- clipboardGet selectionClipboard + textBufferCopyClipboard tb clip + +-- | Paste. +textViewPaste :: TextViewClass self => self -> IO () +textViewPaste tv = do + tb <- textViewGetBuffer tv + clip <- clipboardGet selectionClipboard + textBufferPasteClipboardAtCursor tb clip True + +-- | Delete forward char. +textViewDeleteForwardChar :: TextViewClass self => self -> Bool -> IO Bool +textViewDeleteForwardChar tv = + textViewDeleteBound tv textIterForwardChar + +-- | Delete backward char. +textViewDeleteBackwardChar :: TextViewClass self => self -> Bool -> IO Bool +textViewDeleteBackwardChar tv = + textViewDeleteBound tv textIterBackwardChar + +-- | Delete forward word. +textViewDeleteForwardWord :: TextViewClass self => self -> Bool -> IO Bool +textViewDeleteForwardWord tv = + textViewDeleteBound tv textIterForwardWordEnd + +-- | Delete backward word. +textViewDeleteBackwardWord :: TextViewClass self => self -> Bool -> IO Bool +textViewDeleteBackwardWord tv = + textViewDeleteBound tv textIterBackwardWordStart + +-- | Delete to line end. +textViewDeleteToLineEnd :: TextViewClass self => self -> Bool -> IO Bool +textViewDeleteToLineEnd tv = + textViewDeleteBound tv textIterForwardToLineEnd + +-- | Delete to line start. +textViewDeleteToLineStart :: TextViewClass self => self -> Bool -> IO Bool +textViewDeleteToLineStart tv = + textViewDeleteBound tv (\t -> textIterBackwardToLineStart t >> return True) + +-- | Delete bound. +textViewDeleteBound :: TextViewClass self => self -> (TextIter -> IO Bool) -> Bool -> IO Bool +textViewDeleteBound tv move deleteWhenEditable = do + -- Get text buffer. + tb <- textViewGetBuffer tv + + -- Get start iter. + start <- textViewGetTextIter tv + offset <- textIterGetOffset start + + -- Move iter. + move start + + -- Get end iter. + end <- textViewGetTextIter tv + + -- Build delete/restore action. + let deleteAction = do + textBufferDelete tb start end + return True + restoreAction = do + textIterSetOffset end offset + return False + + isEditable <- textIterBoundIsEditable (start, end) + if deleteWhenEditable && not isEditable + -- Restore if can't delete. + then restoreAction + -- Otherwise delete bound. + else deleteAction + +-- | Duplicate lines. +-- Just duplicate current line to below if haven't selection anything. +-- Otherwise duplicate selection lines to below. +textViewDupLines :: TextViewClass self => self -> Bool -> IO () +textViewDupLines tv dupBelow = do + -- Get text buffer. + tb <- textViewGetBuffer tv + + -- Get selection bound line. + (sIter, eIter, _, lastLine) <- textBufferGetSelectionBoundLines tb + + if dupBelow + -- Duplicate below. + then textBufferKeepSelection tb True True $ + do + -- Record end iter mark. + eMark <- textBufferCreateMark tb Nothing eIter True -- make mark before insert + + -- Insert duplicate content. + textBufferInsertRange tb eIter sIter eIter + + -- Add newline after end iterator when end iter at last line of buffer. + when lastLine $ textBufferInsertNewlineAtMark tb eMark + -- Duplicate above + else textBufferKeepSelection tb False False $ + do + -- Record start iter mark. + sMark <- textBufferCreateMark tb Nothing sIter False -- make mark after insert + + -- Insert duplicate content. + textBufferInsertRange tb sIter sIter eIter + + -- Add newline before start iter when start iter at last line of buffer. + when lastLine $ textBufferInsertNewlineAtMark tb sMark + +textViewDupLinesBelow, textViewDupLinesAbove :: TextViewClass self => self -> IO () +textViewDupLinesBelow tv = textViewDupLines tv True +textViewDupLinesAbove tv = textViewDupLines tv False + +-- | Transposes lines. +-- Just transposes current line to below if haven't selection anything. +-- Otherwise transposes selection lines to below. +textViewTraLines :: TextViewClass self => self -> Bool -> IO () +textViewTraLines tv traBelow = do + -- Get text buffer. + tb <- textViewGetBuffer tv + + -- Get selection bound line. + (sIter, eIter, firstLine, lastLine) <- textBufferGetSelectionBoundLines tb + + -- Transposes lines. + if traBelow + then + unless lastLine $ textBufferKeepSelection tb False False $ + do + -- Record iter mark. + sMark <- textBufferCreateMark tb Nothing sIter False + eMark <- textBufferCreateMark tb Nothing eIter False + + -- Get start and end iter to move. + trasStartIter <- textIterCopy eIter + trasEndIter <- textIterCopy eIter + atLastLine <- textIterIsLastLine eIter + chars <- textIterGetCharsInLine eIter + textIterSetLineOffset trasEndIter chars + + -- Move range. + textBufferMoveRange tb sIter trasStartIter trasEndIter + + -- Adjust when reach last line. + when atLastLine $ do + -- Insert new line. + textBufferInsertNewlineAtMark tb sMark + + -- Delete last char. + textBufferDeleteLastChar tb + + -- Scroll screen to display iter. + textViewScrollMarkOnscreen tv eMark + else + unless firstLine $ textBufferKeepSelection tb True True $ + do + -- Record iter mark. + sMark <- textBufferCreateMark tb Nothing sIter True + eMark <- textBufferCreateMark tb Nothing eIter True + + -- Get start and end iter to move. + trasStartIter <- textIterCopy sIter + trasEndIter <- textIterCopy sIter + textIterBackwardLine trasStartIter + + -- Move range. + textBufferMoveRange tb eIter trasStartIter trasEndIter + + -- Adjust when reach last line. + when lastLine $ do + -- Insert newline. + textBufferInsertNewlineAtMark tb eMark + + -- Delete last char. + textBufferDeleteLastChar tb + + -- Scroll screen to display iter. + textViewScrollMarkOnscreen tv sMark + +textViewTraLinesBelow, textViewTraLinesAbove :: TextViewClass self => self -> IO () +textViewTraLinesBelow tv = textViewTraLines tv True +textViewTraLinesAbove tv = textViewTraLines tv False + +-- | Delete lines. +-- Just delete current line to below if haven't selection anything. +-- Otherwise delete selection lines to below. +-- Return 'False' if in uneditable area. +textViewDelLines :: TextViewClass self => self -> IO Bool +textViewDelLines tv = do + -- Get text buffer. + tb <- textViewGetBuffer tv + + -- Get selection bound line. + (sIter, eIter, _, lastLine) <- textBufferGetSelectionBoundLines tb + + isEditable <- textIterBoundIsEditable (sIter, eIter) + if isEditable + -- Just delete lines when in editable area. + then do + -- Delete lines. + textBufferDelete tb sIter eIter + + -- Adjust when reach last line. + when lastLine $ do + -- Delete last char. + textViewDeleteBackwardChar tv False + + -- Move to line start. + iter <- textViewGetTextIter tv + textIterBackwardToLineStart iter + textBufferPlaceCursor tb iter + + return True + else return False + +-- | Smart home. +textViewSmartHome :: TextViewClass self => self -> IO () +textViewSmartHome tv = do + -- Get iter information. + ti <- textViewGetTextIter tv + lo <- textIterGetLineOffset ti + tb <- textViewGetBuffer tv + + -- Move to line end and got search limit. + textIterForwardToLineEnd_ ti + limit <- textIterCopy ti + + -- Init to line start and search forward visible char. + textIterBackwardToLineStart ti + + -- Move iter. + ifM (textIterForwardFindChar ti (/= ' ') (Just limit)) + (do + nlo <- textIterGetLineOffset ti + if lo == nlo || nlo == 1 + -- Move to line start when iter at indent position + -- or current line is empty line. + then textIterBackwardToLineStart ti + -- Otherwise move to line indent position. + else textIterSetLineOffset ti nlo) + -- Move to line start when search failed. + (textIterBackwardToLineStart ti) + + -- Move cursor to iter place. + textBufferPlaceCursor tb ti + +-- | Smart end. +textViewSmartEnd :: TextViewClass self => self -> IO () +textViewSmartEnd tv = do + -- Get iter information. + ti <- textViewGetTextIter tv + lo <- textIterGetLineOffset ti + tb <- textViewGetBuffer tv + + -- Move to line start and got search limit + textIterBackwardToLineStart ti + limit <- textIterCopy ti + + -- Init to line end and search backward visible char. + textIterForwardToLineEnd_ ti + + -- Move iter. + ifM (textIterBackwardFindChar ti (/= ' ') (Just limit)) + (do + nlo <- textIterGetLineOffset ti + let nl = nlo + 1 + if lo == nl || nlo == 0 + -- Move to line end when iter at last visible char + -- or current line is empty line. + then textIterForwardToLineEnd_ ti + -- Otherwise move to last visible char. + else textIterSetLineOffset ti nl) + -- Move to line end when search failed. + (textIterForwardToLineEnd_ ti) + + -- Move cursor to iter place. + textBufferPlaceCursor tb ti + +-- | Scroll vertical. +textViewScrollVertical :: (TextViewClass tvc, ScrolledWindowClass swc) => tvc -> swc -> Double -> IO () +textViewScrollVertical tv sw inc = do + -- Get adjustment arguments. + aj <- scrolledWindowGetVAdjustment sw + ps <- adjustmentGetPageSize aj + vl <- adjustmentGetValue aj + ur <- adjustmentGetUpper aj + lr <- adjustmentGetLower aj + + -- Get text iter arguments. + ti <- textViewGetTextIter tv + tb <- textViewGetBuffer tv + (y, lnH) <- textViewGetLineYrange tv ti + + -- Adjust scroll value. + let iv = vl + inc + av = if inc >= 0 + -- Don't bigger than upper value when scroll up. + then min iv (ur - integralToDouble lnH) + -- Don't less than lower value when scroll down. + else max iv lr + adjustmentSetValue aj av + + -- Adjust iter position. + top <- adjustmentGetValue aj + let bottom = top + ps + if top >= integralToDouble y + -- Adjust iter to first line in view visual port + -- when iter is up out view visual port. + then do + (nti, _) <- textViewGetLineAtY tv (truncate top) + textBufferPlaceCursor tb nti + -- Adjust iter to last line in view visual port + -- when iter is down out view virtual port. + else when (bottom <= integralToDouble (y + lnH)) $ + do + (nti, _) <- textViewGetLineAtY tv (truncate (bottom - integralToDouble lnH)) + textBufferPlaceCursor tb nti + +-- | Toggle selection. +textViewToggleSelectionMark :: TextViewClass self => self -> IO () +textViewToggleSelectionMark tv = do + -- Get text buffer. + tb <- textViewGetBuffer tv + + -- Whether selection active. + selectionActive <- textBufferHasSelection tb + + -- Toggle selection iter. + if selectionActive + then textViewCancelSelectionMark tv + else textViewSetSelectionMark tv + +-- | Exchange selection mark. +textViewExchangeSelectionMark :: TextViewClass self => self -> IO () +textViewExchangeSelectionMark tv = do + -- Get text buffer. + tb <- textViewGetBuffer tv + + -- Whether selection active. + selectionActive <- textBufferHasSelection tb + + -- Exchange selection mark when selection active. + when selectionActive $ do + -- Get insert and bound iter. + (sIter, eIter) <- textBufferGetSelectionBounds tb + -- Get new iter along with selection direction. + selectionAbove <- textBufferIsEqualInsertIter tb sIter + let (startIter, endIter) = + if selectionAbove + then (eIter, sIter) + else (sIter, eIter) + -- Set selection mark. + textBufferSetSelectionIter tb endIter + -- Set selection range. + textBufferSelectRange tb startIter endIter + -- Move current cursor in screen. + textViewScrollCursorOnscreen tv + +-- | Scroll text view the minimum distance such that cursor is contained within the visible area of widget. +textViewScrollCursorOnscreen :: TextViewClass self => self -> IO () +textViewScrollCursorOnscreen tv = + textViewScrollMarkOnscreen tv + =<< (<=<) textBufferGetInsert textViewGetBuffer tv + +-- | Set selection. +textViewSetSelectionMark :: TextViewClass self => self -> IO () +textViewSetSelectionMark tv = do + -- Get text buffer. + tb <- textViewGetBuffer tv + + -- Cancel selection first. + textBufferCancelSelection tb + + -- Set new selection iter. + textBufferSetSelectionIter tb + =<< textViewGetTextIter tv + +-- | Cancel selection. +textViewCancelSelectionMark :: TextViewClass self => self -> IO () +textViewCancelSelectionMark tv = do + -- Get text buffer. + tb <- textViewGetBuffer tv + + -- Cancel selection first. + textBufferCancelSelection tb + + -- Cancel new selection iter. + textBufferRemoveSelectionIter tb + +-- | Apply selection. +textViewApplySelectionMark :: TextViewClass self => self -> IO () +textViewApplySelectionMark tv = do + tb <- textViewGetBuffer tv + textBufferGetSelectionIter tb >>= + (?>= (\markIter -> do + -- Get insert iter. + insertIter <- textBufferGetInsertIter tb + -- Selection range. + textBufferSelectRange tb insertIter markIter)) + +-- | Text view newline. +textViewNewLine :: TextViewClass self => self -> IO () +textViewNewLine tv = + textViewInsertAtCursor tv "\n" + +-- | Insert string at cursor. +textViewInsertAtCursor :: TextViewClass self => self -> String -> IO () +textViewInsertAtCursor tv str = do + -- Cancel selection first. + tb <- textViewGetBuffer tv + textBufferCancelSelection tb + -- Insert string. + textBufferInsertAtCursor tb str + -- Scroll cursor to screen. + textViewScrollCursorOnscreen tv + +-- | Move to next line and then opens a line. +textViewOpenNewlineBelow :: (TextViewClass self, ScrolledWindowClass swc) => self -> swc -> IO () +textViewOpenNewlineBelow tv swc = do + -- Get text buffer and iter. + tb <- textViewGetBuffer tv + iter <- textViewGetTextIter tv + -- Whether in blank line. + inBlankLine <- textIterInBlankLine iter + -- Move iter to line end and insert newline. + textIterForwardToLineEnd_ iter + textBufferInsert tb iter "\n" + -- Don't forward line at blank line. + unless inBlankLine $ textViewForwardLine tv swc + +-- | Move to previous line and then opens a line. +textViewOpenNewlineAbove :: (TextViewClass self, ScrolledWindowClass swc) => self -> swc -> IO () +textViewOpenNewlineAbove tv swc = do + -- Get text buffer and iter. + tb <- textViewGetBuffer tv + iter <- textViewGetTextIter tv + -- Move iter to line start and insert newline. + textIterBackwardToLineStart iter + textBufferInsert tb iter "\n" + -- Backward line. + textViewBackwardLine tv swc + +-- | Move to `first iter` of buffer. +textIterBackwardToStart :: TextIter -> IO () +textIterBackwardToStart ti = do + textIterSetLine ti 0 + textIterBackwardToLineStart ti + +-- | Forward to line end, like textIterForwardToLineEnd, +-- but don't move to next line when current line is empty. +textIterForwardToLineEnd_ :: TextIter -> IO () +textIterForwardToLineEnd_ ti = + textIterSetLineOffset ti + =<< textIterGetCharsInLine_ ti + +-- | In blank line. +textIterInBlankLine :: TextIter -> IO Bool +textIterInBlankLine = + (<<<=) (1 ==) textIterGetCharsInLine + +-- | Is first line. +textIterIsFirstLine :: TextIter -> IO Bool +textIterIsFirstLine = + (<<<=) (0 ==) textIterGetLine + +-- | Is last line. +textIterIsLastLine :: TextIter -> IO Bool +textIterIsLastLine ti = do + line <- textIterGetLine ti + lines <- (<=<) textBufferGetLineCount textIterGetBuffer ti + return $ line == (lines - 1) + +-- | Backward to line start. +textIterBackwardToLineStart :: TextIter -> IO () +textIterBackwardToLineStart ti = + textIterSetLineOffset ti 0 + +-- | Return number of characters in this line. +-- The return value not includes delimiters. +textIterGetCharsInLine_ :: TextIter -> IO Int +textIterGetCharsInLine_ ti = do + -- Get number of characters in this line. + chars <- textIterGetCharsInLine ti + ifM (textIterIsLastLine ti) + -- Return chars if at last line. + (return chars) + -- Otherwise not includes delimiter. + (return $ chars - 1) + +-- | Whether selection iter is editable. +textIterBoundIsEditable :: (TextIter, TextIter) -> IO Bool +textIterBoundIsEditable (startIter, endIter) = + liftM2 (&&) + (textIterEditable startIter True) + (textIterEditable endIter True) + diff --git a/Manatee/Toolkit/Gtk/Notebook.hs b/Manatee/Toolkit/Gtk/Notebook.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/Notebook.hs @@ -0,0 +1,151 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Gtk.Notebook where + +import Control.Monad +import Graphics.UI.Gtk +import Manatee.Toolkit.General.Basic +import Manatee.Toolkit.General.Functor +import Manatee.Toolkit.General.Maybe + +-- | In Gtk+ C code, GtkNotebook refuses to switch to a page unless the child widget is visible. +-- So wrap below functions that show child widget before add them to a notebook. +-- Details see documents of `gtk_notebook_set_current_page`. + +notebookAppendPage_ :: (NotebookClass notebook, WidgetClass child) => notebook -> child -> String -> IO Int +notebookAppendPage_ notebook child str = + widgetShowAll child >> notebookAppendPage notebook child str + +notebookAppendPageMenu_ :: (NotebookClass notebook, WidgetClass child, WidgetClass tabLabel, WidgetClass menuLabel) => + notebook -> child -> tabLabel -> menuLabel -> IO Int +notebookAppendPageMenu_ notebook child tabLabel menuLabel = + widgetShowAll child >> widgetShowAll tabLabel >> notebookAppendPageMenu notebook child tabLabel menuLabel + +notebookAppendPageTab_ :: (NotebookClass notebook, WidgetClass child, WidgetClass tabLabel) => + notebook -> child -> tabLabel -> IO Int +notebookAppendPageTab_ notebook child tabLabel = do + menuLabel <- labelNew Nothing + widgetShowAll child >> widgetShowAll tabLabel >> notebookAppendPageMenu notebook child tabLabel menuLabel + +notebookPrependPage_ :: (NotebookClass notebook, WidgetClass child) => notebook -> child -> String -> IO Int +notebookPrependPage_ notebook child str = + widgetShowAll child >> notebookPrependPage notebook child str + +notebookPrependPageMenu_ :: (NotebookClass notebook, WidgetClass child, WidgetClass tabLabel, WidgetClass menuLabel) => + notebook -> child -> tabLabel -> menuLabel -> IO Int +notebookPrependPageMenu_ notebook child tabLabel menuLabel = + widgetShowAll child >> widgetShowAll tabLabel >> notebookPrependPageMenu notebook child tabLabel menuLabel + +notebookPrependPageTab_ :: (NotebookClass notebook, WidgetClass child, WidgetClass tabLabel) => + notebook -> child -> tabLabel -> IO Int +notebookPrependPageTab_ notebook child tabLabel = do + menuLabel <- labelNew Nothing + widgetShowAll child >> widgetShowAll tabLabel >> notebookPrependPageMenu notebook child tabLabel menuLabel + +notebookInsertPage_ :: (NotebookClass notebook, WidgetClass child) => notebook -> child -> String -> Int -> IO Int +notebookInsertPage_ notebook child str pos = + widgetShowAll child >> notebookInsertPage notebook child str pos + +notebookInsertPageMenu_ :: (NotebookClass notebook, WidgetClass child, WidgetClass tabLabel, WidgetClass menuLabel) => + notebook -> child -> tabLabel -> menuLabel -> Int -> IO Int +notebookInsertPageMenu_ notebook child tabLabel menuLabel pos = + widgetShowAll child >> widgetShowAll tabLabel >> notebookInsertPageMenu notebook child tabLabel menuLabel pos + +notebookInsertPageTab_ :: (NotebookClass notebook, WidgetClass child, WidgetClass tabLabel) => + notebook -> child -> tabLabel -> Int -> IO Int +notebookInsertPageTab_ notebook child tabLabel pos = do + menuLabel <- labelNew Nothing + widgetShowAll child >> widgetShowAll tabLabel >> notebookInsertPageMenu notebook child tabLabel menuLabel pos + +-- | Remove child, just remove it's page when child is contained in notebook. +notebookRemoveChild :: (NotebookClass notebook, WidgetClass child) => notebook -> child -> IO () +notebookRemoveChild notebook child = + notebookPageNum notebook child >>= + (?>= notebookRemovePage notebook) + +-- | Insert page and make child reorderable. +notebookInsertReorderPage :: (NotebookClass notebook, WidgetClass child) => notebook -> child -> String -> Int -> IO () +notebookInsertReorderPage notebook child str pos = do + notebookInsertPage_ notebook child str pos + notebookSetTabReorderable notebook child True -- make tab can reorderable + +-- | Focus current page. +notebookFocusCurrentPage :: NotebookClass notebook => notebook -> IO () +notebookFocusCurrentPage notebook = do + -- Focus notebook first. + widgetGrabFocus notebook + + -- Get current page. + page <- notebookGetCurrentPage_ notebook + + -- Focus current page + page ?>= widgetGrabFocus + +-- | Get current page. +-- Like `notebookGetCurrentPage` except use widget instead current page index. +notebookGetCurrentPage_ :: NotebookClass notebook => notebook -> IO (Maybe Widget) +notebookGetCurrentPage_ notebook = + notebookGetCurrentPage notebook + >>= notebookGetNthPage notebook + +-- | Select next page. +notebookSelectNextPage :: NotebookClass notebook => notebook -> IO () +notebookSelectNextPage notebook = + ifF notebook notebookAtEnd notebookSelectFirstPage notebookNextPage + +-- | Select previous page. +notebookSelectPrevPage :: NotebookClass notebook => notebook -> IO () +notebookSelectPrevPage notebook = + ifF notebook notebookAtStart notebookSelectLastPage notebookPrevPage + +-- | Select first page. +notebookSelectFirstPage :: NotebookClass notebook => notebook -> IO () +notebookSelectFirstPage notebook = + notebookSetCurrentPage notebook + =<< notebookFirstIndex notebook + +-- | Select last page. +notebookSelectLastPage :: NotebookClass notebook => notebook -> IO () +notebookSelectLastPage notebook = + notebookSetCurrentPage notebook + =<< notebookLastIndex notebook + +-- | At start. +notebookAtStart :: NotebookClass notebook => notebook -> IO Bool +notebookAtStart notebook = + liftM2 (==) (notebookGetCurrentPage notebook) (notebookFirstIndex notebook) + +-- | At End. +notebookAtEnd :: NotebookClass notebook => notebook -> IO Bool +notebookAtEnd notebook = + liftM2 (==) (notebookGetCurrentPage notebook) (notebookLastIndex notebook) + +-- | Get tab first index. +notebookFirstIndex :: NotebookClass notebook => notebook -> IO Int +notebookFirstIndex _ = return 0 + +-- | Get tab last index. +notebookLastIndex :: NotebookClass notebook => notebook -> IO Int +notebookLastIndex = (<<<=) pred notebookGetNPages + +-- | Set name with given index. +notebookSetTabName :: NotebookClass notebook => notebook -> Int -> String -> IO () +notebookSetTabName notebook index name = + notebookGetNthPage notebook index + >?>= \child -> notebookSetTabLabelText notebook child name diff --git a/Manatee/Toolkit/Gtk/ScrolledWindow.hs b/Manatee/Toolkit/Gtk/ScrolledWindow.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/ScrolledWindow.hs @@ -0,0 +1,138 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Gtk.ScrolledWindow where + +import Graphics.UI.Gtk + +data AdjustmentDirection = AdjustmentVertical + | AdjustmentHorizontal + +-- | Like `scrolledWindowNew', except the scrollbar is present only if needed. +scrolledWindowNew_ :: IO ScrolledWindow +scrolledWindowNew_ = do + scrolledWindow <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy scrolledWindow PolicyAutomatic PolicyAutomatic + return scrolledWindow + +-- | Scroll to begin vertically. +scrolledWindowScrollToTop, scrolledWindowScrollToLeft :: ScrolledWindowClass sw => sw -> IO () +scrolledWindowScrollToTop = + scrolledWindowScrollToLower AdjustmentVertical +scrolledWindowScrollToLeft = + scrolledWindowScrollToLower AdjustmentHorizontal + +-- | Scroll to end vertically. +scrolledWindowScrollToBottom, scrolledWindowScrollToRight :: ScrolledWindowClass sw => sw -> IO () +scrolledWindowScrollToBottom = + scrolledWindowScrollToUpper AdjustmentVertical +scrolledWindowScrollToRight = + scrolledWindowScrollToUpper AdjustmentHorizontal + +-- | Scroll page vertically. +scrolledWindowScrollVerticalPage, scrolledWindowScrollHorizontalPage :: ScrolledWindowClass sw => Bool -> sw -> IO () +scrolledWindowScrollVerticalPage = + scrolledWindowScrollPage AdjustmentVertical +scrolledWindowScrollHorizontalPage = + scrolledWindowScrollPage AdjustmentHorizontal + +scrolledWindowScrollVerticalStep, scrolledWindowScrollHorizontalStep :: ScrolledWindowClass sw => Bool -> sw -> IO () +scrolledWindowScrollVerticalStep = + scrolledWindowScrollStep AdjustmentVertical +scrolledWindowScrollHorizontalStep = + scrolledWindowScrollStep AdjustmentHorizontal + +-- | At top. +scrolledWindowIsAtTop, scrolledWindowIsAtLeft :: ScrolledWindowClass sw => sw -> IO Bool +scrolledWindowIsAtTop = + scrolledWindowIsAtLower AdjustmentVertical +scrolledWindowIsAtLeft = + scrolledWindowIsAtLower AdjustmentHorizontal + +-- | At bottom. +scrolledWindowIsAtBottom, scrolledWindowIsAtRight :: ScrolledWindowClass sw => sw -> IO Bool +scrolledWindowIsAtBottom = + scrolledWindowIsAtUpper AdjustmentVertical +scrolledWindowIsAtRight = + scrolledWindowIsAtUpper AdjustmentHorizontal + +-- | Get adjustment. +scrolledWindowGetAdjustment :: ScrolledWindowClass sw => sw -> AdjustmentDirection -> IO Adjustment +scrolledWindowGetAdjustment sw AdjustmentVertical = + scrolledWindowGetVAdjustment sw +scrolledWindowGetAdjustment sw AdjustmentHorizontal = + scrolledWindowGetHAdjustment sw + +-- | Scroll to begin vertically. +scrolledWindowScrollToLower :: ScrolledWindowClass sw => AdjustmentDirection -> sw -> IO () +scrolledWindowScrollToLower direction sw = do + aj <- scrolledWindowGetAdjustment sw direction + lo <- adjustmentGetLower aj + adjustmentSetValue aj lo + +-- | Scroll to end vertically. +scrolledWindowScrollToUpper :: ScrolledWindowClass sw => AdjustmentDirection -> sw -> IO () +scrolledWindowScrollToUpper direction sw = do + aj <- scrolledWindowGetAdjustment sw direction + up <- adjustmentGetUpper aj + ps <- adjustmentGetPageSize aj + adjustmentSetValue aj (up - ps) + +-- | Scroll page vertically. +scrolledWindowScrollPage :: ScrolledWindowClass sw => AdjustmentDirection -> Bool -> sw -> IO () +scrolledWindowScrollPage direction isDown sw = do + aj <- scrolledWindowGetAdjustment sw direction + ps <- adjustmentGetPageSize aj + lo <- adjustmentGetLower aj + up <- adjustmentGetUpper aj + cr <- adjustmentGetValue aj + adjustmentSetValue aj (if isDown + then min (up - ps) (cr + ps) + else max lo (cr - ps)) + +-- | Scroll page vertically. +scrolledWindowScrollStep :: ScrolledWindowClass sw => AdjustmentDirection -> Bool -> sw -> IO () +scrolledWindowScrollStep direction isDown sw = do + aj <- scrolledWindowGetAdjustment sw direction + si <- adjustmentGetStepIncrement aj + ps <- adjustmentGetPageSize aj + lo <- adjustmentGetLower aj + up <- adjustmentGetUpper aj + cr <- adjustmentGetValue aj + adjustmentSetValue aj (if isDown + then min (up - ps) (cr + si) + else max lo (cr - si)) + +-- | At top. +scrolledWindowIsAtLower :: ScrolledWindowClass sw => AdjustmentDirection -> sw -> IO Bool +scrolledWindowIsAtLower direction sw = do + aj <- scrolledWindowGetAdjustment sw direction + lo <- adjustmentGetLower aj + cr <- adjustmentGetValue aj + return (cr <= lo) + +-- | At bottom. +scrolledWindowIsAtUpper :: ScrolledWindowClass sw => AdjustmentDirection -> sw -> IO Bool +scrolledWindowIsAtUpper direction sw = do + aj <- scrolledWindowGetAdjustment sw direction + ps <- adjustmentGetPageSize aj + up <- adjustmentGetUpper aj + cr <- adjustmentGetValue aj + return (cr >= up - ps) + + diff --git a/Manatee/Toolkit/Gtk/Struct.hs b/Manatee/Toolkit/Gtk/Struct.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Gtk/Struct.hs @@ -0,0 +1,49 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Gtk.Struct where + +import Data.Function +import Data.Ord +import Graphics.UI.Gtk.Gdk.DrawWindow (NativeWindowId, fromNativeWindowId, toNativeWindowId) + +newtype GWindowId = GWindowId NativeWindowId + +instance Show GWindowId where + show = show . fromNativeWindowId . getInternalWindowId + +instance Eq GWindowId where + (==) = (==) `on` getInternalWindowId + +instance Ord GWindowId where + compare = comparing (fromIntegral . fromNativeWindowId . getInternalWindowId) + +instance Read GWindowId where + readsPrec _ str = [(GWindowId (toNativeWindowId id), idStr) + | (id, idStr) <- reads str] + +instance Num GWindowId where + (+) = (+) `on` fromIntegral . fromNativeWindowId . getInternalWindowId + (*) = (*) `on` fromIntegral . fromNativeWindowId . getInternalWindowId + abs = abs . fromIntegral . fromNativeWindowId . getInternalWindowId + signum = signum . fromIntegral . fromNativeWindowId . getInternalWindowId + fromInteger = GWindowId . toNativeWindowId + +-- | Get NativeWindowId. +getInternalWindowId :: GWindowId -> NativeWindowId +getInternalWindowId (GWindowId id) = id diff --git a/Manatee/Toolkit/Widget/Interactivebar.hs b/Manatee/Toolkit/Widget/Interactivebar.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Widget/Interactivebar.hs @@ -0,0 +1,121 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Widget.Interactivebar where + +import Graphics.UI.Gtk +import Manatee.Toolkit.General.Basic +import Manatee.Toolkit.General.Maybe +import Manatee.Toolkit.Gtk.Box +import Manatee.Toolkit.Gtk.Container +import Manatee.Toolkit.Gtk.Editable +import Manatee.Toolkit.Gtk.Gtk + +data Interactivebar = + Interactivebar {interactivebarFrame :: Frame -- frame for decorative + ,interactivebarBox :: HBox -- box for container + ,interactivebarTitleLabel :: Label -- title label + ,interactivebarEntry :: Entry -- main entry + } + +type InteractivebarTitle = String +type InteractivebarEntryStatus = EditableStatus +type InteractivebarStatus = (InteractivebarTitle, InteractivebarEntryStatus) + +-- | Create new interactivebar. +interactivebarNew :: IO Interactivebar +interactivebarNew = do + -- Create interactivebar. + frame <- frameNew + box <- hBoxNew False 0 + title <- labelNew $ Just "" + entry <- entryNew + + -- Connect module. + frame `containerAdd` box + boxTryPack box title PackNatural (Just 0) Nothing + boxTryPack box entry PackGrow (Just 1) Nothing + + return $ Interactivebar frame box title entry + +-- | Clone interactivebar. +interactivebarClone :: BoxClass box => box -> Interactivebar -> IO Interactivebar +interactivebarClone box oldBar = do + newBar <- interactivebarNew + + -- Clone status. + interactivebarGetStatus oldBar + >?>= \status -> do + -- Set status. + interactivebarSetStatus newBar status + -- Show. + interactivebarShow box newBar + + return newBar + +-- | Set title. +interactivebarSetTitle :: Interactivebar -> String -> IO () +interactivebarSetTitle bar = + labelSetText (interactivebarTitleLabel bar) + +-- | Set content. +interactivebarSetContent :: Interactivebar -> String -> IO () +interactivebarSetContent bar = + editableSetText (interactivebarEntry bar) + +-- | Show interactivebar. +interactivebarShow :: BoxClass box => box -> Interactivebar -> IO () +interactivebarShow b bar = do + -- Init. + let iFrame = interactivebarFrame bar + + -- Connect to frame. + boxTryPack (toBox b) iFrame PackNatural (Just 0) Nothing + + -- Focus entry. + widgetShowAll iFrame + editableFocus (interactivebarEntry bar) + +-- | Exit interactivebar. +interactivebarExit :: BoxClass box => box -> Interactivebar -> IO () +interactivebarExit b = + containerTryRemove (toBox b) . interactivebarFrame + +-- | Is visible. +interactivebarIsVisible :: Interactivebar -> IO Bool +interactivebarIsVisible = + widgetHasParent . interactivebarFrame + +-- | Set status. +interactivebarSetStatus :: Interactivebar -> InteractivebarStatus -> IO () +interactivebarSetStatus bar (title, entryStatus) = do + interactivebarSetTitle bar title + editableSetStatus (interactivebarEntry bar) entryStatus + +-- | Get interactivebar status. +-- Return Nothing if interactivebar is not visible. +interactivebarGetStatus :: Interactivebar -> IO (Maybe InteractivebarStatus) +interactivebarGetStatus bar = + ifM (interactivebarIsVisible bar) + (do + title <- labelGetText $ interactivebarTitleLabel bar + entryStatus <- editableGetStatus $ interactivebarEntry bar + return $ Just (title, entryStatus)) + (return Nothing) + + diff --git a/Manatee/Toolkit/Widget/NotebookTab.hs b/Manatee/Toolkit/Widget/NotebookTab.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Widget/NotebookTab.hs @@ -0,0 +1,77 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Widget.NotebookTab where + +import Data.Maybe +import Graphics.UI.Gtk +import Manatee.Toolkit.Gtk.Box +import Manatee.Toolkit.Gtk.Container +import Manatee.Toolkit.Gtk.Gtk + +data NotebookTab = + NotebookTab {ntBox :: HBox + ,ntSpinner :: Spinner + ,ntLabel :: Label + ,ntCloseButton :: ToolButton + ,ntSize :: Int + } + +-- | Default size. +notebookTabDefaultSize :: Int +notebookTabDefaultSize = 8 + +-- | Create notebook tab. +notebookTabNew :: Maybe String -> Maybe Int -> IO NotebookTab +notebookTabNew name size = do + -- Init. + let iconSize = fromMaybe notebookTabDefaultSize size + box <- hBoxNew False 0 + spinner <- spinnerNew + label <- labelNew name + image <- imageNewFromIcon "gtk-close" iconSize + closeButton <- toolButtonNew (Just image) Nothing + + -- Show. + boxPackStart box label PackRepel 0 + boxPackStart box closeButton PackRepel 0 + widgetShowAll box + + return $ NotebookTab box spinner label closeButton iconSize + +-- | Set tab name. +notebookTabSetName :: NotebookTab -> String -> IO () +notebookTabSetName tab = + labelSetText (ntLabel tab) + +-- | Start spinner animation. +notebookTabStart :: NotebookTab -> IO () +notebookTabStart NotebookTab {ntBox = box + ,ntSpinner = spinner + ,ntSize = size} = do + boxTryPack box spinner PackNatural (Just 0) (Just (size `div` 2)) + spinnerStart spinner + widgetShow spinner + +-- | Stop spinner animation. +notebookTabStop :: NotebookTab -> IO () +notebookTabStop NotebookTab {ntBox = box + ,ntSpinner = spinner} = do + containerTryRemove box spinner + spinnerStop spinner + diff --git a/Manatee/Toolkit/Widget/Outputbar.hs b/Manatee/Toolkit/Widget/Outputbar.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Widget/Outputbar.hs @@ -0,0 +1,86 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Widget.Outputbar where + +import Control.Concurrent.STM +import Graphics.UI.Gtk +import Manatee.Toolkit.General.Functor +import Manatee.Toolkit.General.Maybe +import Manatee.Toolkit.General.STM +import Manatee.Toolkit.Gtk.Box + +data Outputbar = + Outputbar {outputbarFrame :: Frame -- frame for decorative + ,outputbarLabel :: Label -- label for output + ,outputbarHandlerId :: TVar (Maybe HandlerId) -- handlerId for track timeout + } + +-- | Background color. +outputbarBackgroundColor :: Color +outputbarBackgroundColor = Color 62720 62720 46336 + +-- | Create outputbar. +outputbarNew :: IO Outputbar +outputbarNew = do + -- Create frame. + frame <- frameNew + set frame [frameShadowType := ShadowNone] -- don't display frame border + + -- Create box. + box <- hBoxNew False 0 + + -- Create label. + label <- labelNew $ Just "" + + -- Create id. + id <- newTVarIO Nothing + + -- Connect module. + frame `containerAdd` box + boxPackStart box label PackNatural 0 + + return $ Outputbar frame label id + +-- | Show outputbar. +outputbarShow :: BoxClass box => box -> Outputbar -> String -> IO () +outputbarShow box bar str = do + -- Init. + let frame = outputbarFrame bar + label = outputbarLabel bar + handlerId = outputbarHandlerId bar + id <- readTVarIO handlerId + + -- Remove previous timeout handler first. + id ?>= timeoutRemove + + -- Set output. + labelSetText label str + width <- labelGetMaxWidthChars label + set label [labelAttributes := [AttrBackground 0 width outputbarBackgroundColor]] + + -- Keep outputbar display before statusbar of page. + childNumber <- (<<<=) length containerGetChildren box + boxTryPack box frame PackNatural (Just $ pred childNumber) Nothing + + -- Show + widgetShowAll frame + + -- Hide outputbar 10s later. + newId <- timeoutAdd (box `containerRemove` frame >> return False) 10000 + modifyTVarIO handlerId (const $ Just newId) diff --git a/Manatee/Toolkit/Widget/Plug.hs b/Manatee/Toolkit/Widget/Plug.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Widget/Plug.hs @@ -0,0 +1,62 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Widget.Plug where + +import Graphics.UI.Gtk hiding (Plug, plugNew, plugGetId) +import Manatee.Toolkit.Gtk.Struct + +import qualified Graphics.UI.Gtk.Embedding.Plug as P + +data Plug = + Plug {plugBody :: P.Plug -- GtkPlug + ,plugId :: GWindowId -- GtkPlug id + ,plugHandler :: ConnectId P.Plug -- `deleteEvent` signal handler + } + +-- | Create new plug. +plugNew :: Maybe NativeWindowId -> IO Plug +plugNew socketId = do + -- Create body. + plug <- P.plugNew socketId + + -- Get plug id. + plugId <- P.plugGetId plug + + -- This is hacking trick for hide GtkPlug when re-parent GtkSocket. + -- Because current Gtk+ haven't explicit mechanism to re-parent GtkSocket. + -- GtkPlug will destroy when GtkSocket remove from it's container, + -- And `deleteEvent` signal can hide GtkPlug instead destroy it, + -- so we can re-use GtkPlug with `socketAddId` in new GtkSocket container. + -- When you want do "real destroy" action GtkPlug, disable this signal first. + -- Otherwise GtkPlug always live. + handler <- plug `on` deleteEvent $ tryEvent $ return () + + return (Plug plug (GWindowId plugId) handler) + +-- | Destroy plug. +-- Disconnect `deleteEvent` signal before destroy GtkPlug. +-- Make sure GtkPlug destroy completely. +plugDestroy :: Plug -> IO () +plugDestroy plug = do + -- Disconnect `deleteEvent` signal handler before destroy, + -- otherwise, can't destroy GtkPlug. + signalDisconnect $ plugHandler plug + + -- Destroy GtkPlug. + widgetDestroy $ plugBody plug diff --git a/Manatee/Toolkit/Widget/PopupWindow.hs b/Manatee/Toolkit/Widget/PopupWindow.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Widget/PopupWindow.hs @@ -0,0 +1,93 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Widget.PopupWindow where + +import Control.Applicative hiding (empty) +import Graphics.UI.Gtk +import Manatee.Toolkit.Gtk.Container + +data PopupWindow = + PopupWindow {pwWindow :: Window + ,pwFrame :: Frame} + +-- | The default height of popup window. +popupWindowDefaultHeight :: Int +popupWindowDefaultHeight = 360 + +-- | Create popup window. +popupWindowNew :: IO PopupWindow +popupWindowNew = do + -- Create window and frame. + window <- windowNew + frame <- frameNew + window `containerAdd` frame + + -- Set window properties. + set window [windowTypeHint := WindowTypeHintDialog + ,windowWindowPosition := WinPosCenter + ,windowDecorated := False + ,windowAcceptFocus := False + ,windowDestroyWithParent := True + ,windowResizable := True -- this make window can smaller than last size + ] + + return $ PopupWindow window frame + +-- | Stick popup window with parent window. +-- Note, the widget's toplevel widget must be Window, +-- otherwise this function with failed. +popupWindowStickParent :: WidgetClass widget => PopupWindow -> widget -> IO () +popupWindowStickParent popupWindow widget = + castToWindow <$> widgetGetToplevel widget + >>= windowSetTransientFor (pwWindow popupWindow) + +-- | Set size and position. +popupWindowSetAllocation :: PopupWindow -> Rectangle -> IO () +popupWindowSetAllocation popupWindow (Rectangle x y w h) = do + let window = pwWindow popupWindow + windowMove window x y + widgetSetSizeRequest window w h + windowResize window w h -- this step is necessary to make window smaller than last size + +-- | Show popup window. +popupWindowShow :: PopupWindow -> IO () +popupWindowShow = widgetShowAll . pwWindow + +-- | Hide popup window. +popupWindowHide :: PopupWindow -> IO () +popupWindowHide = widgetHide . pwWindow + +-- | Add child. +popupWindowAdd :: WidgetClass child => PopupWindow -> child -> IO () +popupWindowAdd popupWindow child = + pwFrame popupWindow `containerAdd` child + +-- | Remove children. +popupWindowRemove :: PopupWindow -> IO () +popupWindowRemove = containerRemoveAll . pwFrame + +-- | Is visible. +popupWindowIsVisible :: PopupWindow -> IO Bool +popupWindowIsVisible win = get (pwWindow win) widgetVisible + +-- | Exit. +popupWindowExit :: PopupWindow -> IO () +popupWindowExit win = do + popupWindowRemove win + popupWindowHide win diff --git a/Manatee/Toolkit/Widget/Statusbar.hs b/Manatee/Toolkit/Widget/Statusbar.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Widget/Statusbar.hs @@ -0,0 +1,143 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Widget.Statusbar where + +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad +import Data.Sequence (Seq) +import Graphics.UI.Gtk hiding (Statusbar, statusbarNew) +import Manatee.Toolkit.General.Functor +import Manatee.Toolkit.General.List +import Manatee.Toolkit.General.STM +import Manatee.Toolkit.General.Seq +import Manatee.Toolkit.Gtk.Box +import Manatee.Toolkit.Gtk.Container + +import qualified Data.Foldable as F +import qualified Data.Sequence as Seq +import qualified Graphics.UI.Gtk.Display.Statusbar as S + +type StatusbarSubitem = S.Statusbar +type StatusbarInfoTable = Seq (String, String) + +data Statusbar = + Statusbar {statusbarBox :: HBox + ,statusbarInfoSubitem :: StatusbarSubitem + ,statusbarInfoTable :: TVar StatusbarInfoTable + ,statusbarProgressBar :: ProgressBar} + +-- | Create new statusbar. +statusbarNew :: BoxClass b => b -> IO Statusbar +statusbarNew b = do + -- Status box for contain status boxes. + statusBox <- hBoxNew False 0 + boxPackStart (toBox b) statusBox PackNatural 0 + + Statusbar <$> pure statusBox + <*> statusbarSubitemNew statusBox + <*> newTVarIO Seq.empty + <*> progressBarNew + +-- | Clone statusbar. +statusbarClone :: BoxClass b => b -> Statusbar -> IO Statusbar +statusbarClone box oldStatusbar = do + -- Clone status from old statusbar. + newStatusbar <- statusbarNew box + replaceTVarField newStatusbar oldStatusbar statusbarInfoTable + + -- Update status. + statusbarInfoSubitemUpdate newStatusbar + + return newStatusbar + +-- | Get info table. +statusbarGetInfoTable :: Statusbar -> IO StatusbarInfoTable +statusbarGetInfoTable = readTVarIO . statusbarInfoTable + +-- | Create new sub-statusbar. +statusbarSubitemNew :: BoxClass b => b -> IO StatusbarSubitem +statusbarSubitemNew b = do + bar <- S.statusbarNew + statusbarSetHasResizeGrip bar False -- don't show resize grip + boxPackStart (toBox b) bar PackGrow 0 -- use PackGrow for grow size + + return bar + +-- | Update info status. +statusbarInfoSubitemSetText :: Statusbar -> String -> IO () +statusbarInfoSubitemSetText = + statusbarSubitemSetText . statusbarInfoSubitem + +-- | Set text internal. +statusbarSubitemSetText :: StatusbarSubitem -> String -> IO () +statusbarSubitemSetText ss str = do + id <- statusbarGetContextId ss str + statusbarPush ss id str + return () + +-- | Add new info item to info subitem. +statusbarInfoItemAdd :: Statusbar -> String -> String -> IO () +statusbarInfoItemAdd = statusbarInfoItemUpdate + +-- | Update info item. +statusbarInfoItemUpdate :: Statusbar -> String -> String -> IO () +statusbarInfoItemUpdate statusbar item info = + statusbarApplyInfoTable statusbar (replaceOrAdd (\x -> fst x == item) (item, info)) + +-- | Remove info item from info subitem. +statusbarInfoItemRemove :: Statusbar -> String -> IO () +statusbarInfoItemRemove statusbar item = + statusbarApplyInfoTable statusbar (deleteMatch (\y -> fst y == item)) + +-- | Apply info table. +statusbarApplyInfoTable :: Statusbar -> (StatusbarInfoTable -> StatusbarInfoTable) -> IO () +statusbarApplyInfoTable statusbar f = do + -- Apply function. + modifyTVarIO (statusbarInfoTable statusbar) f + + -- Update info subitem. + statusbarInfoSubitemUpdate statusbar + +-- | Update info item subitem information. +statusbarInfoSubitemUpdate :: Statusbar -> IO () +statusbarInfoSubitemUpdate statusbar = do + infoList <- (<<<=) F.toList (readTVarIO . statusbarInfoTable) statusbar + unlessNull infoList (statusbarInfoSubitemSetText statusbar (concatMap (\x -> snd x ++ " ") infoList)) + +-- | Update progress status. +statusbarProgressUpdate :: Statusbar -> Double -> IO () +statusbarProgressUpdate (Statusbar {statusbarBox = box + ,statusbarProgressBar = progressBar}) + progress = do + -- Show progress bar first. + boxTryPack box progressBar PackNatural Nothing Nothing + widgetShowAll progressBar + + -- Set progress. + set progressBar [progressBarFraction := progress / 100] + progressBarSetText progressBar (show progress ++ "%") + + -- Hide progress bar after reach 100% (default is 100 ms). + when (progress == 100.0) $ + timeoutAdd (do + set progressBar [progressBarFraction := 0] + containerTryRemove box progressBar + return False) 100 + >> return () diff --git a/Manatee/Toolkit/Widget/Tooltip.hs b/Manatee/Toolkit/Widget/Tooltip.hs new file mode 100644 --- /dev/null +++ b/Manatee/Toolkit/Widget/Tooltip.hs @@ -0,0 +1,185 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- 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 +-- 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 . + +module Manatee.Toolkit.Widget.Tooltip where + +import Control.Concurrent.STM +import Control.Monad.Trans +import Data.Maybe +import Data.Ord +import Data.Set +import Graphics.UI.Gtk hiding (Tooltip) +import Manatee.Toolkit.General.Maybe +import Manatee.Toolkit.General.STM +import Manatee.Toolkit.General.Set +import Manatee.Toolkit.Gtk.Gtk + +import qualified Data.Function as F + +data Tooltip = + Tooltip {tooltipId :: Int + ,tooltipWindow :: Window -- window for contain widget + ,tooltipDependWindow :: Window -- depend window for control display + ,tooltipLabel :: Label -- label to container text + ,tooltipTimeout :: Int -- timeout for display (in millisecond) + ,tooltipHideWhenPress :: Bool -- hide when press + ,tooltipFocusInConnectId :: ConnectId Window + ,tooltipFocusOutConnectId:: ConnectId Window + } + +instance Eq Tooltip where + (==) = (==) `F.on` tooltipId + +instance Ord Tooltip where + compare = comparing tooltipId + +-- | Align size. +tooltipAlignSize :: Int +tooltipAlignSize = 10 + +-- | Default foreground color. +tooltipDefaultForegroundColor :: Color +tooltipDefaultForegroundColor = Color 0 0 0 + +-- | Default background color. +tooltipDefaultBackgroundColor :: Color +tooltipDefaultBackgroundColor = Color 65335 65335 0 + +-- | New tooltip. +tooltipNew :: Int -- ^ id + -> Window -- ^ top-level parent window + -> String -- ^ text + -> Maybe Point -- ^ point, 'Nothing' will set right-top corner of screen + -> Int -- ^ timeout + -> Maybe Color -- ^ foreground color + -> Maybe Color -- ^ background color + -> Bool -- ^ weather hide when key press + -> TVar (Set Tooltip) -- ^ set to manage temporary tooltip + -> IO Tooltip +tooltipNew tId win text position timeout fColor bColor hideWhenPress tooltipSet = do + -- Set color. + let foregroundColor = fromMaybe tooltipDefaultForegroundColor fColor + backgroundColor = fromMaybe tooltipDefaultBackgroundColor bColor + + -- Create tooltip window. + window <- windowNewPopup + windowSetDecorated window False + windowSetOpacity window 0.8 -- this function need window-manager support Alpha channel in X11 + widgetModifyBg window StateNormal backgroundColor + + -- Create frame. + frame <- frameNew + set frame [frameShadowType := ShadowEtchedIn] + + -- Create alignment. + alignment <- alignmentNew 0.5 0.5 1 1 + alignmentSetPadding alignment tooltipAlignSize tooltipAlignSize tooltipAlignSize tooltipAlignSize + + -- Create label. + label <- labelNew $ Just text + labelSetAttributes label [AttrForeground 0 (length text) foregroundColor + ,AttrBackground 0 (length text) backgroundColor] + + -- Wrap line with word bound. + labelSetLineWrap label True + labelSetLineWrapMode label WrapPartialWords + + -- Show tooltip. + alignment `containerAdd` label + frame `containerAdd` alignment + window `containerAdd` frame + widgetShowAll window + + -- Adjust tooltip position. + (screenWidth, screenHeight) <- widgetGetScreenSize win + (Rectangle _ _ width height) <- widgetGetAllocation window + let (tooltipX, tooltipY) = + case position of + Just (x, y) -> + let adjustX + -- Set screen right when x bigger than screen width. + | x > screenWidth + = screenWidth - width - tooltipAlignSize + -- Set left of x when tooltip width bigger than screen width. + | x + width > screenWidth + = x - width - tooltipAlignSize + | otherwise + = x + adjustY + -- Set screen bottom when y bigger than screen height. + | y > screenHeight + = screenHeight - height - tooltipAlignSize + -- Set up of y when tooltip height bigger than screen height. + | y + height > screenHeight + = y - height - tooltipAlignSize + | otherwise + = y + in (adjustX, adjustY) + Nothing -> (screenWidth - width - tooltipAlignSize, tooltipAlignSize) + + -- Move window. + windowMove window tooltipX tooltipY + + -- Show tooltip when parent window show. + focusInConnectId <- + win `on` focusInEvent $ tryEvent $ do + liftIO $ do + widgetShowAll window + windowMove window tooltipX tooltipY + stopEvent + + -- Hide tooltip when parent window hide. + focusOutConnectId <- + win `on` focusOutEvent $ tryEvent $ do + liftIO $ widgetHideAll window + stopEvent + + -- Create tooltip. + let tooltip = Tooltip tId window win label timeout hideWhenPress focusInConnectId focusOutConnectId + + -- Destroy tooltip when out of timeout. + timeoutAdd (tooltipExit tooltip tooltipSet >> return False) timeout + + return tooltip + +-- | Exit tooltip. +tooltipExit :: Tooltip -> TVar (Set Tooltip) -> IO () +tooltipExit Tooltip {tooltipId = tId + ,tooltipWindow = window + ,tooltipHideWhenPress = hideWhenPress + ,tooltipFocusInConnectId = focusInConnectId + ,tooltipFocusOutConnectId = focusOutConnectId + } + tooltipSet = do + let exitAction = do + -- Disconnect signal first. + signalDisconnect focusInConnectId + signalDisconnect focusOutConnectId + + -- Destroy tooltip. + widgetDestroy window + + if hideWhenPress + -- If tooltip will hide after press key, remove from set first. + then do + set <- readTVarIO tooltipSet + maybeFindMin set (\x -> tooltipId x == tId) + ?>= \ tooltip -> do + modifyTVarIO tooltipSet (delete tooltip) + exitAction + else exitAction diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/manatee-core.cabal b/manatee-core.cabal new file mode 100644 --- /dev/null +++ b/manatee-core.cabal @@ -0,0 +1,100 @@ +name: manatee-core +version: 0.0.1 +Cabal-Version: >= 1.6 +license: GPL-3 +license-file: LICENSE +copyright: (c) 2009 ~ 2010 Andy Stewart +synopsis: The core of Manatee. +description: manatee-core is core package of Manatee (Haskell/Gtk+ Integrated Live Environment) + To provide basic communication protocol and toolkit. +author: Andy Stewart +maintainer: Andy Stewart +stability: provisional +category: Manatee, Operating System, Desktop Environment, IDE + +tested-with: GHC==6.12.3 +build-type: Simple + +Source-Repository head + type: darcs + location: http://patch-tag.com/r/AndyStewart/manatee-core + +Library + build-depends: base >= 4 && < 5, gtk >= 0.12.0, containers >= 0.3.0.0, text >= 0.7.1.0, + dbus-client >= 0.3 && < 0.4, dbus-core, mtl >= 1.1.0.2, stm >= 2.1.2.0, + cairo >= 0.12.0, gio >= 0.12.0, regex-tdfa >= 1.1.2, utf8-string >= 0.3.4, + network >= 2.2.1.5, template-haskell >= 2.4.0.0, gtk-serialized-event >= 0.12.0, + filepath >= 1.1.0.3, unix >= 2.4.0.0, process >= 1.0.1.2, array >= 0.3.0.0, + old-time >= 1.0.0.3, glib >= 0.12.0, time >= 1.1.4, gtksourceview2 >= 0.12.0, + Cabal >= 1.8.0.2, old-locale >= 1.0.0.2, datetime >= 0.2, bytestring, split, dataenc, + derive, gconf >= 0.12.0, binary, directory + exposed-modules: + Manatee.Core.DBus + Manatee.Core.Debug + Manatee.Core.Interactive + Manatee.Core.FileOpenRule + Manatee.Core.Page + Manatee.Core.PageMode + Manatee.Core.PageView + Manatee.Core.Config + Manatee.Core.TH + Manatee.Core.Types + Manatee.Core.Render + + Manatee.Toolkit.Data.ListZipper + Manatee.Toolkit.Data.SetList + Manatee.Toolkit.Data.Unique + + Manatee.Toolkit.GConf.GConf + + Manatee.Toolkit.General.Arrow + Manatee.Toolkit.General.Basic + Manatee.Toolkit.General.ByteString + Manatee.Toolkit.General.Concurrent + Manatee.Toolkit.General.DBus + Manatee.Toolkit.General.Either + Manatee.Toolkit.General.FilePath + Manatee.Toolkit.General.Functor + Manatee.Toolkit.General.List + Manatee.Toolkit.General.Map + Manatee.Toolkit.General.Maybe + Manatee.Toolkit.General.Misc + Manatee.Toolkit.General.Process + Manatee.Toolkit.General.Seq + Manatee.Toolkit.General.Set + Manatee.Toolkit.General.State + Manatee.Toolkit.General.STM + Manatee.Toolkit.General.String + Manatee.Toolkit.General.Time + Manatee.Toolkit.General.Typeable + Manatee.Toolkit.General.Url + + Manatee.Toolkit.Glib.GError + + Manatee.Toolkit.Gio.Gio + + Manatee.Toolkit.Gtk.Box + Manatee.Toolkit.Gtk.Cairo + Manatee.Toolkit.Gtk.Concurrent + Manatee.Toolkit.Gtk.Container + Manatee.Toolkit.Gtk.DrawWindow + Manatee.Toolkit.Gtk.Editable + Manatee.Toolkit.Gtk.Event + Manatee.Toolkit.Gtk.Gtk + Manatee.Toolkit.Gtk.ModelView + Manatee.Toolkit.Gtk.Multiline + Manatee.Toolkit.Gtk.Notebook + Manatee.Toolkit.Gtk.ScrolledWindow + Manatee.Toolkit.Gtk.Struct + + Manatee.Toolkit.Widget.Interactivebar + Manatee.Toolkit.Widget.NotebookTab + Manatee.Toolkit.Widget.Outputbar + Manatee.Toolkit.Widget.Plug + Manatee.Toolkit.Widget.PopupWindow + Manatee.Toolkit.Widget.Statusbar + Manatee.Toolkit.Widget.Tooltip + + other-modules: + extensions: + ghc-options: -fwarn-unused-matches -fwarn-unused-binds -fwarn-unused-imports -fwarn-overlapping-patterns -fwarn-duplicate-exports -fwarn-unrecognised-pragmas -fwarn-hi-shadowing