diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell +import Distribution.Simple +main = defaultMainWithHooks autoconfUserHooks + diff --git a/src/Atoms.hs b/src/Atoms.hs new file mode 100644 --- /dev/null +++ b/src/Atoms.hs @@ -0,0 +1,34 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 21 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Atoms + ( xmms2PosList + , xmms2MlibId + , propPosList + , mlibIdClipboard + ) where + +import Graphics.UI.Gtk +import System.IO.Unsafe + + +xmms2PosList = unsafePerformIO $ atomNew "application/x-xmms2poslist" +xmms2MlibId = unsafePerformIO $ atomNew "application/x-xmms2mlibid" +propPosList = unsafePerformIO $ atomNew "application/x-visionpropposlist" +mlibIdClipboard = unsafePerformIO $ atomNew "_VISION_MEDIAID_CLIPBOARD" diff --git a/src/Clipboard.hs b/src/Clipboard.hs new file mode 100644 --- /dev/null +++ b/src/Clipboard.hs @@ -0,0 +1,92 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 26 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Clipboard + ( initClipboard + , clipboard + , onClipboardTargets + , getClipboardTargets + ) where + +import Control.Concurrent.MVar +import Control.Monad + +import Data.Maybe + +import Graphics.UI.Gtk hiding (Clipboard) +import qualified Graphics.UI.Gtk as G + +import Context +import Handler +import Utils + + +data State + = State { sTargets :: [TargetTag] } + +makeState = + State { sTargets = [] } + +data Clipboard + = Clipboard { cState :: MVar State + , cClipboard :: G.Clipboard + , cOnClipboardTargets :: HandlerMVar () + } + +state = cState context + +clipboard = cClipboard context + +onClipboardTargets = onHandler $ cOnClipboardTargets context + +getClipboardTargets = withMVar state $ return . sTargets + +updateClipboardTargets targets = do + let targets' = fromMaybe [] targets + modifyMVar state $ \state -> + return (state { sTargets = targets' }, sTargets state /= targets') + + +initClipboard = do + context <- initContext + let ?context = context + + timeoutAdd checkClipboard 0 + + return ?context + + +initContext = do + state <- newMVar makeState + clipboard <- clipboardGet selectionClipboard + onClipboardTargets <- makeHandlerMVar + return $ augmentContext + Clipboard { cState = state + , cClipboard = clipboard + , cOnClipboardTargets = onClipboardTargets + } + +checkClipboard = do + clipboard <- clipboardGet selectionClipboard + clipboardRequestTargets clipboard $ \targets -> do + changed <- updateClipboardTargets targets + when changed $ onClipboardTargets $ invoke () + timeoutAdd checkClipboard 250 + return () + return False diff --git a/src/Collection.hs b/src/Collection.hs new file mode 100644 --- /dev/null +++ b/src/Collection.hs @@ -0,0 +1,64 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 14 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Collection + ( initCollection + , browseCollection + ) where + +import Graphics.UI.Gtk + +import UI +import Collection.Common +import Collection.List +import Collection.Model +import Collection.View +import Collection.Control +import Collection.UI + + +initCollection = do + context <- initCommon + let ?context = context + + context <- initList + let ?context = context + + return ?context + + +browseCollection maybeName = do + let f = browseCollection + + context <- initUI + let ?context = context + + context <- initModel + let ?context = context + + context <- initView + let ?context = context + + context <- initCollectionUI f + let ?context = context + + widgetShowAll window + case maybeName of + Just name -> loadNamed name + Nothing -> widgetGrabFocus collFilter diff --git a/src/Collection/Common.hs b/src/Collection/Common.hs new file mode 100644 --- /dev/null +++ b/src/Collection/Common.hs @@ -0,0 +1,39 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 14 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Collection.Common + ( initCommon + , universe + ) where + +import XMMS2.Client + +import Context + + +data Common + = Common { cUniverse :: Coll } + +universe = cUniverse context + + +initCommon = do + universe <- collUniverse + return $ augmentContext + Common { cUniverse = universe } diff --git a/src/Collection/Control.hs b/src/Collection/Control.hs new file mode 100644 --- /dev/null +++ b/src/Collection/Control.hs @@ -0,0 +1,269 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 20 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Collection.Control + ( loadSelected + , loadNamed + , loadCurrent + , browseSelected + , addToPlaylist + , collAddToPlaylist + , listAddToPlaylist + , applyFilter + , editFilter + , allMedia + , saveCollection + , renameCollection + , removeCollection + , updateWindowTitle + , editCopy + , editSelectAll + , editInvertSelection + , showPropertyEditor + , showPropertyExport + , getOrder + , setOrder + ) where + +import Prelude hiding (catch) +import Control.Monad.CatchIO +import Control.Monad +import Control.Monad.Trans +import Control.Applicative + +import Data.Maybe + +import Graphics.UI.Gtk + +import XMMS2.Client + +import XMMS +import Utils +import UI +import Atoms +import Clipboard +import qualified Properties as P +import Collection.Common +import Collection.Model hiding (setOrder) +import qualified Collection.Model as Model +import Collection.View +import Collection.List.View + + +loadSelected = do + maybeName <- getSelectedCollection + case maybeName of + Just name -> + loadNamed name + Nothing -> do + setCurColl universe "" + loadCurrent + +loadNamed name = + collGet xmms name "Collections" >>* do + coll <- result + liftIO $ do + setCurColl coll name + loadCurrent + return False + +setOrder order = do + Model.setOrder True order + loaded <- getLoaded + when loaded loadCurrent + +loadCurrent = + loadCurrent' `catch` \ParseError -> return () + +loadCurrent' = do + text <- trim <$> entryGetText collFilter + entrySetText collFilter text + setFilter text + coll <- getCurColl + keys <- getOrderKeys + collQueryIds xmms coll keys 0 0 >>* do + ids <- result + liftIO $ do + setLoaded True + updateWindowTitle + populateModel ids + widgetGrabFocus collView + return False + +browseSelected browse = + browse =<< getSelectedCollection + + +addToPlaylist replace = do + list <- widgetGetIsFocus listView + if list + then listAddToPlaylist replace + else do + coll <- widgetGetIsFocus collView + when coll $ collAddToPlaylist replace + +collAddToPlaylist replace = + add `catch` \ParseError -> return () + where add = do + ids <- getSelectedIds + cur <- getCurColl + sel <- collNewIdlist ids + int <- collNew TypeIntersection + collAddOperand int cur + collAddOperand int sel + addCollection replace int + +listAddToPlaylist replace = do + maybeName <- getSelectedCollection + case maybeName of + Nothing -> addCollection replace universe + Just name -> collGet xmms name "Collections" >>* do + coll <- result + liftIO $ addCollection replace coll + return False + +addCollection replace coll = do + when replace $ playlistClear xmms Nothing >> return () + playlistAddCollection xmms Nothing coll =<< getOrderKeys + return () + +getSelectedIds = + mapM (listStoreGetValue collStore . head) + =<< treeSelectionGetSelectedRows collSel + +applyFilter = do + conn <- connected + when conn loadCurrent + +editFilter = do + editableSelectRegion collFilter 0 (-1) + widgetGrabFocus collFilter + +allMedia = do + resetModel + resetListView + entrySetText collFilter "" + widgetGrabFocus collFilter + updateWindowTitle + +saveCollection = do + name <- trim <$> getCurName + coll <- getCurColl + res <- runDlg "Save collection" (not $ null name) (const True) name + fmaybeM_ res $ \name -> do + collSave xmms coll name "Collections" + return () + +renameCollection = do + old <- fromJust <$> getSelectedCollection + res <- runDlg "Rename collection" False (/= old) old + fmaybeM_ res $ \new -> do + collRename xmms old new "Collections" + return () + +removeCollection = do + name <- fromJust <$> getSelectedCollection + collRemove xmms name "Collections" + return () + +runDlg title enable isOk init = do + dialog <- dialogNew + windowSetTitle dialog title + windowSetTransientFor dialog window + windowSetModal dialog True + windowGroupAddWindow windowGroup dialog + + dialogSetHasSeparator dialog False + dialogAddButton dialog "gtk-cancel" ResponseCancel + dialogAddButtonCR dialog "gtk-ok" ResponseOk + dialogSetDefaultResponse dialog ResponseOk + dialogSetResponseSensitive dialog ResponseOk enable + + box <- vBoxNew False 0 + containerSetBorderWidth box 7 + upper <- dialogGetUpper dialog + containerAdd upper box + + entry <- entryNew + entrySetText entry init + editableSelectRegion entry 0 (-1) + editableSetPosition entry (-1) + boxPackStart box entry PackNatural 0 + + let ok = do + new <- trim <$> entryGetText entry + return $ not (null new) && isOk new + check = dialogSetResponseSensitive dialog ResponseOk =<< ok + checkInsert str pos = check >> return (length str + pos) + checkDelete _ _ = check + entry `onEntryActivate` do + ok <- ok + when ok $ dialogResponse dialog ResponseOk + entry `afterInsertText` checkInsert + entry `afterDeleteText` checkDelete + + widgetShowAll dialog + resp <- dialogRun dialog + new <- trim <$> entryGetText entry + widgetDestroy dialog + + return $ case resp of + ResponseOk -> Just new + _ -> Nothing + +updateWindowTitle = do + name <- getCurName + loaded <- getLoaded + filter <- getFilter + let t = if loaded then f ++ n ++ " - " else "" + n = case name of + "" -> "All media" + _ -> name + f = if null filter then "" else "*" + setWindowTitle $ t ++ "Vision collection browser" + +editCopy = do + ids <- getSelectedIds + clipboardSetWithData clipboard + [(xmms2MlibId, 0)] + (const $ selectionDataSet selectionTypeInteger ids) + (return ()) + return () + +editSelectAll = + treeSelectionSelectAll collSel + +editInvertSelection = do + rows <- treeSelectionGetSelectedRows collSel + treeSelectionSelectAll collSel + mapM_ (treeSelectionUnselectPath collSel) rows + + +showPropertyEditor = withSelectedIds P.showPropertyEditor + +showPropertyExport = withSelectedIds P.showPropertyExport + +withSelectedIds f = + f =<< getSelectedIds + +getOrderKeys = + map orderKey <$> getOrder + +orderKey (prop, False) = P.propKey prop +orderKey (prop, True) = '-' : P.propKey prop diff --git a/src/Collection/List.hs b/src/Collection/List.hs new file mode 100644 --- /dev/null +++ b/src/Collection/List.hs @@ -0,0 +1,31 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 20 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Collection.List + ( initList + , listStore + , initListView + , listView + ) where + +import Collection.List.Model +import Collection.List.View + + +initList = initListModel diff --git a/src/Collection/List/Model.hs b/src/Collection/List/Model.hs new file mode 100644 --- /dev/null +++ b/src/Collection/List/Model.hs @@ -0,0 +1,74 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 20 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Collection.List.Model + ( initListModel + , listStore + ) where + +import Control.Monad +import Control.Monad.Trans + +import Graphics.UI.Gtk hiding (add) + +import XMMS2.Client + +import Context +import XMMS +import Handler + + +data Model + = Model { mStore :: ListStore (Maybe String) } + +listStore = mStore context + + +initListModel = do + context <- initContext + let ?context = context + + onServerConnection . add . ever $ \conn -> + if conn + then do + broadcastCollectionChanged xmms >>* do + change <- result + when (namespace change == "Collections") $ + -- TODO: use the change info instead of repopulating the model. + liftIO $ listCollections + return True + listCollections + else + listStoreClear listStore + + return ?context + +initContext = do + store <- listStoreNewDND [] Nothing Nothing + return $ augmentContext + Model { mStore = store } + +listCollections = + collList xmms "Collections" >>* do + colls <- result + liftIO $ do + listStoreClear listStore + listStoreAppend listStore Nothing + mapM_ (listStoreAppend listStore . Just) colls + return False diff --git a/src/Collection/List/View.hs b/src/Collection/List/View.hs new file mode 100644 --- /dev/null +++ b/src/Collection/List/View.hs @@ -0,0 +1,118 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 10 Mar. 2010 +-- +-- Copyright (C) 2009-2010 Oleg Belozeorov +-- 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. +-- + +module Collection.List.View + ( initListView + , listView + , resetListView + , onCollectionActivated + , onCollectionSelectionChanged + , onCollectionListMidClick + , onCollectionListCR + , getSelectedCollection + ) where + +import Control.Applicative +import Control.Monad.Trans + +import Data.Char (toLower) +import Data.List (isInfixOf) + +import Graphics.UI.Gtk + +import Context +import Collection.List.Model + + +data View + = View { vView :: TreeView + , vSel :: TreeSelection + } + +listView = vView context +listSel = vSel context + + +initListView = do + context <- initContext + let ?context = context + + treeSelectionSetMode listSel SelectionBrowse + + treeViewSetHeadersVisible listView False + widgetSetSizeRequest listView 200 (-1) + + column <- treeViewColumnNew + treeViewAppendColumn listView column + cell <- cellRendererTextNew + treeViewColumnPackStart column cell True + cellLayoutSetAttributes column cell listStore $ \n -> + case n of + Nothing -> + [ cellText := "All Media", cellTextWeight := 800 ] + Just cn -> + [ cellText := cn, cellTextWeightSet := False ] + + treeViewSetEnableSearch listView True + treeViewSetSearchEqualFunc listView . Just $ \str iter -> + maybe False (isInfixOf (map toLower str) . map toLower) <$> + (listStoreGetValue listStore . head + =<< treeModelGetPath listStore iter) + + return ?context + +resetListView = + treeViewSetCursor listView [0] Nothing + + +initContext = do + view <- treeViewNewWithModel listStore + sel <- treeViewGetSelection view + return $ augmentContext + View { vView = view + , vSel = sel + } + +onCollectionActivated = + onRowActivated listView . const . const + +onCollectionSelectionChanged = + onSelectionChanged listSel + +onCollectionListMidClick f = + listView `on` buttonPressEvent $ tryEvent $ do + MiddleButton <- eventButton + SingleClick <- eventClick + (x, y) <- eventCoordinates + liftIO $ do + Just (p, _, _) <- treeViewGetPathAtPos listView (round x, round y) + treeViewSetCursor listView p Nothing + f + +onCollectionListCR f = + listView `on` keyPressEvent $ tryEvent $ do + [Control] <- eventModifier + "Return" <- eventKeyName + liftIO f + +getSelectedCollection = do + path <- fst <$> treeViewGetCursor listView + case path of + [n] -> listStoreGetValue listStore n + _ -> return Nothing + diff --git a/src/Collection/Model.hs b/src/Collection/Model.hs new file mode 100644 --- /dev/null +++ b/src/Collection/Model.hs @@ -0,0 +1,172 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 14 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# LANGUAGE TupleSections #-} + +module Collection.Model + ( initModel + , collStore + , getInfo + , populateModel + , getCurName + , getCurColl + , setCurColl + , getFilter + , setFilter + , resetModel + , getLoaded + , setLoaded + , getOrder + , setOrder + ) where + +import Control.Applicative +import Control.Monad +import Control.Concurrent.MVar + +import Data.Maybe + +import Graphics.UI.Gtk + +import XMMS2.Client + +import Context +import Index hiding (getInfo) +import qualified Index as Index +import Medialib hiding (getInfo) +import Collection.Common +import qualified Properties as P +import Config +import Utils + + +data State + = State { sCurColl :: Coll + , sCurName :: String + , sFilter :: String + , sLoaded :: Bool + , sOrder :: [(P.Property, Bool)] + } + +makeState = + State { sCurColl = universe + , sCurName = "" + , sFilter = "" + , sLoaded = False + , sOrder = [] + } + +data Model + = Model { mState :: MVar State + , mStore :: ListStore MediaId + , mIndex :: Index MediaInfo + } + +state = mState context + +collStore = mStore context +collIndex = mIndex context + +getCurName = + withMVar state $ return . sCurName + +getCurColl = + withMVar state $ \s -> do + case sFilter s of + [] -> return $ sCurColl s + text -> do + fil <- collParse text + int <- collNew TypeIntersection + collAddOperand int $ sCurColl s + collAddOperand int fil + return int + +setCurColl coll name = + modifyMVar_ state $ \s -> + return s { sCurColl = coll + , sCurName = name + } + +getFilter = withMVar state $ return . sFilter + +setFilter text = + modifyMVar_ state $ \s -> + return s { sFilter = text } + +getLoaded = + withMVar state $ return . sLoaded + +setLoaded loaded = + modifyMVar_ state $ \s -> + return s { sLoaded = loaded } + +getOrder = + withMVar state $ return . sOrder + +setOrder save o = do + modifyMVar_ state $ \s -> + return s { sOrder = o } + when save $ saveOrder o + +getInfo = Index.getInfo (mIndex context) + + +initModel = do + context <- initContext + let ?context = context + + setOrder False =<< loadOrder + + return ?context + + +initContext = do + state <- newMVar makeState + store <- listStoreNewDND [] Nothing Nothing + index <- makeIndex store return + return $ augmentContext + Model { mState = state + , mStore = store + , mIndex = index + } + +populateModel ids = do + clearIndex collIndex + listStoreClear collStore + mapM_ addOne ids + where addOne id = do + n <- listStoreAppend collStore id + addToIndex collIndex id n + +resetModel = do + listStoreClear collStore + modifyMVar_ state . const $ return makeState + + +loadOrder = + catMaybes <$> (mapM convert =<< config configFile []) + where convert (name, desc) = + maybe Nothing (Just . (, desc)) <$> P.property name + +saveOrder order = do + writeConfig configFile $ map (mapFst P.propName) order + return () + +configFile = + "collection-order.conf" diff --git a/src/Collection/Order.hs b/src/Collection/Order.hs new file mode 100644 --- /dev/null +++ b/src/Collection/Order.hs @@ -0,0 +1,86 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 10 Sep. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# LANGUAGE TupleSections #-} + +module Collection.Order + ( OrderDialog + , makeOrderDialog + , showOrderDialog + ) where + +import Control.Monad + +import Graphics.UI.Gtk + +import UI +import Compound +import Editor +import Properties +import Collection.Control + + +type OrderDialog = EditorDialog (PropertyView Bool) + +showOrderDialog dialog = + runEditorDialog dialog + getOrder + setOrder + False window + +makeOrderDialog = + makeEditorDialog [(stockApply, ResponseApply)] + makeOrderView $ \v -> do + let outerw = outer v + windowSetTitle outerw "Configure ordering" + windowSetDefaultSize outerw 500 400 + +makeOrderView parent onState = do + view <- makePropertyView (, False) parent onState + let store = propertyViewStore view + right = propertyViewRight view + + treeViewSetRulesHint right True + + column <- treeViewColumnNew + treeViewColumnSetTitle column "Order" + treeViewAppendColumn right column + cell <- cellRendererComboNew + treeViewColumnPackStart column cell True + cellLayoutSetAttributes column cell store $ \(_, dir) -> + [ cellText := dirToString dir ] + + cmod <- listStoreNewDND [False, True] Nothing Nothing + let clid = makeColumnIdString 0 + customStoreSetColumn cmod clid dirToString + cell `set` [ cellTextEditable := True + , cellComboHasEntry := False + , cellComboTextModel := (cmod, clid) ] + cell `on` edited $ \[n] str -> do + (prop, dir) <- listStoreGetValue store n + let dir' = stringToDir str + unless (dir' == dir) $ + listStoreSetValue store n (prop, dir') + + return view + +dirToString False = "Ascending" +dirToString True = "Descending" + +stringToDir = ("Descending" ==) diff --git a/src/Collection/UI.hs b/src/Collection/UI.hs new file mode 100644 --- /dev/null +++ b/src/Collection/UI.hs @@ -0,0 +1,365 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 14 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Collection.UI + ( initCollectionUI + ) where + +import Control.Applicative +import Control.Monad.Trans + +import Data.Maybe + +import System.IO.Unsafe + +import Graphics.UI.Gtk hiding (add) + +import UI +import XMMS +import Handler +import Utils +import Context +import Properties (showPropertyImport, showPropertyManager) +import Collection.View +import Collection.List.View +import Collection.Control +import Collection.Order + + +data CollectionUI + = CollectionUI { cOrderDialog :: OrderDialog } + +orderDialog = cOrderDialog context + + +initCollectionUI browse = do + context <- initContext + let ?context = context + + addUIActions $ uiActions browse + + srvAG <- actionGroupNew "server" + actionGroupAddActions srvAG $ srvActions browse + onServerConnectionAdd . ever $ actionGroupSetSensitive srvAG + insertActionGroup srvAG 1 + + addUIFromFile "collection-browser" + + onCollectionActivated $ loadSelected + onCollectionListMidClick $ browseSelected browse + onCollectionListCR $ browseSelected browse + + paned <- hPanedNew + boxPackStartDefaults contents paned + + scroll <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic + scrolledWindowSetShadowType scroll ShadowIn + containerAdd scroll listView + panedAdd1 paned scroll + + box <- vBoxNew False 5 + panedAdd2 paned box + + boxPackStart box collFilter PackNatural 0 + collFilter `onEntryActivate` applyFilter + + scroll <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic + scrolledWindowSetShadowType scroll ShadowIn + containerAdd scroll collView + boxPackStartDefaults box scroll + + popup <- getWidget castToMenu "ui/collection-popup" + setupTreeViewPopup collView popup + + popup <- getWidget castToMenu "ui/list-popup" + setupTreeViewPopup listView popup + + acts <- mapM (getAction srvAG) + [ "rename-collection" + , "remove-collection" + ] + onCollectionSelectionChanged $ do + en <- isJust <$> getSelectedCollection + mapM_ (flip actionSetSensitive en) acts + + acts <- mapM (getAction srvAG) + [ "add-to-playlist" + , "replace-playlist" + ] + let updatePA = liftIO $ do + list <- widgetGetIsFocus listView + coll <- widgetGetIsFocus collView + mapM_ (flip actionSetSensitive (list || coll)) acts + return False + setupPA w = do + w `on` focusInEvent $ updatePA + w `on` focusOutEvent $ updatePA + setupPA listView + setupPA collView + updatePA + + acts <- mapM (getAction srvAG) + ["copy", "edit-properties", "export-properties"] + let updateE = do + en <- (/= 0) <$> treeSelectionCountSelectedRows collSel + mapM_ (flip actionSetSensitive en) acts + collSel `onSelectionChanged` updateE + updateE + + updateWindowTitle + return ?context + + +initContext = do + context <- initListView + let ?context = context + + orderDialog <- unsafeInterleaveIO makeOrderDialog + + return $ augmentContext + CollectionUI { cOrderDialog = orderDialog } + + +uiActions browse = + [ ActionEntry + { actionEntryName = "collection" + , actionEntryLabel = "_Collection" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "new-window" + , actionEntryLabel = "_New window" + , actionEntryStockId = Just stockNew + , actionEntryAccelerator = Just "n" + , actionEntryTooltip = Nothing + , actionEntryCallback = newWindow browse + } + , ActionEntry + { actionEntryName = "edit-filter" + , actionEntryLabel = "_Edit filter" + , actionEntryStockId = Just stockEdit + , actionEntryAccelerator = Just "l" + , actionEntryTooltip = Nothing + , actionEntryCallback = editFilter + } + , ActionEntry + { actionEntryName = "all-media" + , actionEntryLabel = "A_ll media" + , actionEntryStockId = Just stockNew + , actionEntryAccelerator = Just "u" + , actionEntryTooltip = Nothing + , actionEntryCallback = allMedia + } + , ActionEntry + { actionEntryName = "edit" + , actionEntryLabel = "_Edit" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "view" + , actionEntryLabel = "_View" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "configure-columns" + , actionEntryLabel = "Configure _columns" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = showViewConfigDialog + } + , ActionEntry + { actionEntryName = "configure-ordering" + , actionEntryLabel = "Configure _ordering" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = showOrderDialog orderDialog + } + , ActionEntry + { actionEntryName = "properties" + , actionEntryLabel = "P_roperties" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "manage-properties" + , actionEntryLabel = "_Manage properties" + , actionEntryStockId = Just stockPreferences + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = showPropertyManager + } + , ActionEntry + { actionEntryName = "collection-popup" + , actionEntryLabel = "" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + ] + +srvActions browse = + [ ActionEntry + { actionEntryName = "browse-in-new-window" + , actionEntryLabel = "_Browse in new window" + , actionEntryStockId = Just stockOpen + , actionEntryAccelerator = Just "Return" + , actionEntryTooltip = Nothing + , actionEntryCallback = browseSelected browse + } + , ActionEntry + { actionEntryName = "save-collection" + , actionEntryLabel = "_Save collection" + , actionEntryStockId = Just stockSave + , actionEntryAccelerator = Just "s" + , actionEntryTooltip = Nothing + , actionEntryCallback = saveCollection + } + , ActionEntry + { actionEntryName = "rename-collection" + , actionEntryLabel = "Rena_me collection" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = renameCollection + } + , ActionEntry + { actionEntryName = "remove-collection" + , actionEntryLabel = "Remo_ve collection" + , actionEntryStockId = Just stockDelete + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = removeCollection + } + , ActionEntry + { actionEntryName = "add-to-playlist" + , actionEntryLabel = "_Add to playlist" + , actionEntryStockId = Just stockAdd + , actionEntryAccelerator = Just "p" + , actionEntryTooltip = Nothing + , actionEntryCallback = addToPlaylist False + } + , ActionEntry + { actionEntryName = "replace-playlist" + , actionEntryLabel = "_Replace playlist" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Just "p" + , actionEntryTooltip = Nothing + , actionEntryCallback = addToPlaylist True + } + , ActionEntry + { actionEntryName = "coll-add-to-playlist" + , actionEntryLabel = "_Add to playlist" + , actionEntryStockId = Just stockAdd + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = collAddToPlaylist False + } + , ActionEntry + { actionEntryName = "coll-replace-playlist" + , actionEntryLabel = "_Replace playlist" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = collAddToPlaylist True + } + , ActionEntry + { actionEntryName = "list-add-to-playlist" + , actionEntryLabel = "_Add to playlist" + , actionEntryStockId = Just stockAdd + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = listAddToPlaylist False + } + , ActionEntry + { actionEntryName = "list-replace-playlist" + , actionEntryLabel = "_Replace playlist" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = listAddToPlaylist True + } + , ActionEntry + { actionEntryName = "copy" + , actionEntryLabel = "_Copy" + , actionEntryStockId = Just stockCopy + , actionEntryAccelerator = Just "c" + , actionEntryTooltip = Nothing + , actionEntryCallback = editCopy + } + , ActionEntry + { actionEntryName = "select-all" + , actionEntryLabel = "_Select all" + , actionEntryStockId = Just stockSelectAll + , actionEntryAccelerator = Just "a" + , actionEntryTooltip = Nothing + , actionEntryCallback = editSelectAll + } + , ActionEntry + { actionEntryName = "invert-selection" + , actionEntryLabel = "_Invert selection" + , actionEntryStockId = Just stockSelectAll + , actionEntryAccelerator = Just "a" + , actionEntryTooltip = Nothing + , actionEntryCallback = editInvertSelection + } + , ActionEntry + { actionEntryName = "edit-properties" + , actionEntryLabel = "_Edit properties" + , actionEntryStockId = Just stockEdit + , actionEntryAccelerator = Just "Return" + , actionEntryTooltip = Nothing + , actionEntryCallback = showPropertyEditor + } + , ActionEntry + { actionEntryName = "export-properties" + , actionEntryLabel = "E_xport properties" + , actionEntryStockId = Just stockSave + , actionEntryAccelerator = Just "" + , actionEntryTooltip = Nothing + , actionEntryCallback = showPropertyExport + } + , ActionEntry + { actionEntryName = "import-properties" + , actionEntryLabel = "_Import properties" + , actionEntryStockId = Just stockOpen + , actionEntryAccelerator = Just "" + , actionEntryTooltip = Nothing + , actionEntryCallback = showPropertyImport + } + ] + + +newWindow browse = + browse Nothing diff --git a/src/Collection/View.hs b/src/Collection/View.hs new file mode 100644 --- /dev/null +++ b/src/Collection/View.hs @@ -0,0 +1,165 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 14 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# LANGUAGE TupleSections #-} + +module Collection.View + ( initView + , collView + , collSel + , collFilter + , showViewConfigDialog + ) where + +import Control.Monad +import Control.Applicative + +import Data.IORef +import Data.Maybe +import Data.List (isInfixOf) +import Data.Char + +import System.IO.Unsafe + +import Graphics.UI.Gtk + +import UI +import Config +import Compound +import Editor +import Context +import Prelude hiding (lookup) +import Properties +import Collection.Model + + +data View + = View { vView :: TreeView + , vSel :: TreeSelection + , vFilter :: Entry + , vConfigDlg :: EditorDialog (PropertyView ()) + , vColumns :: IORef [Property] + } + +collView = vView context +collSel = vSel context +collFilter = vFilter context +configDlg = vConfigDlg context +columns = vColumns context + + +initView = do + context <- initContext + let ?context = context + + treeViewSetRulesHint collView True + treeSelectionSetMode collSel SelectionMultiple + + setColumns False =<< loadConfig + + return ?context + +showViewConfigDialog = + runEditorDialog configDlg + (map (, ()) <$> getColumns) + (setColumns True . map fst) + False window + +initContext = do + view <- treeViewNewWithModel collStore + sel <- treeViewGetSelection view + filter <- entryNew + configDlg <- unsafeInterleaveIO makeConfigDlg + columns <- newIORef [] + return $ augmentContext + View { vView = view + , vSel = sel + , vFilter = filter + , vConfigDlg = configDlg + , vColumns = columns + } + +getColumns = + readIORef columns + +setColumns save props = do + mapM_ (treeViewRemoveColumn collView) =<< treeViewGetColumns collView + writeIORef columns props + mapM_ addColumn props + setupSearch props + when save $ saveConfig props + +addColumn prop = do + column <- treeViewColumnNew + treeViewAppendColumn collView column + treeViewColumnSetTitle column $ propName prop + treeViewColumnSetResizable column True + cell <- cellRendererTextNew + treeViewColumnPackStart column cell True + cellLayoutSetAttributeFunc column cell collStore $ \iter -> do + maybeInfo <- getInfoIfNeeded iter + let text = case maybeInfo of + Just info -> maybe "" id (lookup prop info) + Nothing -> "" + cell `set` [ cellText := text ] + +getInfoIfNeeded iter = do + [n] <- treeModelGetPath collStore iter + mid <- listStoreGetValue collStore n + rng <- treeViewGetVisibleRange collView + getInfo mid $ case rng of + ([f], [t]) -> n >= f && t >= n + _ -> False + +makeConfigDlg = + makeEditorDialog [(stockApply, ResponseApply)] + (makePropertyView (, ())) $ \v -> do + let outerw = outer v + windowSetTitle outerw "Configure collection browser" + windowSetDefaultSize outerw 500 400 + +loadConfig = + catMaybes <$> (mapM property =<< config configFile defaultConfig) + +saveConfig props = do + writeConfig configFile $ map propName props + return () + +configFile = + "collection-view.conf" + +defaultConfig = + ["Artist", "Album", "Track", "Title"] + +setupSearch props = do + treeViewSetEnableSearch collView True + treeViewSetSearchEqualFunc collView $ Just $ \str iter -> do + [n] <- treeModelGetPath collStore iter + mid <- listStoreGetValue collStore n + search (map toLower str) props <$> getInfo mid True + +search _ _ Nothing = False +search _ [] _ = False +search str (prop:props) (Just info) = + let ptext = map toLower $ maybe "" id $ lookup prop info in + if isInfixOf str ptext + then True + else search str props (Just info) + + diff --git a/src/Compound.hs b/src/Compound.hs new file mode 100644 --- /dev/null +++ b/src/Compound.hs @@ -0,0 +1,29 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 1 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Compound + ( CompoundWidget (..) + ) where + + +class CompoundWidget cw where + type Outer cw + outer :: cw -> Outer cw + + diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,126 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 21 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Config + ( config + , writeConfig + , ConfigWidget (..) + , makeConfigDialog + , ConfigDialog + , prepareToShow + ) where + +import Control.Monad + +import Data.Maybe + +import Text.JSON + +import System.FilePath +import System.Directory +import System.IO + +import Graphics.UI.Gtk + +import Environment +import Compound +import Utils + + +config name defl = do + withFile (configFileName name) ReadMode config' `catch` \_ -> return defl + where config' h = do + c <- hGetContents h + case decodeStrict c of + Ok r -> return r + Error _ -> readIO c -- try to read old format + +writeConfig name cont = + writeConfig' >> return True `catch` \_ -> return False + where writeConfig' = do + createDirectoryIfMissing True configBaseDir + writeFile (configFileName name) $ encodeStrict $ showJSON cont + + +configFileName name = joinPath [configBaseDir, name] + +configBaseDir = joinPath [fromJust homeDir, ".vision"] + + +class CompoundWidget cw => ConfigWidget cw where + type Config cw + getConfig :: cw -> IO (Config cw) + setConfig :: cw -> Config cw -> IO () + clearConfig :: cw -> IO () + getChanged :: cw -> IO Bool + clearChanged :: cw -> IO () + grabFocus :: cw -> IO () + + +data ConfigDialog + = ConfigDialog { cDialog :: Dialog + , prepareToShow :: IO () + } + +instance CompoundWidget ConfigDialog where + type Outer ConfigDialog = Dialog + outer = cDialog + +makeConfigDialog make destroy getc setc = do + dialog <- dialogNew + windowSetModal dialog False + dialogSetHasSeparator dialog False + + dialogAddButton dialog "gtk-apply" ResponseApply + dialogAddButton dialog "gtk-cancel" ResponseCancel + dialogAddButtonCR dialog "gtk-ok" ResponseOk + dialogSetResponseSensitive dialog ResponseApply False + + upper <- dialogGetUpper dialog + cw <- make dialog $ dialogSetResponseSensitive dialog ResponseApply True + widgetShowAll $ outer cw + boxPackStartDefaults upper $ outer cw + + let hide = do + widgetHide dialog + clearConfig cw + clearChanged cw + when destroy $ widgetDestroy dialog + prepareToShow = do + setConfig cw =<< getc + grabFocus cw + + dialog `onResponse` \resp -> + case resp of + ResponseApply -> do + dialogSetResponseSensitive dialog ResponseApply False + changed <- getChanged cw + when changed $ setc =<< getConfig cw + clearChanged cw + grabFocus cw + ResponseOk -> do + changed <- getChanged cw + when changed $ setc =<< getConfig cw + hide + _ -> + hide + + return ConfigDialog { cDialog = dialog + , prepareToShow = prepareToShow + } diff --git a/src/Context.hs b/src/Context.hs new file mode 100644 --- /dev/null +++ b/src/Context.hs @@ -0,0 +1,58 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 18 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# LANGUAGE MultiParamTypeClasses, + FlexibleInstances, + OverlappingInstances, + TypeOperators #-} + +module Context + ( ContextClass + , ContextType + , makeContext + , augmentContext + , context + ) where + + +infixr 9 :* +data a :* b = a :* b +data Nil = Nil + +class ContextClass c a where + ctxt :: a -> c + +instance ContextClass c (c :* b) where + ctxt (c :* _) = c + +instance ContextClass c b => ContextClass c (a :* b) where + ctxt (_ :* b) = ctxt b + + +type ContextType a b = a :* b + + +makeContext :: c -> ContextType c Nil +makeContext c = c :* Nil + +augmentContext :: (?context :: c1) => c2 -> ContextType c2 c1 +augmentContext c = c :* ?context + +context :: (?context :: a, ContextClass c a) => c +context = ctxt ?context diff --git a/src/DnD.hs b/src/DnD.hs new file mode 100644 --- /dev/null +++ b/src/DnD.hs @@ -0,0 +1,92 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 10 Sep. 2010 +-- +-- Copyright (C) 2009-2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +module DnD + ( setupDnDReorder + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans + +import Data.IORef + +import Graphics.UI.Gtk + + +setupDnDReorder target store view apply = do + sel <- treeViewGetSelection view + + targetList <- targetListNew + targetListAdd targetList target [TargetSameWidget] 0 + + dropRef <- newIORef False + + dragSourceSet view [Button1] [ActionMove] + dragSourceSetTargetList view targetList + + view `on` dragDataGet $ \_ _ _ -> do + rows <- liftIO $ treeSelectionGetSelectedRows sel + selectionDataSet selectionTypeInteger $ map head rows + return () + + dragDestSet view [DestDefaultMotion, DestDefaultHighlight] [ActionMove] + dragDestSetTargetList view targetList + + view `on` dragDrop $ \ctxt _ tstamp -> do + writeIORef dropRef True + dragGetData view ctxt target tstamp + return True + + view `on` dragDataReceived $ \ctxt (_, y) _ tstamp -> do + drop <- liftIO $ readIORef dropRef + when drop $ do + liftIO $ writeIORef dropRef False + (rows :: Maybe [Int]) <- selectionDataGet selectionTypeInteger + liftIO $ doReorder apply store view y rows + liftIO $ dragFinish ctxt True True tstamp + + view `on` dragDataDelete $ \_ -> + treeSelectionUnselectAll sel + + +doReorder _ _ _ _ Nothing = return () +doReorder apply store view y (Just rows) = do + base <- getTargetRow + apply $ reorder base rows + where getTargetRow = do + maybePos <- treeViewGetPathAtPos view (0, y) + case maybePos of + Just ([n], _, _) -> + return n + Nothing -> + pred <$> listStoreGetSize store + +reorder = reorderDown 0 + where reorderDown _ _ [] = [] + reorderDown dec base rows@(r:rs) + | r <= base = (r - dec, base) : reorderDown (dec + 1) base rs + | otherwise = reorderUp (if dec /= 0 then base + 1 else base) rows + reorderUp _ [] = [] + reorderUp base (r:rs) + | r == base = reorderUp (base + 1) rs + | otherwise = (r, base) : reorderUp (base + 1) rs + diff --git a/src/Editor.hs b/src/Editor.hs new file mode 100644 --- /dev/null +++ b/src/Editor.hs @@ -0,0 +1,141 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 1 Sep. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# LANGUAGE DoRec #-} + +module Editor + ( EditorWidget (..) + , EditorDialog + , makeEditorDialog + , runEditorDialog + ) where + +import Control.Applicative +import Control.Monad +import Control.Concurrent.MVar + +import Data.Maybe + +import Graphics.UI.Gtk + +import Compound +import Utils + + +class CompoundWidget w => EditorWidget w where + type Data w + setData :: w -> Data w -> IO () + getData :: w -> IO (Data w) + clearData :: w -> IO () + setupView :: w -> IO () + focusView :: w -> IO () + getState :: w -> IO (Bool, Bool) + resetModified :: w -> IO () + + clearData = const $ return () + setupView = const $ return () + focusView = const $ return () + + +data EditorWidget e => EditorDialog e + = EditorDialog + { eLock :: MVar () + , eDialog :: Dialog + , eEditor :: e + } + +instance EditorWidget e => CompoundWidget (EditorDialog e) where + type Outer (EditorDialog e) = Dialog + outer = eDialog + + +makeEditorDialog buttons makeEditor setup = do + lock <- newMVar () + + dialog <- dialogNew + hideOnDeleteEvent dialog + dialogSetHasSeparator dialog False + + mapM_ (uncurry $ dialogAddButton dialog) buttons + dialogAddButton dialog stockCancel ResponseCancel + dialogAddButtonCR dialog stockOk ResponseOk + + rec { editor <- makeEditor dialog $ updateState dialog editor } + + upper <- dialogGetUpper dialog + boxPackStartDefaults upper $ outer editor + widgetShowAll $ outer editor + + let e = EditorDialog { eLock = lock + , eDialog = dialog + , eEditor = editor + } + setup e + return e + +runEditorDialog e get set modal parent = do + let dialog = eDialog e + editor = eEditor e + lock = eLock e + + locked <- isJust <$> tryTakeMVar lock + when locked $ do + windowSetModal dialog modal + windowSetTransientFor dialog parent + when modal $ do + windowGroup <- windowGroupNew + windowGroupAddWindow windowGroup parent + windowGroupAddWindow windowGroup dialog + + setData editor =<< get + resetModified editor + updateState dialog editor + dialogSetDefaultResponse dialog ResponseOk + setupView editor + focusView editor + rec { cid <- dialog `onResponse` \resp -> do + let done = do + signalDisconnect cid + widgetHide dialog + clearData editor + putMVar lock () + dialogSetDefaultResponse dialog ResponseOk + focusView editor + case resp of + ResponseApply -> do + (valid, modified) <- getState editor + when (valid && modified) (set =<< getData editor) + resetModified editor + updateState dialog editor + ResponseOk -> do + (valid, modified) <- getState editor + when valid $ do + when modified (set =<< getData editor) + done + _ -> done + } + return () + + windowPresent dialog + + +updateState dialog editor = do + (valid, modified) <- getState editor + dialogSetResponseSensitive dialog ResponseOk valid + dialogSetResponseSensitive dialog ResponseApply modified diff --git a/src/Environment.hs b/src/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Environment.hs @@ -0,0 +1,67 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 18 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# LANGUAGE UndecidableInstances #-} + +module Environment + ( EnvironmentContextClass + , initEnvironment + , homeDir + , dataDir + , uiFilePath + , xmmsPath + , maybeGetEnv + ) where + +import System.Environment +import System.FilePath +import Control.Applicative + +import Context + +import Paths_vision + + +data Environment + = Environment { eHomeDir :: Maybe FilePath + , eDataDir :: FilePath + , eXMMSPath :: Maybe String } + +class (ContextClass Environment c) => EnvironmentContextClass c where {} +instance (ContextClass Environment c) => EnvironmentContextClass c + +homeDir = eHomeDir context +dataDir = eDataDir context +xmmsPath = eXMMSPath context + + +initEnvironment = do + homeDir <- maybeGetEnv "HOME" + dataDir <- getDataDir + xmmsPath <- maybeGetEnv "XMMS_PATH" + return $ makeContext Environment { eHomeDir = homeDir + , eDataDir = dataDir + , eXMMSPath = xmmsPath + } + +maybeGetEnv var = + (Just <$> getEnv var) `catch` \_ -> return Nothing + +uiFilePath name = dataDir "ui" name <.> "xml" + diff --git a/src/Handler.hs b/src/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Handler.hs @@ -0,0 +1,78 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 11 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Handler + ( Id + , Handler + , make + , add + , remove + , invoke + , once + , ever + , keep + ) where + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Foldable + + +data Id m a = Id Int + +type Entry m a = (Int, a -> m Bool) +type Entries m a = IntMap (Entry m a) + +data Handler m a + = Handler { nextId :: Id m a + , entries :: Entries m a + } + +make :: Handler m a +make = Handler { nextId = Id 0, entries = IntMap.empty } + +add :: Monad m => (a -> m Bool) -> Handler m a -> m (Handler m a, Id m a) +add f Handler { nextId = id@(Id n), entries = e } = + return (h, id) + where h = Handler { nextId = Id $ succ n + , entries = IntMap.insert n (n, f) e + } + +remove :: Monad m => Id m a -> Handler m a -> m (Handler m a, ()) +remove (Id n) h = + return (h { entries = IntMap.delete n $ entries h }, ()) + +invoke :: Monad m => a -> Handler m a -> m (Handler m a, ()) +invoke a h@Handler { entries = e } = do + e' <- foldlM (invoke' a) e e + return (h { entries = e' }, ()) + where invoke' a e (i, f) = do + p <- f a + if p + then return e + else return $ IntMap.delete i e + +once :: Monad m => (a -> m b) -> a -> m Bool +once = keep False + +ever :: Monad m => (a -> m b) -> a -> m Bool +ever = keep True + +keep :: Monad m => Bool -> (a -> m b) -> a -> m Bool +keep r f a = f a >> return r diff --git a/src/Index.hs b/src/Index.hs new file mode 100644 --- /dev/null +++ b/src/Index.hs @@ -0,0 +1,113 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 20 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +module Index + ( Index + , makeIndex + , getInfo + , addToIndex + , clearIndex + ) where + +import Control.Concurrent.MVar +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap + +import Graphics.UI.Gtk hiding (add) + +import XMMS2.Client + +import Medialib hiding (getInfo) +import Handler + + +data IndexEntry i + = IENone + | IERetrieving + | IEReady Stamp MediaInfo i + +data Index i + = Index { iTable :: MVar (IntMap (IndexEntry i, [TreeRowReference])) + , iStore :: ListStore MediaId + , iConv :: MediaInfo -> IO i + } + +makeIndex store conv = do + table <- newMVar IntMap.empty + let index = Index { iTable = table + , iStore = store + , iConv = conv + } + + onMediaInfo . add . ever $ handleInfo index + + return index + +handleInfo index (id, stamp, info) = do + let id' = fromIntegral id + modifyMVar_ (iTable index) $ \ix -> + case IntMap.lookup id' ix of + Just (entry, list) -> + updateIndex index ix id' stamp info entry list + Nothing -> + return ix + +updateIndex index ix id stamp info old list = + if upd + then do + ti <- (iConv index) info + mapM_ (touch index) list + return $ IntMap.insert id (IEReady stamp info ti, list) ix + else + return ix + where upd = case old of + IEReady oldStamp _ _ -> stamp /= oldStamp + _ -> True + +touch index ref = do + path <- treeRowReferenceGetPath ref + case path of + [n] -> do + Just iter <- treeModelGetIter (iStore index) [n] + treeModelRowChanged (iStore index) [n] iter + _ -> + return () + +getInfo index id force = do + let id' = fromIntegral id + modifyMVar (iTable index) $ \ix -> + case IntMap.lookup id' ix of + Just (IEReady _ _ info, _) -> + return (ix, Just info) + Just (IENone, list) | force -> do + requestInfo id + return (IntMap.insert id'(IERetrieving, list) ix, Nothing) + _ -> + return (ix, Nothing) + +addToIndex index id n = + modifyMVar_ (iTable index) $ \ix -> do + Just ref <- treeRowReferenceNew (iStore index) [n] + return $ IntMap.insertWith iw (fromIntegral id) (IENone, [ref]) ix + where iw (_, [new]) (entry, old) = (entry, new : old) + +clearIndex index = + modifyMVar_ (iTable index) . const $ return IntMap.empty diff --git a/src/Location.hs b/src/Location.hs new file mode 100644 --- /dev/null +++ b/src/Location.hs @@ -0,0 +1,59 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 28 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Location + ( initLocation + , browseLocation + ) where + +import Graphics.UI.Gtk + +import UI +import Location.History +import Location.Model +import Location.View +import Location.Control +import Location.UI + + +initLocation = + initHistory + + +browseLocation order maybeURL = do + let f = browseLocation + + context <- initUI + let ?context = context + + context <- initModel order + let ?context = context + + context <- initView + let ?context = context + + setupUI f + + widgetShowAll window + case maybeURL of + Just url -> loadLocation $ Go url + Nothing -> openLocation + + + diff --git a/src/Location/Control.hs b/src/Location/Control.hs new file mode 100644 --- /dev/null +++ b/src/Location/Control.hs @@ -0,0 +1,112 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 28 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Location.Control + ( loadLocation + , makeURL + , addToPlaylist + , replacePlaylist + , updateWindowTitle + , openLocation + ) where + +import Prelude hiding (catch) +import Control.Monad.CatchIO +import Control.Monad.Trans + +import Data.Maybe +import Data.List + +import Graphics.UI.Gtk + +import XMMS2.Client + +import XMMS +import Environment +import UI +import Location.History +import Location.Model +import Location.View + + +loadLocation location = do + listStoreClear locationStore + maybeURL <- updateLocation location + case maybeURL of + Just url -> do + addToHistory url + updateWindowTitle + entrySetText locationEntry url + xformMediaBrowse xmms url >>* handleBrowse url + Nothing -> + return () + +handleBrowse url = do + handleBrowse' `catch` \(_ :: XMMSException) -> + liftIO $ putStrLn $ "error loading " ++ url + return False + where handleBrowse' = do + r <- result + liftIO $ do + mapM_ (listStoreAppend locationStore . makeItem) r + widgetGrabFocus locationView + +makeURL url + | isInfixOf "://" url = + url + | isPrefixOf "~/" url && isJust homeDir = + "file://" ++ fromJust homeDir ++ tail url + | otherwise = + "file://" ++ url + +replacePlaylist = do + playlistClear xmms Nothing + addToPlaylist + +addToPlaylist = do + rows <- treeSelectionGetSelectedRows locationSel + mapM_ addOne rows + +addOne p = do + item <- itemByPath p + let path = iPath item + if iIsDir item + then do + playlistRAdd xmms Nothing path + return () + else do + collIdlistFromPlaylistFile xmms path >>* + ((do coll <- result + lift $ playlistAddIdlist xmms Nothing coll + return False) + `catch` + (\(_ :: XMMSException) -> do + lift $ playlistAddURL xmms Nothing path + return False)) + return () + +updateWindowTitle = do + loc <- getCurrentLocation + setWindowTitle $ case loc of + [] -> "Vision location browser" + _ -> loc ++ " - Vision location browser" + +openLocation = do + widgetGrabFocus locationEntry + editableSelectRegion locationEntry 0 (-1) diff --git a/src/Location/History.hs b/src/Location/History.hs new file mode 100644 --- /dev/null +++ b/src/Location/History.hs @@ -0,0 +1,67 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 1 Jul. 2010 +-- +-- Copyright (C) 2009-2010 Oleg Belozeorov +-- 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. +-- + +module Location.History + ( History + , initHistory + , makeHistoryCompletion + , addToHistory + ) where + +import Data.List +import Data.Char + +import Graphics.UI.Gtk + +import Config +import Context + + +data History + = History { hStore :: ListStore String } + +historyStore = hStore context + + +initHistory = do + history <- config "history.urls" [] + store <- listStoreNewDND history Nothing Nothing + return $ augmentContext + History { hStore = store } + +makeHistoryCompletion = do + comp <- entryCompletionNew + + entryCompletionSetModel comp $ Just historyStore + entryCompletionSetTextModel comp historyStore + entryCompletionSetMatchFunc comp $ \s i -> do + [n] <- treeModelGetPath historyStore i + t <- listStoreGetValue historyStore n + return $ isInfixOf s $ map toLower t + + entryCompletionSetPopupCompletion comp True + entryCompletionSetPopupSingleMatch comp True + + return comp + +addToHistory url = do + history <- listStoreToList historyStore + maybe (return ()) (listStoreRemove historyStore) $ elemIndex url history + listStorePrepend historyStore url + writeConfig "history.urls" =<< listStoreToList historyStore + return () diff --git a/src/Location/Model.hs b/src/Location/Model.hs new file mode 100644 --- /dev/null +++ b/src/Location/Model.hs @@ -0,0 +1,220 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 28 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +module Location.Model + ( initModel + , Item (..) + , makeItem + , locationStore + , sortModel + , getCurrentLocation + , onLocation + , LocationChange (..) + , updateLocation + , canGo + , itemByIter + , itemByPath + , setSortOrder + , getSortOrder + ) where + +import Control.Concurrent.MVar +import Control.Applicative + +import Data.List + +import Graphics.UI.Gtk + +import XMMS2.Client + +import Context +import Utils +import Handler + + +data Location + = Location { lCurrent :: String + , lBack :: [String] + , lForward :: [String] + } + +makeLocation = + Location { lCurrent = "" + , lBack = [] + , lForward = [] + } + +data LocationChange + = Back + | Forward + | Go String + | Refresh + | Up + +changeLocation Back l = + case lBack l of + (u : us) -> + (l { lCurrent = u + , lBack = us + , lForward = lCurrent l : lForward l + }, Just u) + _ -> + (l, Nothing) +changeLocation Forward l = + case lForward l of + (u : us) -> + (l { lCurrent = u + , lBack = lCurrent l : lBack l + , lForward = us + }, Just u) + _ -> + (l, Nothing) +changeLocation (Go u) l = + (l { lCurrent = u + , lBack = case lCurrent l of + [] -> lBack l + u' -> u' : lBack l + , lForward = [] + }, Just u) +changeLocation Refresh l = + (l, Just $ lCurrent l) +changeLocation Up l = + let u = reverse . dropWhile (/= '/') . tail . reverse $ lCurrent l + in changeLocation (Go u) l + + +data State + = State { sLocation :: Location + , sOrder :: SortType + } + +makeState order = + State { sLocation = makeLocation + , sOrder = order + } + +data Item + = Item { iName :: String + , iPath :: String + , iIsDir :: Bool + } + +makeItem x = + Item { iName = name + , iPath = path + , iIsDir = entryIsDir x + } + where name = last $ split $ path + path = decodeURL $ entryPath x + +compareItems SortDescending a b + | iIsDir a == iIsDir b = compare (iName b) (iName a) + | iIsDir a = LT + | iIsDir b = GT +compareItems SortAscending a b + | iIsDir a == iIsDir b = compare (iName a) (iName b) + | iIsDir a = LT + | iIsDir b = GT + + +data Model + = Model { mState :: MVar State + , mStore :: ListStore Item + , mSort :: TypedTreeModelSort Item + , mOnLocation :: HandlerMVar () + } + +locationStore = mStore context +sortModel = mSort context +onLocation = onHandler $ mOnLocation context +state = mState context + +getCurrentLocation = + withMVar state $ return . lCurrent . sLocation + +updateLocation change = do + r <- modifyMVar state $ \s -> do + let (l, u) = changeLocation change $ sLocation s + return (s { sLocation = l }, u) + onLocation $ invoke () + return r + +canGo = withMVar state $ \s -> + let Location { lCurrent = c + , lBack = b + , lForward = f + } = sLocation s + in return (not $ null b, + not $ null f, + not $ null c || isSuffixOf "//" c, + not $ null c) + + +initModel order = do + context <- initContext order + let ?context = context + + setSortOrder order + + return ?context + + +initContext order = do + state <- newMVar $ makeState order + store <- listStoreNewDND [] Nothing Nothing + sort <- treeModelSortNewWithModel store + onLocation <- makeHandlerMVar + return $ augmentContext + Model { mState = state + , mStore = store + , mSort = sort + , mOnLocation = onLocation + } + +split [] = [] +split s = + let (p, s') = break (== '/') s in + p : case s' of + [] -> [] + (_:s'') -> split s'' + +itemByIter' iter = do + [n] <- treeModelGetPath locationStore iter + listStoreGetValue locationStore n + +itemByIter iter = do + citer <- treeModelSortConvertIterToChildIter sortModel iter + itemByIter' citer + +itemByPath path = do + [n] <- treeModelSortConvertPathToChildPath sortModel path + listStoreGetValue locationStore n + +compareIters order a b = + compareItems order <$> itemByIter' a <*> itemByIter' b + +getSortOrder = + withMVar state $ return . sOrder + +setSortOrder order = do + modifyMVar_ state $ \s -> + return s { sOrder = order } + treeSortableSetDefaultSortFunc sortModel $ compareIters order diff --git a/src/Location/UI.hs b/src/Location/UI.hs new file mode 100644 --- /dev/null +++ b/src/Location/UI.hs @@ -0,0 +1,281 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 28 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Location.UI + ( setupUI + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans + +import Graphics.UI.Gtk hiding (add) + +import UI +import XMMS +import Handler +import Utils +import Location.Model +import Location.View +import Location.Control + + +setupUI browse = do + addUIActions $ uiActions browse + + srvAG <- actionGroupNew "server" + actionGroupAddActions srvAG $ srvActions browse + onServerConnectionAdd . ever $ actionGroupSetSensitive srvAG + insertActionGroup srvAG 1 + + addUIFromFile "location-browser" + + toolbar <- getWidget castToToolbar "ui/toolbar" + toolbarSetStyle toolbar ToolbarIcons + boxPackStart contents toolbar PackNatural 0 + + item <- toolItemNew + toolItemSetHomogeneous item False + toolItemSetExpand item True + containerAdd item locationEntry + toolbarInsert toolbar item 6 + + load <- getAction srvAG "load" + locationEntry `onEntryActivate` do + actionActivate load + + scroll <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic + containerAdd scroll locationView + boxPackStartDefaults contents scroll + + popup <- getWidget castToMenu "ui/location-popup" + setupTreeViewPopup locationView popup + + down <- getAction srvAG "down" + binw <- getAction srvAG "browse-in-new-window" + addp <- getAction srvAG "add-to-playlist" + repp <- getAction srvAG "replace-playlist" + let updateB = do + rows <- treeSelectionGetSelectedRows locationSel + (enp, enn) <- case rows of + [] -> + return (False, False) + [path] -> do + item <- itemByPath path + return (True, iIsDir item) + _ -> + return (True, False) + mapM_ (flip actionSetSensitive enp) [addp, repp] + mapM_ (flip actionSetSensitive enn) [down, binw] + locationSel `onSelectionChanged` updateB + updateB + + locationView `onRowActivated` \_ _ -> + actionActivate down + + locationView `on` buttonPressEvent $ tryEvent $ do + MiddleButton <- eventButton + SingleClick <- eventClick + (x, y) <- eventCoordinates + liftIO $ do + maybePath <- treeViewGetPathAtPos locationView (round x, round y) + case maybePath of + Just (path, _, _) -> do + treeViewSetCursor locationView path Nothing + actionActivate binw + Nothing -> + return () + + back <- getAction srvAG "back" + forward <- getAction srvAG "forward" + up <- getAction srvAG "up" + refresh <- getAction srvAG "refresh" + let updateN = do + (eb, ef, eu, er) <- canGo + actionSetSensitive back eb + actionSetSensitive forward ef + actionSetSensitive up eu + actionSetSensitive refresh er + onLocation . add . ever . const $ updateN + updateN + + updateWindowTitle + + return () + + +uiActions browse = + [ ActionEntry + { actionEntryName = "location" + , actionEntryLabel = "_Location" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "new-window" + , actionEntryLabel = "_New window" + , actionEntryStockId = Just stockNew + , actionEntryAccelerator = Just "n" + , actionEntryTooltip = Nothing + , actionEntryCallback = newWindow browse + } + , ActionEntry + { actionEntryName = "open-location" + , actionEntryLabel = "_Open location" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Just "l" + , actionEntryTooltip = Nothing + , actionEntryCallback = openLocation + } + , ActionEntry + { actionEntryName = "go" + , actionEntryLabel = "_Go" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "location-popup" + , actionEntryLabel = "" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "clear" + , actionEntryLabel = "" + , actionEntryStockId = Just stockClear + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = clearLocationEntry + } + ] + +srvActions browse = + [ ActionEntry + { actionEntryName = "load" + , actionEntryLabel = "" + , actionEntryStockId = Just stockJumpTo + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = loadCurrentLocation + } + , ActionEntry + { actionEntryName = "down" + , actionEntryLabel = "" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = loadAtCursor (loadLocation . Go) + } + , ActionEntry + { actionEntryName = "browse-in-new-window" + , actionEntryLabel = "_Browse in new window" + , actionEntryStockId = Just stockOpen + , actionEntryAccelerator = Just "Return" + , actionEntryTooltip = Nothing + , actionEntryCallback = browseInNewWindow browse + } + , ActionEntry + { actionEntryName = "add-to-playlist" + , actionEntryLabel = "_Add to playlist" + , actionEntryStockId = Just stockAdd + , actionEntryAccelerator = Just "p" + , actionEntryTooltip = Nothing + , actionEntryCallback = addToPlaylist + } + , ActionEntry + { actionEntryName = "replace-playlist" + , actionEntryLabel = "_Replace playlist" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Just "p" + , actionEntryTooltip = Nothing + , actionEntryCallback = replacePlaylist + } + , ActionEntry + { actionEntryName = "back" + , actionEntryLabel = "Go _back" + , actionEntryStockId = Just stockGoBack + , actionEntryAccelerator = Just "Left" + , actionEntryTooltip = Nothing + , actionEntryCallback = loadLocation Back + } + , ActionEntry + { actionEntryName = "forward" + , actionEntryLabel = "Go _forward" + , actionEntryStockId = Just stockGoForward + , actionEntryAccelerator = Just "Right" + , actionEntryTooltip = Nothing + , actionEntryCallback = loadLocation Forward + } + , ActionEntry + { actionEntryName = "up" + , actionEntryLabel = "Go _up" + , actionEntryStockId = Just stockGoUp + , actionEntryAccelerator = Just "Up" + , actionEntryTooltip = Nothing + , actionEntryCallback = loadLocation Up + } + , ActionEntry + { actionEntryName = "refresh" + , actionEntryLabel = "_Refresh" + , actionEntryStockId = Just stockRefresh + , actionEntryAccelerator = Just "F5" + , actionEntryTooltip = Nothing + , actionEntryCallback = loadLocation Refresh + } + ] + +loadCurrentLocation = do + text <- trim <$> entryGetText locationEntry + case text of + [] -> do + cur <- getCurrentLocation + case cur of + [] -> return () + _ -> do + entrySetText locationEntry cur + widgetGrabFocus locationView + _ -> loadLocation . Go $ makeURL text + +loadAtCursor func = do + (path, _) <- treeViewGetCursor locationView + case path of + [_] -> do + item <- itemByPath path + when (iIsDir item) $ func $ iPath item + _ -> + return () + +clearLocationEntry = do + entrySetText locationEntry "" + widgetGrabFocus locationEntry + +browseInNewWindow browse = do + order <- getSortOrder + loadAtCursor (browse order . Just) + +newWindow browse = do + order <- getSortOrder + browse order Nothing diff --git a/src/Location/View.hs b/src/Location/View.hs new file mode 100644 --- /dev/null +++ b/src/Location/View.hs @@ -0,0 +1,105 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 28 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Location.View + ( initView + , locationView + , locationSel + , locationEntry + ) where + +import Data.List +import Data.Char + +import Graphics.UI.Gtk + +import Context +import Location.Model +import Location.History + + +data View + = View { vView :: TreeView + , vSel :: TreeSelection + , vEntry :: Entry + } + +locationView = vView context +locationSel = vSel context +locationEntry = vEntry context + + +initView = do + context <- initContext + let ?context = context + + treeViewSetRulesHint locationView True + + treeSelectionSetMode locationSel SelectionMultiple + + column <- treeViewColumnNew + treeViewAppendColumn locationView column + treeViewColumnSetTitle column "Name" + treeViewColumnSetSortOrder column =<< getSortOrder + treeViewColumnSetSortIndicator column True + treeViewColumnSetClickable column True + column `onColClicked` do + order <- treeViewColumnGetSortOrder column + let order' = case order of + SortAscending -> SortDescending + SortDescending -> SortAscending + treeViewColumnSetSortOrder column order' + setSortOrder order' + + cell <- cellRendererPixbufNew + treeViewColumnPackStart column cell False + cellLayoutSetAttributeFunc column cell sortModel $ \iter -> do + item <- itemByIter iter + cell `set` [ cellPixbufStockId := + if iIsDir item + then stockDirectory + else stockFile ] + + cell <- cellRendererTextNew + treeViewColumnPackStart column cell True + cellLayoutSetAttributeFunc column cell sortModel $ \iter -> do + item <- itemByIter iter + cell `set` [ cellText := iName item ] + + treeViewSetEnableSearch locationView True + treeViewSetSearchEqualFunc locationView $ Just $ \str iter -> do + item <- itemByIter iter + return $ isInfixOf (map toLower str) (map toLower $ iName item) + + comp <- makeHistoryCompletion + entrySetCompletion locationEntry comp + + return ?context + + +initContext = do + view <- treeViewNewWithModel sortModel + sel <- treeViewGetSelection view + entry <- entryNew + return $ augmentContext + View { vView = view + , vSel = sel + , vEntry = entry + } + diff --git a/src/Medialib.hs b/src/Medialib.hs new file mode 100644 --- /dev/null +++ b/src/Medialib.hs @@ -0,0 +1,168 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 18 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Medialib + ( Stamp + , MediaInfo + , initMedialib + , requestInfo + , onMediaInfo + , getInfo + , retrieveProperties + ) where + +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Trans + +import Data.Map (Map) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Maybe +import Data.List +import Data.IORef + +import Graphics.UI.Gtk hiding (add, remove) + +import XMMS2.Client +import XMMS2.Client.Bindings (propdictToDict) + +import Utils +import Context +import XMMS +import Handler + + +type Stamp = Int +type MediaInfo = Map String Property + + +data CacheEntry + = CEReady Stamp MediaInfo + | CERetrieving + +data Cache + = Cache { cEntries :: IntMap CacheEntry + , cNextStamp :: Stamp + } + +emptyCache = + Cache { cEntries = IntMap.empty + , cNextStamp = 1 + } + + +data MLib + = MLib { mCache :: MVar Cache + , mOnMediaInfo :: HandlerMVar (MediaId, Stamp, MediaInfo) + } + +cache = mCache context + + +onMediaInfo = onHandler $ mOnMediaInfo context + +initMedialib = do + context <- initContext + let ?context = context + + onServerConnectionAdd . ever $ \conn -> + if conn + then do + broadcastMedialibEntryChanged xmms >>* do + id <- result + let id' = fromIntegral id + liftIO $ do + withMVar cache $ \cache -> + when (isJust . IntMap.lookup id' $ cEntries cache) $ + medialibGetInfo xmms id >>* handleInfo id' + return True + else + modifyMVar_ cache $ \cache -> + return cache { cEntries = IntMap.empty } + + return ?context + +requestInfo id = do + modifyMVar_ cache $ \cache -> + let id' = fromIntegral id + entries = cEntries cache in + case IntMap.lookup id' entries of + Nothing -> do + medialibGetInfo xmms id >>* handleInfo id' + return cache { cEntries = IntMap.insert id' CERetrieving $ cEntries cache } + Just (CEReady s i) -> do + idleAdd (onMediaInfo (invoke (id, s, i)) >> return False) priorityHighIdle + return cache + _ -> + return cache + + +initContext = do + cache <- newMVar emptyCache + onMediaInfo <- makeHandlerMVar + return $ augmentContext + MLib { mCache = cache + , mOnMediaInfo = onMediaInfo } + +handleInfo id = do + rawv <- resultRawValue + liftIO $ do + info <- valueGet =<< propdictToDict rawv [] + stamp <- modifyMVar cache $ \cache -> + let stamp = cNextStamp cache + entries = cEntries cache + entry = CEReady stamp info in + return (Cache { cEntries = IntMap.insert id entry entries + , cNextStamp = succ stamp }, stamp) + onMediaInfo $ invoke (fromIntegral id, stamp, info) + return False + +getInfo id = + withMVar cache $ \cache -> + return $ case IntMap.lookup (fromIntegral id) $ cEntries cache of + Just (CEReady _ info) -> Just info + _ -> Nothing + +retrieveProperties ids f = do + let ids' = nub ids + len = length ids' + step = len `div` 100 + + ref <- newIORef (0, ids', []) + hid <- onMediaInfo . add $ \(id, _, info) -> do + (ctr, todo, ready) <- readIORef ref + case todo of + (i:is) | i == id -> do + if null is + then do + f . Right $ reverse ((id, info) : ready) + return False + else do + let ctr' = ctr + 1 + when (step == 0 || ctr' `mod` step == 0) $ + f . Left $ fromIntegral ctr' / fromIntegral len + requestInfo $ head is + writeIORef ref (ctr', is, (id, info) : ready) + return True + _ -> + return True + + requestInfo $ head ids + return . onMediaInfo $ remove hid diff --git a/src/Playback.hs b/src/Playback.hs new file mode 100644 --- /dev/null +++ b/src/Playback.hs @@ -0,0 +1,174 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 20 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playback + ( initPlayback + , onPlaybackStatus + , onPlaybackStatusAdd + , onCurrentTrack + , getPlaybackStatus + , getCurrentTrack + , startPlayback + , pausePlayback + , stopPlayback + , restartPlayback + , prevTrack + , nextTrack + , requestCurrentTrack + ) where + +import Control.Concurrent.MVar +import Control.Monad.Trans + +import XMMS2.Client + +import XMMS +import Handler +import Context +import Utils + + +data State + = State { sCurrentTrack :: Maybe (Int, String) + , sStatus :: Maybe PlaybackStatus + } + +data Playback + = Playback { pState :: MVar State + , pOnPlaybackStatus :: HandlerMVar (Maybe PlaybackStatus) + , pOnCurrentTrack :: HandlerMVar (Maybe (Int, String)) + } + +state = pState context + +onPlaybackStatus = onHandler (pOnPlaybackStatus context) +onPlaybackStatusAdd f = do + id <- onPlaybackStatus . add $ f + f =<< getPlaybackStatus + return id + +onCurrentTrack = onHandler (pOnCurrentTrack context) + +getPlaybackStatus = + withMVar state $ return . sStatus + +getCurrentTrack = + withMVar state $ return . sCurrentTrack + + +initPlayback = do + context <- initContext + let ?context = context + + onServerConnectionAdd . ever $ \conn -> + if conn + then do + broadcastPlaybackStatus xmms >>* do + liftIO requestStatus + return True + requestStatus + broadcastPlaylistCurrentPos xmms >>* do + liftIO $ requestCurrentTrack + return True + requestCurrentTrack + else + resetState + + return ?context + + +initContext = do + state <- newMVar makeState + onPlaybackStatus <- makeHandlerMVar + onCurrentTrack <- makeHandlerMVar + return $ augmentContext + Playback { pState = state + , pOnPlaybackStatus = onPlaybackStatus + , pOnCurrentTrack = onCurrentTrack + } + +makeState = + State { sCurrentTrack = Nothing + , sStatus = Nothing + } + +resetState = do + modifyMVar_ state $ const $ return makeState + invokeOnPlaybackStatus + +setStatus s = do + modifyMVar_ state $ \state -> + return state { sStatus = s } + invokeOnPlaybackStatus + +requestStatus = + playbackStatus xmms >>* do + status <- result + liftIO . setStatus $ Just status + return False + +requestCurrentTrack = + playlistCurrentPos xmms Nothing >>* do + new <- catchResult Nothing (Just . mapFst fromIntegral) + liftIO $ do + old <- modifyMVar state $ \state -> + return (state { sCurrentTrack = new }, sCurrentTrack state) + onCurrentTrack $ invoke old + return False + +startPlayback False = do + playbackStart xmms + return () +startPlayback True = do + ps <- getPlaybackStatus + case ps of + Just StatusPlay -> + playbackTickle xmms + Just StatusPause -> do + playbackTickle xmms + playbackStart xmms + playbackTickle xmms + _ -> + playbackStart xmms + return () + +pausePlayback = do + playbackPause xmms + return () + +stopPlayback = do + playbackStop xmms + return () + +nextTrack = do + playlistSetNextRel xmms 1 + playbackTickle xmms + return () + +prevTrack = do + playlistSetNextRel xmms (-1) + playbackTickle xmms + return () + +invokeOnPlaybackStatus = + onPlaybackStatus . invoke =<< getPlaybackStatus + +restartPlayback = do + playbackTickle xmms + return () diff --git a/src/Playlist.hs b/src/Playlist.hs new file mode 100644 --- /dev/null +++ b/src/Playlist.hs @@ -0,0 +1,64 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 20 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playlist + ( initPlaylist + , showPlaylist + ) where + +import Graphics.UI.Gtk + +import UI + +import Playlist.Model +import Playlist.Index +import Playlist.Format +import Playlist.View +import Playlist.Config +import Playlist.Search +import Playlist.Update +import Playlist.DnD +import Playlist.UI + + +initPlaylist = + initFormat + +showPlaylist = do + context <- initUI + let ?context = context + + context <- initModel + let ?context = context + + context <- initIndex + let ?context = context + + context <- initView + let ?context = context + + context <- initPlaylistConfig + let ?context = context + + setupSearch + setupUpdate + setupDnD + setupUI + + widgetShowAll window diff --git a/src/Playlist/Config.hs b/src/Playlist/Config.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/Config.hs @@ -0,0 +1,51 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 1 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playlist.Config + ( initPlaylistConfig + , showPlaylistConfigDialog + ) where + +import System.IO.Unsafe + +import Graphics.UI.Gtk + +import UI +import Editor +import Context +import Compound +import Playlist.Format +import Playlist.Format.Config + + +data Config + = Config { cDialog :: EditorDialog FormatView } + +initPlaylistConfig = do + dialog <- unsafeInterleaveIO $ makeEditorDialog + [(stockApply, ResponseApply)] + makePlaylistFormatView $ \m -> do + let outerw = outer m + windowSetTitle outerw "Configure playlist" + windowSetDefaultSize outerw 500 400 + return $ augmentContext + Config { cDialog = dialog } + +showPlaylistConfigDialog = + runEditorDialog (cDialog context) getFormatDefs putFormatDefs False window diff --git a/src/Playlist/Control.hs b/src/Playlist/Control.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/Control.hs @@ -0,0 +1,79 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 2 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playlist.Control + ( clearPlaylist + , currentTrackThisPlaylist + , removeTracks + , insertIds + , moveTracks + , playTrack + , showPropertyEditor + , showPropertyExport + ) where + +import Control.Monad + +import XMMS2.Client + +import XMMS +import Playback +import qualified Properties as P +import Playlist.Model +import Playlist.View + + +clearPlaylist = do + playlistClear xmms =<< getPlaylistName + return () + +currentTrackThisPlaylist = do + maybeName <- getPlaylistName + maybeCPos <- getCurrentTrack + return $ case (maybeName, maybeCPos) of + (Just pname, Just (track, cname)) | pname == cname -> + Just track + _ -> + Nothing + +removeTracks tracks = do + name <- getPlaylistName + mapM_ (playlistRemoveEntry xmms name) $ reverse tracks + +insertIds ids pos = do + start <- case pos of + Just n -> return n + Nothing -> getPlaylistSize + name <- getPlaylistName + zipWithM_ (playlistInsertId xmms name) [start .. ] ids + +moveTracks tracks = do + name <- getPlaylistName + mapM_ (uncurry (playlistMoveEntry xmms name)) tracks + +playTrack n = do + playlistSetNext xmms $ fromIntegral n + startPlayback True + +showPropertyEditor = withSelectedIds P.showPropertyEditor + +showPropertyExport = withSelectedIds P.showPropertyExport + +withSelectedIds f = + f =<< playlistGetIds =<< getSelectedTracks diff --git a/src/Playlist/DnD.hs b/src/Playlist/DnD.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/DnD.hs @@ -0,0 +1,32 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 21 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playlist.DnD + ( setupDnD + ) where + +import Atoms +import DnD +import Playlist.Model +import Playlist.View +import Playlist.Control + + +setupDnD = + setupDnDReorder xmms2PosList playlistStore playlistView moveTracks diff --git a/src/Playlist/Edit.hs b/src/Playlist/Edit.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/Edit.hs @@ -0,0 +1,82 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 26 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playlist.Edit + ( editDelete + , editCopy + , editPaste + , editSelectAll + , editInvertSelection + , editCheckClipboard + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans + +import Graphics.UI.Gtk + +import Atoms +import Utils +import Clipboard +import Playback +import Playlist.Model +import Playlist.View +import Playlist.Control + + +editDelete cut = do + tracks <- getSelectedTracks + when cut $ copyIds tracks + removeTracks tracks + maybeTrack <- currentTrackThisPlaylist + fmaybeM_ maybeTrack $ \t -> + when (t `elem` tracks) restartPlayback + +editCopy = copyIds =<< getSelectedTracks + +editPaste append = + clipboardRequestContents clipboard xmms2MlibId $ do + maybeIds <- selectionDataGet selectionTypeInteger + fmaybeM_ maybeIds $ \ids -> liftIO $ do + (path, _) <- treeViewGetCursor playlistView + insertIds ids $ case path of + [n] | not append -> Just n + _ -> Nothing + +editSelectAll = + treeSelectionSelectAll playlistSel + +editInvertSelection = do + rows <- treeSelectionGetSelectedRows playlistSel + treeSelectionSelectAll playlistSel + mapM_ (treeSelectionUnselectPath playlistSel) rows + +editCheckClipboard = + elem xmms2MlibId <$> getClipboardTargets + + +copyIds tracks = do + ids <- playlistGetIds tracks + clipboardSetWithData clipboard + [(xmms2MlibId, 0)] + (const $ selectionDataSet selectionTypeInteger ids) + (return ()) + return () + diff --git a/src/Playlist/Format.hs b/src/Playlist/Format.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/Format.hs @@ -0,0 +1,170 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 22 Feb. 2010 +-- +-- Copyright (C) 2009-2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# LANGUAGE TupleSections #-} + +module Playlist.Format + ( initFormat + , makeTrackInfo + , getFormatDefs + , putFormatDefs + , TrackInfo (..) + , trackInfoAttrs + , trackInfoText + , trackInfoDuration + , onFormatsChanged + ) where + +import Prelude hiding (lookup) + +import Control.Applicative +import Control.Monad + +import Data.IORef +import Data.Maybe +import Data.Either +import Data.Char (toLower) + +import Graphics.UI.Gtk hiding (add) +import System.Glib.GError + +import Medialib +import Properties +import Config +import Utils +import Context +import Handler +import Playlist.Format.Format +import Playlist.Format.Parser + + +data TrackInfo + = TrackInfo { tAttrs :: [AttrOp CellRendererText] + , tText :: String + , tDuration :: String } + +trackInfoAttrs Nothing = [ cellTextMarkup := Just "" ] +trackInfoAttrs (Just i) = tAttrs i + +trackInfoText Nothing = "" +trackInfoText (Just i) = tText i + +trackInfoDuration Nothing = "" +trackInfoDuration (Just i) = tDuration i + + +data Format + = Format { fMakeInfoRef :: IORef (MediaInfo -> IO ([AttrOp CellRendererText], String)) + , fFormatDefsRef :: IORef [String] + , fLookupDuration :: MediaInfo -> String + , fLookupURL :: MediaInfo -> String + , fOnFormatsChanged :: HandlerMVar () + } + +getMakeInfo = readIORef (fMakeInfoRef context) +putMakeInfo = writeIORef (fMakeInfoRef context) + +getFormatDefs = readIORef (fFormatDefsRef context) +putFormatDefs' = writeIORef (fFormatDefsRef context) +putFormatDefs defs = do + putFormatDefs' defs + saveFormatDefs + updateFormats True + +lookupDuration = fLookupDuration context +lookupURL = fLookupURL context + +onFormatsChanged = onHandler $ fOnFormatsChanged context + + +initFormat = do + context <- initContext + let ?context = context + + loadFormatDefs + onProperties . add . ever . const $ + updateFormats True + + return ?context + +initContext = do + formatDefsRef <- newIORef [] + makeInfoRef <- newIORef $ const $ return ([], "") + duration <- fromJust <$> property "Duration" + url <- fromJust <$> property "URL" + onFormatsChanged <- makeHandlerMVar + return $ augmentContext + Format { fMakeInfoRef = makeInfoRef + , fFormatDefsRef = formatDefsRef + , fLookupDuration = maybe "" escapeMarkup . lookup duration + , fLookupURL = maybe "" escapeMarkup . lookup url + , fOnFormatsChanged = onFormatsChanged + } + + +loadFormatDefs = do + putFormatDefs' . map trim =<< config "playlist-formats.conf" builtinFormats + updateFormats False + where builtinFormats = + [ "{Movement}[: {Title}]\n\ + \{Composer} — {Work}[, {Catalog}]" + , "{Work}[, {Catalog}]\n\ + \{Composer}" + , "{Movement}[: {Title}]\n\ + \{Composer} — {Work}[, {Catalog}][\n\ + \{Performer}][\n\ + \[{Conductor}, ]{Orchestra}][\n\ + \[{Chorus master}, ]{Chorus}]" + , "{Work}[, {Catalog}]\n\ + \{Composer}[\n\ + \{Performer}][\n\ + \[{Conductor}, ]{Orchestra}][\n\ + \[{Chorus master}, ]{Chorus}]" + , "[{Track} ]{Title}\n\ + \{Artist} — {Album}" ] + +saveFormatDefs = do + writeConfig "playlist-formats.conf" =<< getFormatDefs + return () + +getFormats = (rights . map parseFormat) <$> getFormatDefs + +updateFormats notify = do + putMakeInfo =<< makeMakeInfo =<< getFormats + when notify $ onFormatsChanged $ invoke () + +makeTrackInfo info = do + makeInfo <- getMakeInfo + (attrs, text) <- makeInfo info + return TrackInfo { tAttrs = attrs + , tText = text + , tDuration = lookupDuration info } + +makeMakeInfo fs = do + fs' <- rights <$> mapM cookFormat fs + return $ \pm -> do + let (text, ellipsize) = + maybe (lookupURL pm, EllipsizeMiddle) (, EllipsizeEnd) $ + formatMediaInfo fs' pm + search <- map toLower <$> plain text + return ( [ cellTextMarkup := Just text + , cellTextEllipsize := ellipsize ] + , search ) + where plain text = + (trd <$> parseMarkup text '\0') `catchGError` \_ -> return "" diff --git a/src/Playlist/Format/Config.hs b/src/Playlist/Format/Config.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/Format/Config.hs @@ -0,0 +1,253 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 1 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# LANGUAGE TupleSections #-} + +module Playlist.Format.Config + ( FormatView + , makePlaylistFormatView + ) where + +import Control.Monad + +import Data.IORef + +import System.IO.Unsafe + +import Graphics.UI.Gtk + +import Utils +import Compound +import Editor + + +data FormatView + = FormatView { fBox :: HBox + , fStore :: ListStore String + , fView :: TreeView + , fChanged :: IORef Bool + , fCids :: [ConnectId (ListStore String)] + } + +instance CompoundWidget FormatView where + type Outer FormatView = HBox + outer = fBox + +instance EditorWidget FormatView where + type Data FormatView = [String] + setData = formatViewSetData + getData = formatViewGetData + clearData = formatViewClearData + setupView = formatViewSetupView + focusView = formatViewFocusView + getState = formatViewGetState + resetModified = formatViewResetModified + +formatViewSetData f d = + withoutChanged f $ do + let store = fStore f + listStoreClear store + mapM_ (listStoreAppend store) d + +formatViewGetData = + listStoreToList . fStore + +formatViewClearData f = + withoutChanged f . listStoreClear $ fStore f + +formatViewSetupView f = + treeViewSetCursor (fView f) [0] Nothing + +formatViewFocusView = + widgetGrabFocus . fView + +formatViewGetState = + liftM (True, ) . readIORef . fChanged + +formatViewResetModified = + flip writeIORef False . fChanged + +withoutChanged FormatView { fCids = cids } = + bracket_ (mapM_ signalBlock cids) (mapM_ signalUnblock cids) + +makePlaylistFormatView parent onChanged = do + box <- hBoxNew False 5 + containerSetBorderWidth box 7 + + bbox <- vButtonBoxNew + buttonBoxSetLayout bbox ButtonboxStart + boxSetSpacing bbox 5 + boxPackEnd box bbox PackNatural 0 + + scroll <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic + scrolledWindowSetShadowType scroll ShadowIn + boxPackStartDefaults box scroll + + let mkButton m = do + button <- buttonNewWithMnemonic m + widgetSetCanFocus button False + containerAdd bbox button + return button + + addB <- mkButton "_Add" + editB <- mkButton "_Edit" + deleteB <- mkButton "_Delete" + + changedRef <- newIORef False + store <- listStoreNew [] + + view <- treeViewNewWithModel store + treeViewSetRulesHint view True + treeViewSetHeadersVisible view False + treeViewSetReorderable view True + containerAdd scroll view + + column <- treeViewColumnNew + treeViewAppendColumn view column + + cell <- cellRendererTextNew + treeViewColumnPackStart column cell True + cellLayoutSetAttributes column cell store $ \t -> [ cellText := t ] + + sel <- treeViewGetSelection view + treeSelectionSetMode sel SelectionBrowse + sel `onSelectionChanged` do + n <- treeSelectionCountSelectedRows sel + let enable = n > 0 + widgetSetSensitive editB enable + widgetSetSensitive deleteB enable + + let handleChange path _ = do + treeViewSetCursor view path Nothing + handleChange' + handleChange' = do + writeIORef changedRef True + onChanged + + insId <- store `on` rowInserted $ handleChange + chgId <- store `on` rowChanged $ handleChange + delId <- store `on` rowDeleted $ \[n] -> do + size <- listStoreGetSize store + case size of + 0 -> return () + k -> treeViewSetCursor view [if k > n then n else k - 1] Nothing + handleChange' + + editor <- unsafeInterleaveIO $ makeEditorDialog [] + makeFormatEditor $ \fe -> do + let outerw = outer fe + windowSetTitle outerw "Edit format" + windowSetDefaultSize outerw 500 400 + + let startEditing pos = + runEditorDialog editor + (case pos of + Just pos -> listStoreGetValue store pos + Nothing -> return "") + (\text -> case pos of + Just pos -> do + oldText <- listStoreGetValue store pos + unless (text == oldText) $ + listStoreSetValue store pos text + Nothing -> do + listStoreAppend store text + return ()) + True parent + + view `onRowActivated` \[n] _ -> startEditing $ Just n + addB `onClicked` startEditing Nothing + editB `onClicked` do + ([n], _) <- treeViewGetCursor view + startEditing $ Just n + deleteB `onClicked` do + ([n], _) <- treeViewGetCursor view + listStoreRemove store n + + return FormatView { fBox = box + , fStore = store + , fView = view + , fChanged = changedRef + , fCids = [insId, chgId, delId] + } + + +data FormatEditor + = FormatEditor + { eScroll :: ScrolledWindow + , eBuff :: TextBuffer + , eView :: TextView + , eCid :: ConnectId TextBuffer + } + +instance CompoundWidget FormatEditor where + type Outer FormatEditor = ScrolledWindow + outer = eScroll + +instance EditorWidget FormatEditor where + type Data FormatEditor = String + setData = formatEditorSetData + getData = formatEditorGetData + clearData = formatEditorClearData + setupView = formatEditorSetupView + focusView = formatEditorFocusView + getState = formatEditorGetState + resetModified = formatEditorResetModified + +formatEditorSetData = + textBufferSetText . eBuff + +formatEditorGetData FormatEditor { eBuff = buff } = do + start <- textBufferGetStartIter buff + end <- textBufferGetEndIter buff + textBufferGetText buff start end False + +formatEditorClearData = + flip textBufferSetText "" . eBuff + +formatEditorSetupView FormatEditor { eBuff = buff } = do + start <- textBufferGetStartIter buff + textBufferPlaceCursor buff start + +formatEditorFocusView = + widgetGrabFocus . eView + +formatEditorGetState = + liftM (True, ) . textBufferGetModified . eBuff + +formatEditorResetModified e = + withSignalBlocked (eCid e) $ textBufferSetModified (eBuff e) False + +makeFormatEditor _ onStateChanged = do + buff <- textBufferNew Nothing + cid <- buff `on` modifiedChanged $ onStateChanged + + view <- textViewNewWithBuffer buff + + scroll <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic + scrolledWindowSetShadowType scroll ShadowIn + containerSetBorderWidth scroll 7 + containerAdd scroll view + + return FormatEditor { eScroll = scroll + , eBuff = buff + , eView = view + , eCid = cid + } diff --git a/src/Playlist/Format/Format.hs b/src/Playlist/Format/Format.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/Format/Format.hs @@ -0,0 +1,57 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 23 Feb. 2010 +-- +-- Copyright (C) 2009-2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playlist.Format.Format + ( Fe (..) + , cookFormat + , formatMediaInfo + ) where + +import Prelude hiding (lookup) + +import Control.Applicative +import Control.Monad +import Control.Monad.Writer +import Control.Monad.Error + +import Graphics.UI.Gtk (escapeMarkup) + +import Properties + + +data Fe a + = FeP a + | FeL String + | FeO [Fe a] + + +cookFormat fmt = runErrorT (mapM f fmt) + where f (FeP n) = + maybe (throwError "") (return . FeP) =<< (liftIO $ property n) + f (FeL s) = + return $ FeL s + f (FeO l) = + FeO <$> mapM f l + +formatMediaInfo [] _ = Nothing +formatMediaInfo (fmt:fmts) m = + execWriterT (mapM_ f fmt) `mplus` formatMediaInfo fmts m + where f (FeP p) = tell . escapeMarkup =<< (lift $ lookup p m) + f (FeL s) = tell s + f (FeO l) = mapM_ f l `mplus` return () diff --git a/src/Playlist/Format/Parser.hs b/src/Playlist/Format/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/Format/Parser.hs @@ -0,0 +1,52 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 23 Feb. 2010 +-- +-- Copyright (C) 2009-2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playlist.Format.Parser + ( parseFormat + ) where + +import Control.Applicative hiding (many, optional, (<|>)) + +import Text.Parsec +import Text.Parsec.String + +import Playlist.Format.Format (Fe (..)) + + +parseFormat = parse format "" + +format :: Parser [Fe String] +format = do + fes <- many fe + eof + return fes + +fe :: Parser (Fe String) +fe = feP <|> feO <|> feL + +feP :: Parser (Fe String) +feP = FeP <$> between (char '{') (char '}') (many1 (noneOf "{}")) + +feL :: Parser (Fe String) +feL = FeL <$> many1 (esc <|> noneOf "{}[]") + +feO :: Parser (Fe String) +feO = FeO <$> between (char '[') (char ']') (many fe) + +esc = char '\\' >> anyChar diff --git a/src/Playlist/Index.hs b/src/Playlist/Index.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/Index.hs @@ -0,0 +1,119 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 21 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +module Playlist.Index + ( initIndex + , getInfo + , addToIndex + ) where + +import Control.Applicative +import Control.Concurrent.MVar +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap + +import Graphics.UI.Gtk hiding (add) + +import Medialib hiding (getInfo) +import Context +import Handler +import Playlist.Model +import Playlist.Format + + +data IndexEntry + = IENone + | IERetrieving + | IEReady Stamp MediaInfo TrackInfo + +data Index + = Index { iTable :: MVar (IntMap (IndexEntry, [TreeRowReference])) } + +index = iTable context + + +initIndex = do + context <- initContext + let ?context = context + + onMediaInfo . add . ever $ handleInfo + onFormatsChanged . add . ever . const $ handleFormats + + return ?context + + +initContext = do + table <- newMVar IntMap.empty + return $ augmentContext + Index { iTable = table } + +handleInfo (id, stamp, info) = do + let id' = fromIntegral id + modifyMVar_ index $ \ix -> + case IntMap.lookup id' ix of + Just (entry, list) -> updateIndex ix id' stamp info entry list + Nothing -> return ix + +handleFormats = + modifyMVar_ index $ \ix -> + IntMap.fromList <$> mapM update (IntMap.toList ix) + where update (i, (IEReady s m _, l)) = do + t <- makeTrackInfo m + mapM touch l + return (i, (IEReady s m t, l)) + update other = + return other + +updateIndex ix id stamp info old list = + if upd + then do + ti <- makeTrackInfo info + mapM_ touch list + return $ IntMap.insert id (IEReady stamp info ti, list) ix + else + return ix + where upd = case old of + IEReady oldStamp _ _ -> stamp /= oldStamp + _ -> True + +touch ref = do + path <- treeRowReferenceGetPath ref + case path of + [n] -> touchPlaylist n + _ -> return () + +getInfo id force = do + let id' = fromIntegral id + modifyMVar index $ \ix -> + case IntMap.lookup id' ix of + Just (IEReady _ _ info, _) -> + return (ix, Just info) + Just (IENone, list) | force -> do + requestInfo id + return (IntMap.insert id'(IERetrieving, list) ix, Nothing) + _ -> + return (ix, Nothing) + +addToIndex id n = + modifyMVar_ index $ \ix -> do + Just ref <- treeRowReferenceNew playlistStore [n] + return $ IntMap.insertWith iw (fromIntegral id) (IENone, [ref]) ix + where iw (_, [new]) (entry, old) = (entry, new : old) diff --git a/src/Playlist/Model.hs b/src/Playlist/Model.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/Model.hs @@ -0,0 +1,91 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 20 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playlist.Model + ( initModel + , clearModel + , playlistStore + , getPlaylistName + , setPlaylistName + , getPlaylistSize + , touchPlaylist + , onPlaylistUpdated + , playlistGetIds + ) where + +import Control.Concurrent.MVar + +import Data.Int + +import Graphics.UI.Gtk + +import Context +import Utils + + +data State + = State { sName :: Maybe String } + +data Model + = Model { mStore :: ListStore Int32 + , mOnPlaylistUpdated :: HandlerMVar () + , mState :: MVar State + } + +playlistStore = mStore context +onPlaylistUpdated = onHandler (mOnPlaylistUpdated context) +state = mState context + +getPlaylistName = withMVar state (return . sName) +setPlaylistName name = modifyMVar_ state $ \s -> + return s { sName = name } + +getPlaylistSize = listStoreGetSize playlistStore + +touchPlaylist n = do + Just iter <- treeModelGetIter playlistStore [n] + treeModelRowChanged playlistStore [n] iter + +playlistGetIds = + mapM (listStoreGetValue playlistStore) + + +initModel = do + context <- initContext + let ?context = context + + return ?context + +clearModel = + listStoreClear playlistStore + + +initContext = do + store <- listStoreNewDND [] Nothing Nothing + onPlaylistUpdated <- makeHandlerMVar + state <- newMVar makeState + return $ augmentContext + Model { mStore = store + , mOnPlaylistUpdated = onPlaylistUpdated + , mState = state + } + +makeState = + State { sName = Nothing } + diff --git a/src/Playlist/Search.hs b/src/Playlist/Search.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/Search.hs @@ -0,0 +1,41 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 23 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playlist.Search + ( setupSearch + ) where + +import Data.List +import Data.Char + +import Graphics.UI.Gtk + +import Playlist.Model +import Playlist.Index +import Playlist.View +import Playlist.Format + + +setupSearch = do + treeViewSetEnableSearch playlistView True + treeViewSetSearchEqualFunc playlistView $ Just $ \str iter -> do + [n] <- treeModelGetPath playlistStore iter + mid <- listStoreGetValue playlistStore n + info <- getInfo mid True + return $ isInfixOf (map toLower str) (trackInfoText info) diff --git a/src/Playlist/UI.hs b/src/Playlist/UI.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/UI.hs @@ -0,0 +1,366 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 22 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playlist.UI + ( setupUI + ) where + +import Graphics.UI.Gtk hiding (add) + +import XMMS2.Client + +import UI +import XMMS +import Handler +import Playback +import Playtime +import Volume +import Utils +import Clipboard +import Location +import Collection +import Properties hiding (showPropertyEditor, showPropertyExport) +import Playlist.Model +import Playlist.View +import Playlist.Edit +import Playlist.Config +import Playlist.Control + + +setupUI = do + addUIActions uiActions + + srvAG <- actionGroupNew "server" + actionGroupAddActions srvAG srvActions + onServerConnectionAdd . ever $ actionGroupSetSensitive srvAG + insertActionGroup srvAG 1 + + play <- getAction srvAG "play" + pause <- getAction srvAG "pause" + stop <- getAction srvAG "stop" + let setupPPS = do + ps <- getPlaybackStatus + let (ePlay, ePause, eStop) = case ps of + Just StatusPlay -> (False, True, True) + Just StatusPause -> (True, False, True) + _ -> (True, False, False) + actionSetSensitive play ePlay + actionSetVisible play ePlay + actionSetSensitive pause ePause + actionSetVisible pause ePause + actionSetSensitive stop eStop + + prev <- getAction srvAG "prev" + next <- getAction srvAG "next" + let setupPN = do + size <- getPlaylistSize + name <- getPlaylistName + cpos <- getCurrentTrack + let (ep, en) = case (name, cpos) of + (Just n, Just (ct, cn)) -> + (n == cn && ct > 0, n == cn && ct < size - 1) + _ -> + (False, False) + actionSetSensitive prev ep + actionSetSensitive next en + + cut <- getAction srvAG "cut" + copy <- getAction srvAG "copy" + delete <- getAction srvAG "delete" + editp <- getAction srvAG "edit-properties" + expp <- getAction srvAG "export-properties" + let setupSel = do + n <- treeSelectionCountSelectedRows playlistSel + mapM_ (flip actionSetSensitive (n /= 0)) + [cut, copy, delete, editp, expp] + + paste <- getAction srvAG "paste" + append <- getAction srvAG "append" + let setupPA = do + en <- editCheckClipboard + mapM_ (flip actionSetSensitive en) [paste, append] + + onPlaybackStatus . add . ever . const $ setupPPS + onCurrentTrack . add . ever . const $ setupPN + onPlaylistUpdated . add . ever . const $ setupPN + onClipboardTargets . add . ever . const $ setupPA + playlistSel `onSelectionChanged` setupSel + flip timeoutAdd 0 $ do + setupPPS + setupPN + setupSel + setupPA + return False + + addUIFromFile "playlist" + + playlistView `onRowActivated` \[n] _ -> + playTrack n + + scroll <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic + containerAdd scroll playlistView + boxPackStartDefaults contents scroll + + playbar <- getWidget castToToolbar "ui/playbar" + toolbarSetStyle playbar ToolbarIcons + boxPackEnd contents playbar PackNatural 0 + + sep <- separatorToolItemNew + separatorToolItemSetDraw sep False + toolbarInsert playbar sep (-1) + + seekView <- makeSeekControl + seekItem <- toolItemNew + toolItemSetHomogeneous seekItem False + toolItemSetExpand seekItem True + containerAdd seekItem seekView + toolbarInsert playbar seekItem (-1) + + sep <- separatorToolItemNew + separatorToolItemSetDraw sep False + toolbarInsert playbar sep (-1) + + volView <- makeVolumeControl + volumeItem <- toolItemNew + toolItemSetHomogeneous volumeItem False + toolItemSetExpand volumeItem False + widgetSetSizeRequest volumeItem 100 (-1) + containerAdd volumeItem volView + toolbarInsert playbar volumeItem (-1) + + popup <- getWidget castToMenu "ui/playlist-popup" + setupTreeViewPopup playlistView popup + + window `onDestroy` mainQuit + + +uiActions = + [ ActionEntry + { actionEntryName = "music" + , actionEntryLabel = "_Music" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "edit" + , actionEntryLabel = "_Edit" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "browse" + , actionEntryLabel = "_Browse" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "playlist" + , actionEntryLabel = "_Playlist" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "configure-playlist" + , actionEntryLabel = "C_onfigure playlist" + , actionEntryStockId = Just stockPreferences + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = showPlaylistConfigDialog + } + , ActionEntry + { actionEntryName = "properties" + , actionEntryLabel = "P_roperties" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "manage-properties" + , actionEntryLabel = "_Manage properties" + , actionEntryStockId = Just stockPreferences + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = showPropertyManager + } + , ActionEntry + { actionEntryName = "playlist-popup" + , actionEntryLabel = "" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + ] + +srvActions = + [ ActionEntry + { actionEntryName = "play" + , actionEntryLabel = "_Play" + , actionEntryStockId = Just stockMediaPlay + , actionEntryAccelerator = Just "space" + , actionEntryTooltip = Nothing + , actionEntryCallback = startPlayback False + } + , ActionEntry + { actionEntryName = "pause" + , actionEntryLabel = "_Pause" + , actionEntryStockId = Just stockMediaPause + , actionEntryAccelerator = Just "space" + , actionEntryTooltip = Nothing + , actionEntryCallback = pausePlayback + } + , ActionEntry + { actionEntryName = "stop" + , actionEntryLabel = "_Stop" + , actionEntryStockId = Just stockMediaStop + , actionEntryAccelerator = Just "s" + , actionEntryTooltip = Nothing + , actionEntryCallback = stopPlayback + } + , ActionEntry + { actionEntryName = "prev" + , actionEntryLabel = "P_revious track" + , actionEntryStockId = Just stockMediaPrevious + , actionEntryAccelerator = Just "p" + , actionEntryTooltip = Nothing + , actionEntryCallback = prevTrack + } + , ActionEntry + { actionEntryName = "next" + , actionEntryLabel = "_Next track" + , actionEntryStockId = Just stockMediaNext + , actionEntryAccelerator = Just "n" + , actionEntryTooltip = Nothing + , actionEntryCallback = nextTrack + } + , ActionEntry + { actionEntryName = "cut" + , actionEntryLabel = "Cu_t" + , actionEntryStockId = Just stockCut + , actionEntryAccelerator = Just "x" + , actionEntryTooltip = Nothing + , actionEntryCallback = editDelete True + } + , ActionEntry + { actionEntryName = "copy" + , actionEntryLabel = "_Copy" + , actionEntryStockId = Just stockCopy + , actionEntryAccelerator = Just "c" + , actionEntryTooltip = Nothing + , actionEntryCallback = editCopy + } + , ActionEntry + { actionEntryName = "paste" + , actionEntryLabel = "_Paste" + , actionEntryStockId = Just stockPaste + , actionEntryAccelerator = Just "v" + , actionEntryTooltip = Nothing + , actionEntryCallback = editPaste False + } + , ActionEntry + { actionEntryName = "append" + , actionEntryLabel = "_Append" + , actionEntryStockId = Just stockPaste + , actionEntryAccelerator = Just "v" + , actionEntryTooltip = Nothing + , actionEntryCallback = editPaste True + } + , ActionEntry + { actionEntryName = "delete" + , actionEntryLabel = "_Delete" + , actionEntryStockId = Just stockDelete + , actionEntryAccelerator = Just "Delete" + , actionEntryTooltip = Nothing + , actionEntryCallback = editDelete False + } + , ActionEntry + { actionEntryName = "select-all" + , actionEntryLabel = "_Select all" + , actionEntryStockId = Just stockSelectAll + , actionEntryAccelerator = Just "a" + , actionEntryTooltip = Nothing + , actionEntryCallback = editSelectAll + } + , ActionEntry + { actionEntryName = "invert-selection" + , actionEntryLabel = "_Invert selection" + , actionEntryStockId = Just stockSelectAll + , actionEntryAccelerator = Just "a" + , actionEntryTooltip = Nothing + , actionEntryCallback = editInvertSelection + } + , ActionEntry + { actionEntryName = "browse-location" + , actionEntryLabel = "Browse _location" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = browseLocation SortAscending Nothing + } + , ActionEntry + { actionEntryName = "browse-collection" + , actionEntryLabel = "Browse _collection" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = browseCollection Nothing + } + , ActionEntry + { actionEntryName = "clear-playlist" + , actionEntryLabel = "_Clear playlist" + , actionEntryStockId = Just stockClear + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = clearPlaylist + } + , ActionEntry + { actionEntryName = "edit-properties" + , actionEntryLabel = "_Edit properties" + , actionEntryStockId = Just stockEdit + , actionEntryAccelerator = Just "Return" + , actionEntryTooltip = Nothing + , actionEntryCallback = showPropertyEditor + } + , ActionEntry + { actionEntryName = "export-properties" + , actionEntryLabel = "E_xport properties" + , actionEntryStockId = Just stockSave + , actionEntryAccelerator = Just "" + , actionEntryTooltip = Nothing + , actionEntryCallback = showPropertyExport + } + , ActionEntry + { actionEntryName = "import-properties" + , actionEntryLabel = "_Import properties" + , actionEntryStockId = Just stockOpen + , actionEntryAccelerator = Just "" + , actionEntryTooltip = Nothing + , actionEntryCallback = showPropertyImport + } + ] diff --git a/src/Playlist/Update.hs b/src/Playlist/Update.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/Update.hs @@ -0,0 +1,132 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 20 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playlist.Update + ( setupUpdate + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Data.Maybe + +import Graphics.UI.Gtk hiding (add) + +import XMMS2.Client + +import XMMS +import Handler +import Playback +import Playlist.Model +import Playlist.Index +import Playlist.View + + +setupUpdate = do + onServerConnectionAdd . ever $ \conn -> + if conn + then do + playlistCurrentActive xmms >>* do + setupPlaylist + liftIO $ broadcastPlaylistChanged xmms >>* handleChange + return False + broadcastPlaylistLoaded xmms >>* do + setupPlaylist + return True + else do + setPlaylistName Nothing + updateWindowTitle + clearModel + + onPlaybackStatus . add . ever . const $ do + maybeCT <- getCurrentTrack + name <- fromMaybe "" <$> getPlaylistName + size <- getPlaylistSize + case maybeCT of + Just (ct, cname) | cname == name && ct < size -> + touchPlaylist ct + _ -> + return () + + onCurrentTrack . add . ever $ \old -> do + name <- fromMaybe "" <$> getPlaylistName + size <- getPlaylistSize + case old of + Just (ot, oname) | oname == name && ot < size -> + touchPlaylist ot + _ -> + return () + new <- getCurrentTrack + case new of + Just (nt, nname) | nname == name && nt < size -> + touchPlaylist nt + _ -> + return () + +setupPlaylist = do + name <- result + liftIO $ do + setPlaylistName $ Just name + updateWindowTitle + requestPlaylist name + +requestPlaylist name = + playlistListEntries xmms (Just name) >>* handlePlaylist + +handlePlaylist = do + ids <- result + liftIO $ do + clearModel + mapM_ addToPlaylist ids + requestCurrentTrack + onPlaylistUpdated $ invoke () + return False + +addToPlaylist id = do + n <- listStoreAppend playlistStore id + addToIndex id n + +handleChange = do + change <- result + liftIO $ do + name <- fromMaybe "" <$> getPlaylistName + when (name == playlist change) $ + case change of + PlaylistRemove { position = p } -> do + listStoreRemove playlistStore p + onPlaylistUpdated $ invoke () + PlaylistAdd { mlibId = id } -> do + n <- listStoreAppend playlistStore id + addToIndex id n + onPlaylistUpdated $ invoke () + PlaylistInsert { mlibId = id, position = n } -> do + listStoreInsert playlistStore n id + addToIndex id n + onPlaylistUpdated $ invoke () + PlaylistMove { mlibId = id, position = o, newPosition = n } -> do + listStoreRemove playlistStore o + listStoreInsert playlistStore n id + addToIndex id n + onPlaylistUpdated $ invoke () + PlaylistClear {} -> do + clearModel + onPlaylistUpdated $ invoke () + _ -> + requestPlaylist name + return True diff --git a/src/Playlist/View.hs b/src/Playlist/View.hs new file mode 100644 --- /dev/null +++ b/src/Playlist/View.hs @@ -0,0 +1,125 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 20 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playlist.View + ( initView + , playlistView + , playlistSel + , updateWindowTitle + , getSelectedTracks + ) where + +import Control.Applicative + +import Data.Maybe + +import Graphics.UI.Gtk + +import XMMS2.Client + +import Context +import UI +import Playback +import Playlist.Model +import Playlist.Index +import Playlist.Format +--import Playlist.Control + + +data View + = View { vView :: TreeView + , vSel :: TreeSelection } + +playlistView = vView context +playlistSel = vSel context + + +initView = do + context <- initContext + let ?context = context + + treeViewSetRulesHint playlistView True + treeViewSetReorderable playlistView True + treeViewSetHeadersVisible playlistView False + + treeSelectionSetMode playlistSel SelectionMultiple + + column <- treeViewColumnNew + treeViewInsertColumn playlistView column 0 + + cell <- cellRendererPixbufNew + cell `set` [ cellWidth := 30 ] + treeViewColumnPackStart column cell False + cellLayoutSetAttributeFunc column cell playlistStore $ \iter -> do + [n] <- treeModelGetPath playlistStore iter + maybeCT <- getCurrentTrack + name <- fromMaybe "" <$> getPlaylistName + cell `set` [ cellPixbufStockId :=> + case maybeCT of + Just (cp, cname) | cp == n && cname == name -> do + maybeStatus <- getPlaybackStatus + case maybeStatus of + Just StatusPlay -> return stockMediaPlay + Just StatusPause -> return stockMediaPause + Just StatusStop -> return stockMediaStop + _ -> return "" + _ -> + return "" + ] + + cell <- cellRendererTextNew + treeViewColumnPackStart column cell True + cellLayoutSetAttributeFunc column cell playlistStore $ \iter -> do + info <- getInfoIfNeeded iter + cell `set` trackInfoAttrs info + + cell <- cellRendererTextNew + treeViewColumnPackStart column cell False + cellLayoutSetAttributeFunc column cell playlistStore $ \iter -> do + info <- getInfoIfNeeded iter + cell `set` [ cellText := trackInfoDuration info ] + + return ?context + + +getInfoIfNeeded iter = do + [n] <- treeModelGetPath playlistStore iter + mid <- listStoreGetValue playlistStore n + rng <- treeViewGetVisibleRange playlistView + getInfo mid $ case rng of + ([f], [t]) -> n >= f && t >= n + _ -> False + + +updateWindowTitle = do + maybeName <- getPlaylistName + setWindowTitle $ case maybeName of + Nothing -> "Vision playlist" + Just name -> name ++ " - Vision playlist" + +initContext = do + view <- treeViewNewWithModel playlistStore + sel <- treeViewGetSelection view + return $ augmentContext + View { vView = view + , vSel = sel } + + +getSelectedTracks = + map head <$> treeSelectionGetSelectedRows playlistSel diff --git a/src/Playtime.hs b/src/Playtime.hs new file mode 100644 --- /dev/null +++ b/src/Playtime.hs @@ -0,0 +1,196 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 22 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Playtime + ( initPlaytime + , makeSeekControl + ) where + +import Control.Concurrent.MVar +import Control.Applicative +import Control.Monad +import Control.Monad.Trans + +import qualified Data.Map as Map +import Data.IORef +import Data.Word +import Data.Maybe + +import Graphics.UI.Gtk hiding (add, remove) + +import XMMS2.Client + +import XMMS +import Handler +import Medialib +import Context +import Utils +import Playback + + +data State + = State { sCurrentId :: Maybe MediaId } + +data Playtime + = Playtime { pState :: MVar State + , pAdj :: Adjustment + , pCId :: ConnectId Adjustment } + +state = pState context +cId = pCId context +adj = pAdj context + +getCurrentId = withMVar state $ return . sCurrentId +setCurrentId id = modifyMVar_ state $ \s -> return s { sCurrentId = id } + +initPlaytime = do + updateRef <- initUpdate + let ?updateRef = updateRef + + context <- initContext + let ?context = context + + onServerConnectionAdd . ever $ \conn -> + if conn + then do + playbackCurrentId xmms >>* handleCurrentId False + broadcastPlaybackCurrentId xmms >>* handleCurrentId True + playbackPlaytime xmms >>* handlePlaytime 0 False + signalPlaybackPlaytime xmms >>* handlePlaytime 1000 True + else do + resetState + setValue 0 + resetUpdate (+ 1) + + onMediaInfo . add . ever $ handleInfo + onPlaybackStatusAdd . ever $ \status -> + when (fromMaybe StatusStop status == StatusStop) $ + setValue 0 + + return ?context + + +initContext = do + state <- newMVar makeState + adj <- adjustmentNew 0 0 bigNum 5000 5000 0 + cId <- adj `onValueChanged` do + pos <- adjustmentGetValue adj + seek pos + + return $ augmentContext + Playtime { pState = state + , pAdj = adj + , pCId = cId } + +makeState = + State { sCurrentId = Nothing } + +resetState = + modifyMVar_ state $ const $ return makeState + +handleCurrentId ret = do + cid <- result + liftIO $ do + setCurrentId $ + if cid == 0 + then Nothing + else Just cid + requestInfo cid + return ret + +handleInfo (id, _, info) = do + cid <- getCurrentId + when (cid == Just id) $ do + case Map.lookup "duration" info of + Just (PropInt32 d) -> setUpper $ fromIntegral d + _ -> return () + +bigNum = 10000000000.0 + +seek pos = do + putStrLn $ "seek to " ++ show pos + eid <- disableUpdate + playbackSeekMs xmms (round pos) SeekSet >>* do + liftIO $ scheduleEnableUpdate eid + return False + return () + +data Update + = Update { uEnabled :: Bool + , uEnablerId :: Maybe HandlerId + , uStamp :: Word32 } + +initUpdate = + newIORef Update { uEnabled = True + , uEnablerId = Nothing + , uStamp = 0 } + +resetUpdate f = + modifyIORef ?updateRef $ \up -> + up { uEnabled = True + , uEnablerId = Nothing + , uStamp = f $ uStamp up } + +updateEnabled = uEnabled <$> readIORef ?updateRef + +disableUpdate = do + up <- readIORef ?updateRef + maybe (return ()) timeoutRemove $ uEnablerId up + let stamp = uStamp up + 1 + writeIORef ?updateRef Update { uEnabled = False + , uEnablerId = Nothing + , uStamp = stamp } + return stamp + +scheduleEnableUpdate stamp = do + eid <- (flip timeoutAdd) 500 $ do + stamp' <- uStamp <$> readIORef ?updateRef + when (stamp == stamp') $ resetUpdate id + return False + modifyIORef ?updateRef $ \up -> up { uEnablerId = Just eid } + +getValue = adjustmentGetValue adj +setValue = withoutSeek . adjustmentSetValue adj +setUpper = withoutSeek . adjustmentSetUpper adj + +withoutSeek = + bracket_ (signalBlock cId) (signalUnblock cId) + +handlePlaytime diff ret = do + newPt <- catchResult 0 fromIntegral + liftIO $ do + en <- updateEnabled + ps <- getPlaybackStatus + when (en && fromMaybe StatusStop ps /= StatusStop) $ do + oldPt <- getValue + when (abs (newPt - oldPt) >= diff) $ setValue newPt + return ret + +makeSeekControl = do + view <- hScaleNew adj + scaleSetDrawValue view False + rangeSetUpdatePolicy view UpdateContinuous + widgetSetCanFocus view False + + id <- onPlaybackStatusAdd . ever $ + widgetSetSensitive view . (Just StatusPlay ==) + view `onDestroy` do + onPlaybackStatus $ remove id + + return view diff --git a/src/Properties.hs b/src/Properties.hs new file mode 100644 --- /dev/null +++ b/src/Properties.hs @@ -0,0 +1,60 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 22 Sep. 2009 +-- +-- Copyright (C) 2009-2010 Oleg Belozeorov +-- +-- 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. +-- + +module Properties + ( PropertyType (..) + , Property (..) + , readValue + , showValue + , lookup + , initProperties + , property + , showPropertyManager + , showPropertyEditor + , onProperties + , showPropertyExport + , showPropertyImport + , module Properties.View + ) where + +import Prelude hiding (lookup) + +import Properties.Property +import Properties.Model +import Properties.View +import Properties.Manager +import Properties.Editor +import Properties.Impex + + +initProperties = do + context <- initModel + let ?context = context + + context <- initPropertyManager + let ?context = context + + context <- initPropertyEditor + let ?context = context + + context <- initImpex + let ?context = context + + return ?context + diff --git a/src/Properties/Editor.hs b/src/Properties/Editor.hs new file mode 100644 --- /dev/null +++ b/src/Properties/Editor.hs @@ -0,0 +1,41 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 6 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Properties.Editor + ( initPropertyEditor + , showPropertyEditor + ) where + +import Properties.Editor.Model +import Properties.Editor.View +import Properties.Editor.UI + + +initPropertyEditor = do + context <- initEditorModel + let ?context = context + + context <- initEditorView + let ?context = context + + context <- initEditorUI + let ?context = context + + return ?context + diff --git a/src/Properties/Editor/Model.hs b/src/Properties/Editor/Model.hs new file mode 100644 --- /dev/null +++ b/src/Properties/Editor/Model.hs @@ -0,0 +1,264 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 6 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Properties.Editor.Model + ( initEditorModel + , store + , populateModel + , resetModel + , propertyText + , getNavEnables + , prevTrack + , nextTrack + , togglePerTrack + , changeProperty + , writeProperties + ) where + +import Prelude hiding (lookup) + +import Control.Concurrent.MVar +import Control.Monad.State hiding (State, withState) +import Control.Applicative + +import Data.Maybe +import Data.List hiding (lookup) +import Data.Array +import Data.Map (Map) +import qualified Data.Map as Map + +import Graphics.UI.Gtk hiding (add, get, Entry) + +import qualified XMMS2.Client as X + +import XMMS +import Context +import Config +import Utils +import Handler +import Medialib +import Properties.Property +import Properties.Model + + +type Entry = (MediaInfo, MediaInfo) + +data State + = State { sPos :: Int + , sSize :: Int + , sIds :: Array Int X.MediaId + , sEntries :: Map X.MediaId Entry + , sCurrent :: Entry + , sPerTrack :: Bool + } + +makeState list = + let size = length list + ids = array (0, size - 1) $ zip [0 .. ] $ map fst list + entries = Map.fromList $ + map (\(id, info) -> (id, (info, Map.empty))) list + current = fromJust $ Map.lookup (ids ! 0) entries + in State { sPos = 0 + , sSize = size + , sIds = ids + , sEntries = entries + , sCurrent = current + , sPerTrack = True + } + +data Model + = Model { mState :: MVar (Maybe State) + , mStore :: ListStore Property + } + +state = mState context +store = mStore context + +setupState list = + modifyMVar_ state . const . return . Just $ makeState list + +resetState = + modifyMVar_ state . const $ return Nothing + +withState d f = + modifyMVar state $ \state -> + case state of + Just s -> do + (a, s') <- runStateT f s + return (Just s', a) + Nothing -> + return (Nothing, d) + +initEditorModel = do + context <- initContext + let ?context = context + + cid <- store `on` rowDeleted $ const saveConfig + onProperties . add . ever . const $ + withSignalBlocked cid updateProperties + + onServerConnection . add . ever $ \conn -> + unless conn $ do + resetModel + touchAll + + loadConfig + + return ?context + +initContext = do + state <- newMVar Nothing + store <- listStoreNew [] + return $ augmentContext + Model { mState = state + , mStore = store + } + +loadConfig = do + cfg <- mapM property =<< config configFile [] + populateStore cfg + +saveConfig = do + names <- map propName <$> listStoreToList store + writeConfig configFile names + return () + +updateProperties = do + cur <- mapM (property . propName) =<< listStoreToList store + listStoreClear store + populateStore cur + +populateStore cur = do + all <- getProperties + mapM_ (listStoreAppend store) $ + unionBy (eqBy propName) (catMaybes cur) all + +configFile = "property-editor.conf" + +populateModel list = do + setupState list + touchAll + +resetModel = + resetState + +propertyText prop = withState "" $ do + (b, c) <- gets sCurrent + let key = propKey prop + val = Map.lookup key c `mplus` Map.lookup key b + return $ maybe "" (showValue prop) val + +getNavEnables = withState (False, False) $ do + t <- gets sPerTrack + p <- gets sPos + s <- gets sSize + return (t && p > 0, t && p < s - 1) + +prevTrack = stepTrack (-1) +nextTrack = stepTrack 1 + +stepTrack inc = do + withState () $ modify $ \s -> + let e = Map.insert (sIds s ! sPos s) (sCurrent s) (sEntries s) + p = sPos s + inc + c = e Map.! (sIds s ! p) in + s { sEntries = e + , sPos = p + , sCurrent = c + } + touchAll + +touchAll = do + s <- listStoreGetSize store + mapM_ touch [0 .. s - 1] + +touch n = do + Just iter <- treeModelGetIter store [n] + treeModelRowChanged store [n] iter + +togglePerTrack = do + withState () $ modify $ \s -> + if sPerTrack s + then let + e = Map.insert (sIds s ! sPos s) (sCurrent s) (sEntries s) + c = (common $ Map.elems e, Map.empty) + in s { sPerTrack = False + , sEntries = e + , sCurrent = c + } + else let + u = snd $ sCurrent s + e = Map.map (\(b, c) -> (b, Map.union u c)) $ sEntries s + c = e Map.! (sIds s ! sPos s) + in s { sPerTrack = True + , sEntries = e + , sCurrent = c + } + touchAll + +common e = + let (c, i) = foldl g (h, h) t + f a b = if a == b then Just a else Nothing + g (c, i) e = (Map.differenceWith f c e, Map.intersection i e) + (h : t) = map (uncurry $ flip Map.union) e + in Map.intersection c i + +changeProperty n prop text = do + maybeVal <- case trim text of + [] -> return . Just $ X.PropString "" + st -> readValue prop st + case maybeVal of + Nothing -> return False + Just val -> withState False $ do + (b, c) <- gets sCurrent + let key = propKey prop + cur = Map.lookup key c `mplus` Map.lookup key b + res = maybeVal /= cur + when res $ do + modify $ \s -> s { sCurrent = (b, Map.insert key val c) } + liftIO $ touch n + return res + +writeProperties = do + changes <- withState [] extractChanges + mapM_ writeForId changes + where writeForId (id, cs) = + mapM_ (writeProperty id) cs + +writeProperty id (key, val) = + X.medialibEntryPropertySet xmms id + (Just "client/generic/override") + key val + +extractChanges = do + s <- get + let c = sCurrent s + e = case sPerTrack s of + True -> + Map.insert (sIds s ! sPos s) c (sEntries s) + False -> + let u = snd c in + Map.map (\(b, c) -> (b, Map.union u c)) $ sEntries s + e' = Map.map (\(b, c) -> (Map.union c b, Map.empty)) e + put s { sEntries = e' + , sCurrent = (Map.union (snd c) (fst c), Map.empty) + } + return $ map (\(id, (_, c)) -> (id, Map.toList c)) $ Map.toList e + + diff --git a/src/Properties/Editor/UI.hs b/src/Properties/Editor/UI.hs new file mode 100644 --- /dev/null +++ b/src/Properties/Editor/UI.hs @@ -0,0 +1,224 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 6 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Properties.Editor.UI + ( initEditorUI + , showPropertyEditor + ) where + +import Control.Concurrent.MVar +import Control.Monad + +import Data.IORef + +import Graphics.UI.Gtk hiding (add, remove) + +import Context +import Utils +import Handler +import UI +import XMMS +import Medialib +import Properties.Editor.Model +import Properties.Editor.View + + +data UI + = UI { uLock :: MVar () + , uDialog :: Dialog + , uPrevB :: Button + , uNextB :: Button + , uPtrkB :: ToggleButton + , uPBar :: ProgressBar + , uCancel :: IORef (Maybe (IO ())) + } + +tryLock f = + maybe (return False) (const $ f >> return True) + =<< (tryTakeMVar $ uLock context) +unlock = tryPutMVar (uLock context) () >> return () + +dialog = uDialog context + +prevB = uPrevB context +nextB = uNextB context +ptrkB = uPtrkB context +pBar = uPBar context + +setRetrievalCancel = writeIORef (uCancel context) . Just +cancelRetrieval = do + cancel' <- readIORef (uCancel context) + fmaybeM_ cancel' id + writeIORef (uCancel context) Nothing + + +initEditorUI = do + context <- initContext + let ?context = context + + hideOnDeleteEvent dialog + windowSetModal dialog False + windowSetTitle dialog "Edit properties" + windowSetDefaultSize dialog 800 600 + dialogSetHasSeparator dialog False + + dialogAddButton dialog stockApply ResponseApply + dialogAddButton dialog stockCancel ResponseCancel + dialogAddButtonCR dialog stockOk ResponseOk + + box <- vBoxNew False 0 + containerSetBorderWidth box 7 + upper <- dialogGetUpper dialog + boxPackStartDefaults upper box + + hbox <- hBoxNew False 15 + boxPackStart box hbox PackNatural 7 + + bbox <- hButtonBoxNew + buttonBoxSetLayout bbox ButtonboxStart + boxSetSpacing bbox 7 + boxPackStart hbox bbox PackNatural 0 + + boxPackStartDefaults hbox pBar + + prevB `onClicked` (prevTrack >> updateNavButtons) + widgetSetCanFocus prevB False + containerAdd bbox prevB + + nextB `onClicked` (nextTrack >> updateNavButtons) + widgetSetCanFocus nextB False + containerAdd bbox nextB + + ptrkB `onToggled` (togglePerTrack >> updateNavButtons) + widgetSetCanFocus ptrkB False + containerAdd bbox ptrkB + + scroll <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic + scrolledWindowSetShadowType scroll ShadowIn + containerAdd scroll view + boxPackStartDefaults box scroll + + onPropertyEdited $ \[n] t -> do + prop <- listStoreGetValue store n + chok <- changeProperty n prop t + when chok $ do + dialogSetResponseSensitive dialog ResponseApply True + updateTitle True False + + dialog `onResponse` \resp -> + case resp of + ResponseApply -> do + doWriteProperties + dialogSetResponseSensitive dialog ResponseOk True + widgetGrabFocus view + ResponseOk -> do + doWriteProperties + hideEditor + _ -> do + cancelRetrieval + hideEditor + + onServerConnection . add . ever $ \conn -> + unless conn $ do + cancelRetrieval + widgetSetSensitive prevB False + widgetSetSensitive nextB False + widgetSetSensitive ptrkB False + dialogSetResponseSensitive dialog ResponseApply False + dialogSetResponseSensitive dialog ResponseOk False + progressBarSetFraction pBar 0 + progressBarSetText pBar "Disconnected" + updateTitle False False + unlock + + widgetShowAll box + return ?context + +doWriteProperties = do + dialogSetResponseSensitive dialog ResponseApply False + dialogSetResponseSensitive dialog ResponseOk False + writeProperties + updateTitle False False + +hideEditor = do + widgetHide dialog + resetModel + unlock + +updateTitle m r = do + c <- connected + windowSetTitle dialog $ case c of + False -> "Edit properties (disconnected)" + True | m -> "Edit properties (modified)" + _ | r -> "Edit properties (retrieving)" + _ -> "Edit properties" + +showPropertyEditor ids = do + retr <- tryLock $ do + dialogSetResponseSensitive dialog ResponseApply False + dialogSetResponseSensitive dialog ResponseOk False + widgetSetSensitive ptrkB False + updateNavButtons + widgetShow pBar + resetView + setRetrievalCancel =<< do + progressBarSetFraction pBar 0 + progressBarSetText pBar "Retrieving properties" + retrieveProperties ids $ \prog -> + case prog of + Left frac -> + progressBarSetFraction pBar frac + Right list -> do + toggleButtonSetActive ptrkB True + widgetSetSensitive ptrkB True + populateModel list + dialogSetResponseSensitive dialog ResponseApply False + dialogSetResponseSensitive dialog ResponseOk True + updateNavButtons + widgetHide pBar + updateTitle False False + widgetHide dialog + windowSetTransientFor dialog window + updateTitle False retr + windowPresent dialog + +initContext = do + lock <- newMVar () + dialog <- dialogNew + prevB <- buttonNewWithMnemonic "_Previous track" + nextB <- buttonNewWithMnemonic "_Next track" + ptrkB <- toggleButtonNewWithMnemonic "Per _track" + pBar <- progressBarNew + cancel <- newIORef Nothing + return $ augmentContext + UI { uLock = lock + , uDialog = dialog + , uPrevB = prevB + , uNextB = nextB + , uPtrkB = ptrkB + , uPBar = pBar + , uCancel = cancel + } + +updateNavButtons = do + (ep, en) <- getNavEnables + widgetSetSensitive prevB ep + widgetSetSensitive nextB en + diff --git a/src/Properties/Editor/View.hs b/src/Properties/Editor/View.hs new file mode 100644 --- /dev/null +++ b/src/Properties/Editor/View.hs @@ -0,0 +1,88 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 6 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Properties.Editor.View + ( initEditorView + , view + , resetView + , onPropertyEdited + ) where + +import Graphics.UI.Gtk + +import Context +import XMMS +import Properties.Property +import Properties.Editor.Model + + +data View + = View { vView :: TreeView + , vValCol :: TreeViewColumn + , vValCell :: CellRendererText + } + +view = vView context +valCol = vValCol context +valCell = vValCell context + +onPropertyEdited = valCell `on` edited + +resetView = do + treeViewSetCursor view [0] $ Just (valCol, False) + widgetGrabFocus view + + +initEditorView = do + context <- initContext + let ?context = context + + treeViewSetRulesHint view True + treeViewSetHeadersVisible view False + treeViewSetReorderable view True + + column <- treeViewColumnNew + treeViewAppendColumn view column + cell <- cellRendererTextNew + treeViewColumnPackStart column cell True + cellLayoutSetAttributes column cell store $ \prop -> + [ cellText := propName prop + , cellTextWeight := 800 + ] + + treeViewAppendColumn view valCol + treeViewColumnPackStart valCol valCell True + cellLayoutSetAttributes valCol valCell store $ \prop -> + [ cellText :=> propertyText prop + , cellTextEditable :=> do + c <- connected + return $ c && (not $ propReadOnly prop) + ] + + return ?context + +initContext = do + view <- treeViewNewWithModel store + valCol <- treeViewColumnNew + valCell <- cellRendererTextNew + return $ augmentContext + View { vView = view + , vValCol = valCol + , vValCell = valCell + } diff --git a/src/Properties/Impex.hs b/src/Properties/Impex.hs new file mode 100644 --- /dev/null +++ b/src/Properties/Impex.hs @@ -0,0 +1,203 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 12 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# LANGUAGE DoRec, TupleSections #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +module Properties.Impex + ( initImpex + , showPropertyExport + , showPropertyImport + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Control.Concurrent.MVar + +import Data.Char +import qualified Data.Map as Map +import Data.Maybe +import Data.List + +import Codec.Binary.UTF8.String + +import System.FilePath +import System.IO.Error +import System.IO.Unsafe + +import Text.JSON + +import Graphics.UI.Gtk + +import XMMS2.Client hiding (Property) +import qualified XMMS2.Client as X + +import UI +import Context +import Medialib +import Utils +import XMMS + + +data Impex + = Impex { iExportDlg :: Chooser + , iImportDlg :: Chooser + } + + +showPropertyExport = + runChooser (iExportDlg context) . exportProps + +showPropertyImport = + runChooser (iImportDlg context) importProps + + +initImpex = do + context <- initContext + let ?context = context + + return ?context + +initContext = do + exportDlg <- unsafeInterleaveIO makeExportDlg + importDlg <- unsafeInterleaveIO makeImportDlg + return $ augmentContext + Impex { iExportDlg = exportDlg + , iImportDlg = importDlg + } + +makeExportDlg = + makeChooser "Export properties" FileChooserActionSave stockSave + +exportProps ids file = do + pbar <- progressBarNew -- FIXME + retrieveProperties ids $ \prog -> + case prog of + Left _ -> return () + Right list -> do + let base = dropFileName $ decodeString file + text = encodeStrict $ showJSON $ map (exConv base . snd) list + widgetDestroy pbar -- FIXME + writeFile file text `catch` \e -> + putStrLn $ "Export failed" ++ + (decodeString file) ++ ": " ++ ioeGetErrorString e + +exConv base info = ((url', args), Map.difference info readOnlyProps) + where url' = stripBase $ decodeURL path + (path, args) = break (== '?') url + X.PropString url = fromJust $ Map.lookup "url" info + stripBase url + | Just path <- stripPrefix "file://" url + , Just tail <- stripPrefix base path = tail + | otherwise = url + +readOnlyProps = + Map.fromList $ map (, undefined) + [ "added", "bitrate", "chain", "channels", "duration" + , "id", "laststarted", "lmod", "mime", "sample_format" + , "samplerate", "size", "status", "timesplayed", "url" + , "startms", "stopms", "isdir", "intsort" ] + +makeImportDlg = + makeChooser "Import properties" FileChooserActionOpen stockOpen + +importProps name = + importAll `catch` (erep . ioeGetErrorString) + where importAll = do + text <- readFile name + case decodeStrict text of + Ok recs -> mapM_ (importOne base) recs + Error _ -> erep "invalid file format" + base = dropFileName decn + decn = decodeString name + erep = putStrLn . (("Import failed: " ++ decn ++ ": ") ++) + +importOne base ((url, args), props) = + medialibAddEntryEncoded xmms enc >>* do + liftIO $ medialibGetIdEncoded xmms enc >>* do + id <- result + unless (id == 0) $ + liftIO $ setProps id props + return False + return False + where enc = (encodeURL url') ++ args + url' | isInfixOf "://" url = url + | otherwise = "file://" ++ joinPath [base, url] + +setProps id props = mapM_ set $ Map.toList props + where set (k, v) = medialibEntryPropertySet xmms id src k v + src = Just "client/generic/override/vision" + + + +data Chooser + = Chooser { cLock :: MVar () + , cChooser :: FileChooserDialog + } + +makeChooser title action stockId = do + lock <- newMVar () + chooser <- fileChooserDialogNew + (Just title) + Nothing + action + [ (stockCancel, ResponseCancel) + , (stockId, ResponseAccept) ] + hideOnDeleteEvent chooser + + filter <- fileFilterNew + fileFilterSetName filter "Vision property files" + fileFilterAddCustom filter [FileFilterFilename] $ \name _ _ _ -> + return $ maybe False ((==) ".vpf" . map toLower . takeExtension) name + fileChooserAddFilter chooser filter + + filter <- fileFilterNew + fileFilterSetName filter "All files" + fileFilterAddCustom filter [] $ \_ _ _ _ -> return True + fileChooserAddFilter chooser filter + + return Chooser { cLock = lock + , cChooser = chooser + } + +runChooser Chooser { cLock = lock, cChooser = chooser } onAccept = do + locked <- isJust <$> tryTakeMVar lock + when locked $ do + windowSetTransientFor chooser window + rec { cid <- chooser `onResponse` \resp -> do + signalDisconnect cid + case resp of + ResponseAccept -> do + name <- fileChooserGetFilename chooser + fmaybeM_ name onAccept + _ -> + return () + widgetHide chooser + putMVar lock () + } + return () + windowPresent chooser + + +instance JSON X.Property where + showJSON (X.PropInt32 i) = showJSON i + showJSON (X.PropString s) = showJSON s + readJSON (JSRational _ i) = return $ X.PropInt32 $ truncate i + readJSON (JSString s) = return $ X.PropString $ fromJSString s diff --git a/src/Properties/Manager.hs b/src/Properties/Manager.hs new file mode 100644 --- /dev/null +++ b/src/Properties/Manager.hs @@ -0,0 +1,377 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 5 Jul. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# LANGUAGE TupleSections #-} + +module Properties.Manager + ( initPropertyManager + , showPropertyManager + ) where + +import Control.Applicative +import Control.Monad + +import Data.IORef +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Ord +import Data.Char + +import System.IO.Unsafe + +import Graphics.UI.Gtk + +import Utils +import Compound +import Context +import UI +import Editor +import Properties.Property +import Properties.Model + + +data Manager + = Manager { pManager :: EditorDialog PropertyManager } + +manager = pManager context + + +initPropertyManager = do + manager <- unsafeInterleaveIO $ makeEditorDialog + [(stockApply, ResponseApply)] + makePropertyManager $ \m -> do + let outerw = outer m + windowSetTitle outerw "Manage properties" + windowSetDefaultSize outerw 500 400 + return $ augmentContext + Manager { pManager = manager } + +showPropertyManager = + runEditorDialog manager getProperties setProperties False window + + +data PropertyManager + = PropertyManager { pStore :: ListStore Property + , pView :: TreeView + , pBox :: VBox + , pChanged :: IORef Bool + , pNames :: IORef (Set String) + } + +instance CompoundWidget PropertyManager where + type Outer PropertyManager = VBox + outer = pBox + +instance EditorWidget PropertyManager where + type Data PropertyManager = [Property] + getData = propertyManagerGetData + setData = propertyManagerSetData + clearData = propertyManagerClearData + setupView = propertyManagerSetupView + focusView = propertyManagerFocusView + getState = propertyManagerGetState + resetModified = propertyManagerResetModified + +propertyManagerGetData = + listStoreToList . pStore + +propertyManagerSetData pm props = do + let store = pStore pm + listStoreClear store + writeIORef (pNames pm) =<< + foldM (\names prop -> do + listStoreAppend store prop + return $ Set.insert (propName prop) names + ) Set.empty props + +propertyManagerClearData pm = do + listStoreClear $ pStore pm + writeIORef (pNames pm) Set.empty + +propertyManagerSetupView pm = + treeViewSetCursor (pView pm) [0] Nothing + +propertyManagerFocusView = + widgetGrabFocus . pView + +propertyManagerGetState = + liftM (True, ) . readIORef . pChanged + +propertyManagerResetModified = + flip writeIORef False . pChanged + +makePropertyManager parent notify = do + names <- newIORef Set.empty + + store <- listStoreNewDND [] Nothing Nothing + sorted <- treeModelSortNewWithModel store + + let getByIter iter = do + [n] <- treeModelGetPath store iter + listStoreGetValue store n + compBy f a b = + comparing f <$> getByIter a <*> getByIter b + + treeSortableSetDefaultSortFunc sorted $ compBy (map toLower . propName) + treeSortableSetSortFunc sorted 0 $ compBy (map toLower . propName) + treeSortableSetSortFunc sorted 1 $ compBy (map toLower . propKey) + treeSortableSetSortFunc sorted 2 $ compBy (fromEnum . propType) + treeSortableSetSortFunc sorted 3 $ compBy (fromEnum . propReadOnly) + treeSortableSetSortFunc sorted 4 $ compBy (fromEnum . propCustom) + + view <- treeViewNewWithModel sorted + treeViewSetRulesHint view True + + let showType p = + case propType p of + PropertyInt -> "integer" + PropertyString -> "string" + showBool acc p = + if acc p then "yes" else "no" + addColumn title id acc = do + column <- treeViewColumnNew + treeViewColumnSetSortColumnId column id + treeViewAppendColumn view column + treeViewColumnSetTitle column title + cell <- cellRendererTextNew + treeViewColumnPackStart column cell True + cellLayoutSetAttributes column cell store + (\p -> [ cellText := acc p ]) + + addColumn "Name" 0 propName + addColumn "Key" 1 propKey + addColumn "Type" 2 showType + addColumn "Read-only" 3 $ showBool propReadOnly + addColumn "Custom" 4 $ showBool propCustom + + scroll <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic + scrolledWindowSetShadowType scroll ShadowIn + containerAdd scroll view + + changed <- newIORef False + + let setChanged = do + writeIORef changed True + notify + addProperty prop = do + listStoreAppend store prop + modifyIORef names $ Set.insert (propName prop) + setChanged + return () + exists name = Set.member name <$> readIORef names + + edlg <- unsafeInterleaveIO $ makeEditorDialog [] + (makePropertyEntry exists) (const $ return ()) + addB <- buttonNewFromStock stockAdd + addB `onClicked` + runEditorDialog edlg (return nullProperty) addProperty True parent + + delB <- buttonNewFromStock stockRemove + delB `onClicked` do + (path, _) <- treeViewGetCursor view + case path of + [n] -> do + [n'] <- treeModelSortConvertPathToChildPath sorted path + prop <- listStoreGetValue store n' + when (propCustom prop) $ do + listStoreRemove store n' + modifyIORef names $ Set.delete (propName prop) + s <- listStoreGetSize store + unless (s < 1) $ + treeViewSetCursor view [min (s - 1) n] Nothing + setChanged + _ -> + return () + + view `on` cursorChanged $ do + (path, _) <- treeViewGetCursor view + case path of + [_] -> do + [n'] <- treeModelSortConvertPathToChildPath sorted path + prop <- listStoreGetValue store n' + widgetSetSensitive delB $ propCustom prop + _ -> + widgetSetSensitive delB False + + bbox <- hBoxNew True 5 + boxPackStartDefaults bbox addB + boxPackStartDefaults bbox delB + + vbox <- vBoxNew False 5 + containerSetBorderWidth vbox 7 + boxPackStart vbox scroll PackGrow 0 + boxPackStart vbox bbox PackNatural 0 + + return PropertyManager { pStore = store + , pView = view + , pBox = vbox + , pChanged = changed + , pNames = names + } + + +data PropertyEntry + = PropertyEntry + { eTable :: Table + , eName :: Entry + , eKey :: Entry + , eType :: ComboBox + , eRO :: ComboBox + , eExists :: String -> IO Bool + } + +instance CompoundWidget PropertyEntry where + type Outer PropertyEntry = Table + outer = eTable + +instance EditorWidget PropertyEntry where + type Data PropertyEntry = Property + setData = propertyEntrySetData + getData = propertyEntryGetData + focusView = propertyEntryFocusView + getState = propertyEntryGetState + resetModified = const $ return () + +propertyEntrySetData e p = do + entrySetText (eName e) (propName p) + entrySetText (eKey e) (propKey p) + comboSet (eType e) Nothing (propType p) + comboSet (eRO e) Nothing (propReadOnly p) + +propertyEntryGetData e = do + pname <- entryGetText $ eName e + pkey <- entryGetText $ eKey e + ptype <- comboGet $ eType e + pro <- comboGet $ eRO e + return Property { propName = trim pname + , propKey = trim pkey + , propType = ptype + , propReadOnly = pro + , propCustom = True + , propReadValue = Nothing + , propShowValue = Nothing + } + +propertyEntryFocusView = + widgetGrabFocus . eName + +propertyEntryGetState e = do + name <- trim <$> entryGetText (eName e) + key <- trim <$> entryGetText (eKey e) + (, True) <$> propertyEntryValid (eExists e) name key + +propertyEntryValid exists name key = do + e <- exists name + return . not $ e || null name || null key + +makePropertyEntry exists _ notify = do + table <- tableNew 4 2 False + containerSetBorderWidth table 7 + tableSetColSpacings table 15 + tableSetRowSpacings table 5 + + let addPair m w b = do + l <- labelNewWithMnemonic m + miscSetAlignment l 0.0 0.5 + labelSetMnemonicWidget l w + tableAttach table l 0 1 b (b + 1) [Fill] [] 0 0 + tableAttach table w 1 2 b (b + 1) [Expand, Fill] [] 0 0 + + nameE <- entryNew + addPair "_Name" nameE 0 + + keyE <- entryNew + addPair "_Key" keyE 1 + + typeC <- comboBoxNewText + comboBoxInsertText typeC (fromEnum PropertyString) "string" + comboBoxInsertText typeC (fromEnum PropertyInt) "integer" + typeRef <- newIORef PropertyString + typeCid <- setupCombo typeC typeRef + addPair "_Type" typeC 2 + + roC <- comboBoxNewText + comboBoxInsertText roC (fromEnum False) "no" + comboBoxInsertText roC (fromEnum True) "yes" + roRef <- newIORef False + roCid <- setupCombo roC roRef + addPair "_Read-only" roC 3 + + let check = do + notify + key <- trim <$> entryGetText keyE + case Map.lookup key builtinPropertyMap of + Just prop -> do + comboSet typeC (Just typeCid) $ propType prop + widgetSetSensitive typeC False + comboSet roC (Just roCid) $ propReadOnly prop + widgetSetSensitive roC False + Nothing -> do + comboSet typeC (Just typeCid) =<< readIORef typeRef + widgetSetSensitive typeC True + comboSet roC (Just roCid) =<< readIORef roRef + widgetSetSensitive roC True + + checkInsert str pos = do + check + return $ (length str) + pos + + checkDelete _ _ = check + + nameE `afterInsertText` checkInsert + nameE `afterDeleteText` checkDelete + keyE `afterInsertText` checkInsert + keyE `afterDeleteText` checkDelete + + return PropertyEntry { eTable = table + , eName = nameE + , eKey = keyE + , eType = typeC + , eRO = roC + , eExists = exists + } + + +nullProperty = + Property { propName = "" + , propKey = "" + , propType = PropertyString + , propReadOnly = False + , propCustom = True + , propReadValue = Nothing + , propShowValue = Nothing + } + + +comboGet combo = + toEnum <$> comboBoxGetActive combo + +comboSet :: + Enum a => + ComboBox -> + Maybe (ConnectId ComboBox) -> + a -> + IO () +comboSet combo cid = + maybe id withSignalBlocked cid . comboBoxSetActive combo . fromEnum + +setupCombo combo ref = + combo `on` changed $ (writeIORef ref =<< comboGet combo) diff --git a/src/Properties/Model.hs b/src/Properties/Model.hs new file mode 100644 --- /dev/null +++ b/src/Properties/Model.hs @@ -0,0 +1,100 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 4 Mar. 2009 +-- +-- Copyright (C) 2009-2010 Oleg Belozeorov +-- +-- 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. +-- + +module Properties.Model + ( lookup + , initModel + , property + , propertyMap + , propertyStore + , getProperties + , setProperties + , onProperties + ) where + +import Prelude hiding (lookup) + +import Control.Concurrent.MVar + +import Data.Map (Map) +import qualified Data.Map as Map + +import Graphics.UI.Gtk + +import Context +import Config +import Handler +import Utils +import Properties.Property + + +data Model + = Model { mMap :: MVar (Map String Property) + , mStore :: ListStore Property + , mOnProperties :: HandlerMVar () + } + +propertyMap = mMap context +propertyStore = mStore context +onProperties = onHandler $ mOnProperties context + + +initModel = do + context <- initContext + let ?context = context + + loadProperties + + return ?context + +initContext = do + npmap <- newMVar $ mkMap builtinProperties + -- The store will be populated in loadProperties. + store <- listStoreNewDND [] Nothing Nothing + onprops <- makeHandlerMVar + return $ augmentContext + Model { mMap = npmap + , mStore = store + , mOnProperties = onprops + } + +property name = + withMVar propertyMap $ return . Map.lookup name + +loadProperties = do + props <- config "properties.conf" [] + mapM_ (listStoreAppend propertyStore) =<< + (modifyMVar propertyMap $ \m -> do + let m' = Map.union m $ mkMap props + return (m', Map.elems m')) + +getProperties = + withMVar propertyMap $ return . Map.elems + +setProperties props = do + listStoreClear propertyStore + mapM_ (listStoreAppend propertyStore) =<< + (modifyMVar propertyMap $ const $ do + let m = mkMap props + return (m, Map.elems m)) + writeConfig "properties.conf" props + onProperties $ invoke () + + +mkMap = Map.fromList . map (\p -> (propName p, p)) diff --git a/src/Properties/Property.hs b/src/Properties/Property.hs new file mode 100644 --- /dev/null +++ b/src/Properties/Property.hs @@ -0,0 +1,175 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 2 Mar. 2010 +-- +-- Copyright (C) 2009-2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +module Properties.Property + ( PropertyType (..) + , Property (..) + , readValue + , showValue + , lookup + , builtinProperties + , builtinPropertyMap + ) where + +import Prelude hiding (lookup) + +import Control.Applicative +import Control.Monad + +import qualified Data.Map as Map + +import Text.Printf +import Text.JSON + +import qualified XMMS2.Client.Types as X + +import Utils + + +data PropertyType + = PropertyString + | PropertyInt + deriving (Read, Show, Enum) + +instance JSON PropertyType where + showJSON PropertyInt = showJSON "int" + showJSON PropertyString = showJSON "string" + readJSON (JSString s) = + case fromJSString s of + "int" -> return PropertyInt + "string" -> return PropertyString + _ -> fail "Unable to read PropertyType" + readJSON _ = fail "Unable to read PropertyType" + + +type PropertyShow = X.Property -> String +type PropertyRead = String -> IO X.Property + +data Property + = Property { propName :: String + , propKey :: String + , propType :: PropertyType + , propCustom :: Bool + , propReadOnly :: Bool + , propReadValue :: Maybe PropertyRead + , propShowValue :: Maybe PropertyShow } + +instance Read Property where + readsPrec x s = map (mapFst mk) (readsPrec x s) + +instance Show Property where + show p = show (propName p, propKey p, propType p, propReadOnly p) + +instance JSON Property where + showJSON p = showJSON (propName p, propKey p, propType p, propReadOnly p) + readJSON v = mk <$> readJSON v `mplus` fail "Unable to read Property" + +mk (pn, pk, pt, pr) = + case Map.lookup pk builtinPropertyMap of + Just prop -> + prop { propName = pn + , propCustom = True } + _ -> + Property { propName = pn + , propKey = pk + , propType = pt + , propCustom = True + , propReadOnly = pr + , propReadValue = Nothing + , propShowValue = Nothing } + + + + +readValue p s = liftM Just read `catch` \_ -> return Nothing + where read = maybe rdef id (propReadValue p) $ s + rdef s = case (propType p) of + PropertyInt -> X.PropInt32 <$> readIO s + PropertyString -> return $ X.PropString s + +showValue p v = maybe sdef id (propShowValue p) $ v + where sdef (X.PropInt32 n) = show n + sdef (X.PropString s) = s + + +lookup p m = do + res <- (showValue p) <$> Map.lookup (propKey p) m + when (null res) mzero + return res + + +builtinPropertyMap = + Map.fromList $ map (\p -> (propKey p, p)) builtinProperties + +builtinProperties = + map (\(pn, pk, pt, ro, pr, ps) -> + Property { propName = pn + , propKey = pk + , propType = pt + , propCustom = False + , propReadOnly = ro + , propReadValue = pr + , propShowValue = ps }) + [ ("Artist", "artist", + PropertyString, False, Nothing, Nothing) + , ("Album", "album", + PropertyString, False, Nothing, Nothing) + , ("Date", "date", + PropertyString, False, Nothing, Nothing) + , ("Track", "tracknr", + PropertyInt, False, Nothing, Nothing) + , ("Title", "title", + PropertyString, False, Nothing, Nothing) + , ("Comment", "comment", + PropertyString, False, Nothing, Nothing) + , ("Duration", "duration", + PropertyInt, True, Nothing, Just showDuration) + , ("URL", "url", + PropertyString, True, Nothing, Just showURL) + , ("Composer", "composer", + PropertyString, False, Nothing, Nothing) + , ("Work", "work", + PropertyString, False, Nothing, Nothing) + , ("Catalog", "catalog", + PropertyString, False, Nothing, Nothing) + , ("Movement", "movement", + PropertyString, False, Nothing, Nothing) + , ("Performer", "performer", + PropertyString, False, Nothing, Nothing) + , ("Conductor", "conductor", + PropertyString, False, Nothing, Nothing) + , ("Orchestra", "orchestra", + PropertyString, False, Nothing, Nothing) + , ("Chorus master", "chorus_master", + PropertyString, False, Nothing, Nothing) + , ("Chorus", "chorus", + PropertyString, False, Nothing, Nothing) ] + + +showDuration (X.PropInt32 n) = + if h == 0 then mss else (show h) ++ (':' : mss) + where d = n `div` 1000 + h = d `div` 3600 + m = (d - (h * 3600)) `div` 60 + s = d - h * 3600 - m * 60 + mss = printf "%02d:%02d" m s + +showURL (X.PropString u) = decodeURL u diff --git a/src/Properties/View.hs b/src/Properties/View.hs new file mode 100644 --- /dev/null +++ b/src/Properties/View.hs @@ -0,0 +1,175 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 22 Mar. 2010 +-- +-- Copyright (C) 2009-2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# LANGUAGE TupleSections #-} + +module Properties.View + ( PropertyView + , makePropertyView + , propertyViewStore + , propertyViewRight + ) where + +import Control.Monad +import Control.Monad.Trans + +import Data.IORef + +import Graphics.UI.Gtk + +import Atoms +import DnD +import Compound +import Editor +import Properties.Property +import Properties.Model + + +data PropertyView a + = PropertyView + { vPaned :: HPaned + , vLeft :: TreeView + , propertyViewStore :: ListStore (Property, a) + , propertyViewRight :: TreeView + , vModified :: IORef Bool + } + +instance CompoundWidget (PropertyView a) where + type Outer (PropertyView a) = HPaned + outer = vPaned + +instance EditorWidget (PropertyView a) where + type Data (PropertyView a) = [(Property, a)] + getData = propertyViewGetData + setData = propertyViewSetData + clearData = propertyViewClearData + setupView = propertyViewSetupView + focusView = propertyViewFocusView + getState = propertyViewGetState + resetModified = propertyViewResetModified + +propertyViewGetData = + listStoreToList . propertyViewStore + +propertyViewSetData v d = do + listStoreClear $ propertyViewStore v + mapM_ (listStoreAppend $ propertyViewStore v) d + +propertyViewClearData = + listStoreClear . propertyViewStore + +propertyViewSetupView pm = + treeViewSetCursor (vLeft pm) [0] Nothing + +propertyViewFocusView = + widgetGrabFocus . vLeft + +propertyViewGetState = + liftM (True, ) . readIORef . vModified + +propertyViewResetModified = + flip writeIORef False . vModified + +makePropertyView make _ notify = do + modified <- newIORef False + let onChanged = do + writeIORef modified True + notify + + paned <- hPanedNew + containerSetBorderWidth paned 7 + + scroll <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic + scrolledWindowSetShadowType scroll ShadowIn + panedPack1 paned scroll True False + + left <- treeViewNewWithModel propertyStore + treeViewSetHeadersVisible left False + + sel <- treeViewGetSelection left + treeSelectionSetMode sel SelectionMultiple + + column <- treeViewColumnNew + treeViewAppendColumn left column + cell <- cellRendererTextNew + treeViewColumnPackStart column cell True + cellLayoutSetAttributes column cell propertyStore $ \prop -> + [ cellText := propName prop ] + + containerAdd scroll left + + scroll <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic + scrolledWindowSetShadowType scroll ShadowIn + panedPack2 paned scroll True False + + store <- listStoreNew [] + store `on` rowChanged $ const $ const onChanged + store `on` rowInserted $ const $ const onChanged + store `on` rowDeleted $ const onChanged + + right <- treeViewNewWithModel store + treeViewSetHeadersVisible right False + treeViewSetReorderable right True + + sel <- treeViewGetSelection right + treeSelectionSetMode sel SelectionMultiple + + column <- treeViewColumnNew + treeViewAppendColumn right column + cell <- cellRendererTextNew + treeViewColumnPackStart column cell True + cellLayoutSetAttributes column cell store $ \(prop, _) -> + [ cellText := propName prop ] + + containerAdd scroll right + + left `on` keyPressEvent $ tryEvent $ do + [] <- eventModifier + "Return" <- eventKeyName + liftIO $ do + sel <- treeViewGetSelection left + rows <- treeSelectionGetSelectedRows sel + forM_ rows $ \[n] -> + listStoreAppend store . make =<< + listStoreGetValue propertyStore n + + right `on` keyPressEvent $ tryEvent $ do + [] <- eventModifier + "Delete" <- eventKeyName + liftIO $ do + sel <- treeViewGetSelection right + rows <- treeSelectionGetSelectedRows sel + mapM_ (listStoreRemove store . head) $ reverse rows + + setupDnDReorder propPosList store right $ + mapM_ $ \(f, t) -> do + v <- listStoreGetValue store f + listStoreRemove store f + listStoreInsert store t v + + return PropertyView { vPaned = paned + , vLeft = left + , propertyViewStore = store + , propertyViewRight = right + , vModified = modified + } + + diff --git a/src/UI.hs b/src/UI.hs new file mode 100644 --- /dev/null +++ b/src/UI.hs @@ -0,0 +1,149 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 20 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +{-# LANGUAGE RankNTypes #-} + +module UI + ( initUI + , window + , contents + , setWindowTitle + , getWidget + , addUIFromFile + , insertActionGroup + , addUIActions + , getAction + , windowGroup + ) where + +import Control.Applicative + +import Data.Maybe + +import Graphics.UI.Gtk + +import Context +import Environment +import About + + +data UI + = UI { uWindow :: Window + , uContents :: VBox + , uManager :: UIManager + , uActionGroup :: ActionGroup + , uWindowGroup :: WindowGroup + } + +window = uWindow context +contents = uContents context +uiManager = uManager context +uiActionGroup = uActionGroup context +windowGroup = uWindowGroup context + +initUI = do + context <- initContext + let ?context = context + + windowGroupAddWindow windowGroup window + containerAdd window contents + + windowAddAccelGroup window =<< uiManagerGetAccelGroup uiManager + insertActionGroup uiActionGroup 1 + addUIActions uiActions + addUIFromFile "common" + + menubar <- getWidget castToMenuBar "ui/menubar" + boxPackStart contents menubar PackNatural 0 + + return ?context + + +initContext = do + window <- windowNew + contents <- vBoxNew False 0 + uiManager <- uiManagerNew + uiActionGroup <- actionGroupNew "ui" + windowGroup <- windowGroupNew + return $ augmentContext + UI { uWindow = window + , uContents = contents + , uManager = uiManager + , uActionGroup = uiActionGroup + , uWindowGroup = windowGroup + } + +setWindowTitle = windowSetTitle window +addUIActions = actionGroupAddActions uiActionGroup +insertActionGroup = uiManagerInsertActionGroup uiManager +addUIFromFile = uiManagerAddUiFromFile uiManager . uiFilePath +maybeGetWidget cast name = fmap cast <$> uiManagerGetWidget uiManager name +getWidget cast name = fromJust <$> maybeGetWidget cast name +getAction group name = fromJust <$> actionGroupGetAction group name + +uiActions = + [ ActionEntry + { actionEntryName = "menubar" + , actionEntryLabel = "" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "toolbar" + , actionEntryLabel = "" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "quit" + , actionEntryLabel = "_Quit" + , actionEntryStockId = Just stockQuit + , actionEntryAccelerator = Just "q" + , actionEntryTooltip = Nothing + , actionEntryCallback = mainQuit + } + , ActionEntry + { actionEntryName = "close-window" + , actionEntryLabel = "_Close window" + , actionEntryStockId = Just stockClose + , actionEntryAccelerator = Just "w" + , actionEntryTooltip = Nothing + , actionEntryCallback = widgetDestroy window + } + , ActionEntry + { actionEntryName = "help" + , actionEntryLabel = "_Help" + , actionEntryStockId = Nothing + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = return () + } + , ActionEntry + { actionEntryName = "about" + , actionEntryLabel = "_About" + , actionEntryStockId = Just stockAbout + , actionEntryAccelerator = Nothing + , actionEntryTooltip = Nothing + , actionEntryCallback = showAbout window + } + ] diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,177 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 17 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Utils + ( HandlerMVar + , makeHandlerMVar + , onHandler + , mapFst + , mapSnd + , encodeURL + , decodeURL + , trd + , trim + , bracket_ + , catchResult + , setupTreeViewPopup + , dialogAddButtonCR + , fmaybeM_ + , withSignalBlocked + , hideOnDeleteEvent + , eqBy + , tryModifyMVar_ + ) where + +import Prelude hiding (catch) +import Control.Monad.CatchIO hiding (Handler) + +import Control.Monad +import Control.Monad.Trans +import Control.Applicative +import Control.Concurrent.MVar +import Data.Char hiding (Control) +import Codec.Binary.UTF8.String + +import Graphics.UI.Gtk + +import XMMS2.Client + +import Handler + + +type HandlerMVar a = MVar (Handler IO a) + +makeHandlerMVar = newMVar make + +onHandler = modifyMVar + +mapFst f (a, b) = (f a, b) +mapSnd f (a, b) = (a, f b) + +encodeURL = encodeURL' . encodeString +encodeURL' [] = [] +encodeURL' (' ':cs) = '+' : encodeURL' cs +encodeURL' (c:cs) + | goodChar c = + c : encodeURL' cs + | otherwise = + let code = ord c + c1 = intToDigit $ code `div` 16 + c2 = intToDigit $ code `rem` 16 in + '%' : c1 : c2 : encodeURL' cs + +goodChar ':' = True +goodChar '/' = True +goodChar '-' = True +goodChar '.' = True +goodChar '_' = True +goodChar c = isAsciiUpper c || isAsciiLower c || isDigit c + +decodeURL = decodeString . decodeURL' +decodeURL' [] = [] +decodeURL' ('+' : cs) = ' ' : decodeURL' cs +decodeURL' ('%' : cs) = let (c, cs') = decodeByte cs in c : decodeURL' cs' +decodeURL' (c : cs) = c : decodeURL' cs + +decodeByte (d1 : d0 : cs) + | isHexDigit d1 && isHexDigit d0 = (chr $ (digitToInt d1) * 16 + (digitToInt d0), cs) +decodeByte _ = error "invalid URL" + +trd (_, _, c) = c + +trim = f . f where f = reverse . dropWhile isSpace + +bracket_ f g = bracket f (const g) . const + +catchResult def conv = + (conv <$> result) `catch` \(_ :: XMMSException) -> return def + +setupTreeViewPopup view popup = do + view `on` popupMenuSignal $ (menuPopup popup Nothing >> return True) + + sel <- treeViewGetSelection view + selMode <- treeSelectionGetMode sel + let cond = + case selMode of + SelectionMultiple -> + (2 >) <$> (liftIO $ treeSelectionCountSelectedRows sel) + SelectionNone -> + return False + _ -> + return True + setCursor = do + doIt <- cond + when doIt $ do + (x, y) <- eventCoordinates + maybePath <- liftIO $ treeViewGetPathAtPos view (round x, round y) + case maybePath of + Just (path, _, _) -> + liftIO $ treeViewSetCursor view path Nothing + Nothing -> + return () + + view `on` buttonPressEvent $ tryEvent $ do + RightButton <- eventButton + SingleClick <- eventClick + stamp <- eventTime + setCursor + liftIO $ menuPopup popup $ Just (RightButton, stamp) + +dialogAddButtonCR dialog label response = do + button <- dialogAddButton dialog label response + dialog `on` keyPressEvent $ tryEvent $ do + "Return" <- eventKeyName + [Control] <- eventModifier + liftIO $ do + doIt <- button `get` widgetSensitive + when doIt $ do + widgetActivate button + return () + +fmaybe :: b -> Maybe a -> (a -> b) -> b +fmaybe = flip . maybe + +fmaybeM_ :: Monad m => Maybe a -> (a -> m b) -> m () +fmaybeM_ m f = fmaybe (return ()) m $ \a -> f a >> return () + +withSignalBlocked s f = + block $ do + signalBlock s + r <- unblock f `onException` signalUnblock s + signalUnblock s + return r + +hideOnDeleteEvent window = + window `on` deleteEvent $ do + liftIO $ widgetHide window + return True + +eqBy f a b = f a == f b + +{-# INLINE tryModifyMVar_ #-} +tryModifyMVar_ :: MVar a -> (a -> IO a) -> IO () +tryModifyMVar_ m io = + block $ do + maybeA <- tryTakeMVar m + case maybeA of + Just a -> do + a' <- unblock (io a) `onException` putMVar m a + putMVar m a' + Nothing -> + return () diff --git a/src/Vision.hs b/src/Vision.hs new file mode 100644 --- /dev/null +++ b/src/Vision.hs @@ -0,0 +1,80 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 11 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Main + where + +import Graphics.UI.Gtk + +import Environment +import About +import Properties +import XMMS +import Medialib +import Playback +import Volume +import Playtime +import Clipboard +import Location +import Collection +import Playlist + + +main = do + initGUI + + context <- initEnvironment + let ?context = context + + context <- initAbout + let ?context = context + + context <- initXMMS + let ?context = context + + context <- initMedialib + let ?context = context + + context <- initProperties + let ?context = context + + context <- initPlayback + let ?context = context + + context <- initVolume + let ?context = context + + context <- initPlaytime + let ?context = context + + context <- initClipboard + let ?context = context + + context <- initLocation + let ?context = context + + context <- initCollection + let ?context = context + + context <- initPlaylist + let ?context = context + + showPlaylist + + mainGUI diff --git a/src/Volume.hs b/src/Volume.hs new file mode 100644 --- /dev/null +++ b/src/Volume.hs @@ -0,0 +1,99 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 22 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module Volume + ( initVolume + , makeVolumeControl + ) where + +import Control.Monad.Trans + +import qualified Data.Map as Map + +import Graphics.UI.Gtk hiding (add, remove) + +import XMMS2.Client + +import XMMS +import Handler +import Utils +import Context + + +data Volume + = Volume { vAdj :: Adjustment + , vCid :: ConnectId Adjustment } + +adj = vAdj context +cId = vCid context + +initVolume = do + context <- initContext + let ?context = context + + onServerConnectionAdd . ever $ \conn -> + if conn + then do + playbackVolumeGet xmms >>* do + handleVolume + lift $ broadcastPlaybackVolumeChanged xmms >>* handleVolume + return False + signalUnblock cId + else do + signalBlock cId + withoutVolumeChange $ adjustmentSetValue (adj) 0 + + return ?context + + +initContext = do + adj <- adjustmentNew 0 0 100 5 5 0 + cId <- adj `onValueChanged` do + vol <- adjustmentGetValue adj + setVolume $ round vol + return $ augmentContext + Volume { vAdj = adj, vCid = cId } + + +makeVolumeControl = do + view <- hScaleNew $ adj + scaleSetDrawValue view False + rangeSetUpdatePolicy view UpdateContinuous + widgetSetCanFocus view False + + id <- onServerConnectionAdd . ever $ widgetSetSensitive view + view `onDestroy` do onServerConnection $ remove id + + return view + + +handleVolume = do + vol <- catchResult 0 (maximum . Map.elems) + liftIO $ withoutVolumeChange $ + adjustmentSetValue (adj) $ fromIntegral vol + return True + +setVolume vol = + playbackVolumeGet xmms >>* do + vols <- catchResult Map.empty id + lift $ mapM_ ((flip (playbackVolumeSet xmms)) vol) $ Map.keys vols + return False + +withoutVolumeChange = + bracket_ (signalBlock $ cId) (signalUnblock $ cId) diff --git a/src/XMMS.hs b/src/XMMS.hs new file mode 100644 --- /dev/null +++ b/src/XMMS.hs @@ -0,0 +1,107 @@ +-- -*-haskell-*- +-- Vision (for the Voice): an XMMS2 client. +-- +-- Author: Oleg Belozeorov +-- Created: 18 Jun. 2010 +-- +-- Copyright (C) 2010 Oleg Belozeorov +-- +-- 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. +-- + +module XMMS + ( xmms + , initXMMS + , connected + , onServerConnection + , onServerConnectionAdd + ) where + +import Prelude hiding (init) +import Control.Concurrent.MVar + +import Graphics.UI.Gtk hiding (add) + +import XMMS2.Client +import XMMS2.Client.Glib + +import Environment +import Handler +import Utils +import Context + + +data State + = State { sConnected :: Bool } + +makeState = State { sConnected = False } + + +data XMMS + = XMMS { xXMMS :: Connection + , xOnServerConnection :: HandlerMVar Bool + , xState :: MVar State + } + +xmms = xXMMS context +onServerConnection = onHandler (xOnServerConnection context) +state = xState context + +connected = withMVar state $ return . sConnected + +initXMMS = do + context <- initContext + let ?context = context + + scheduleTryConnect 100 + + return ?context + + +initContext = do + xmms <- init "Vision" + onServerConnection <- makeHandlerMVar + state <- newMVar makeState + return $ augmentContext + XMMS { xXMMS = xmms + , xOnServerConnection = onServerConnection + , xState = state + } + +scheduleTryConnect = timeoutAdd tryConnect + +tryConnect = do + putStr "connecting... " + success <- connect xmms xmmsPath + if success + then do + putStrLn "connected!" + disconnectCallbackSet xmms disconnectCallback + mainLoopGMainInit xmms + modifyMVar_ state $ \s -> return s { sConnected = True } + onServerConnection $ invoke True + return False + else do + putStrLn "failed." + scheduleTryConnect 1000 + return False + +disconnectCallback = do + putStrLn "disconnected." + modifyMVar_ state $ \s -> return s { sConnected = False } + onServerConnection $ invoke False + scheduleTryConnect 1000 + return () + +onServerConnectionAdd f = do + id <- onServerConnection . add $ f + f =<< connected + return id diff --git a/ui/collection-browser.xml b/ui/collection-browser.xml new file mode 100644 --- /dev/null +++ b/ui/collection-browser.xml @@ -0,0 +1,59 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/ui/common.xml b/ui/common.xml new file mode 100644 --- /dev/null +++ b/ui/common.xml @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/ui/location-browser.xml b/ui/location-browser.xml new file mode 100644 --- /dev/null +++ b/ui/location-browser.xml @@ -0,0 +1,39 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/ui/playlist.xml b/ui/playlist.xml new file mode 100644 --- /dev/null +++ b/ui/playlist.xml @@ -0,0 +1,60 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/vision.cabal b/vision.cabal new file mode 100644 --- /dev/null +++ b/vision.cabal @@ -0,0 +1,103 @@ +name: vision +version: 0.0.2.2 + +author: Oleg Belozeorov +maintainer: Oleg Belozeorov +copyright: (C) 2010 Oleg Belozeorov +license: GPL-3 +license-file: COPYING + +category: Sound +synopsis: An XMMS2 client. +description: + Vision (for the Voice) is an X-platform Music Multiplexing System 2 + (http://xmms2.xmms.se) client aiming to eventually fit its author's + views on listening to music, managing a music library etc. Only the + time can tell what will come of that :] + +cabal-version: >= 1.6 +build-type: Simple +extra-tmp-files: config.status, config.log, autom4te.cache +data-files: ui/*.xml + +executable vision + main-is: Vision.hs + other-modules: Handler, + Utils, + Context, + XMMS, + Environment, + Medialib, + UI, + Atoms, + DnD, + Config, + Compound, + Editor, + Properties, + Properties.Property, + Properties.Model, + Properties.View, + Properties.Manager, + Properties.Editor, + Properties.Editor.Model, + Properties.Editor.View, + Properties.Editor.UI, + Properties.Impex, + Playback, + Volume, + Playtime, + Clipboard, + Index, + Location, + Location.History, + Location.Model, + Location.View, + Location.Control, + Location.UI, + Collection, + Collection.List, + Collection.List.Model, + Collection.List.View, + Collection.Common, + Collection.Model, + Collection.View, + Collection.Control, + Collection.Order, + Collection.UI, + Playlist, + Playlist.Model, + Playlist.View, + Playlist.UI, + Playlist.Update, + Playlist.DnD, + Playlist.Index, + Playlist.Search, + Playlist.Edit, + Playlist.Config, + Playlist.Control, + Playlist.Format, + Playlist.Format.Format, + Playlist.Format.Parser, + Playlist.Format.Config + hs-source-dirs: src + build-depends: base >= 4 && < 5, xmms2-client >= 0.0.3.6, + xmms2-client-glib >= 0.0.3.6, + gtk, containers, mtl, utf8-string, + filepath, directory, glib, array, + MonadCatchIO-mtl, json, parsec >= 3.0.1 + extensions: ImplicitParams, NoMonomorphismRestriction, + FlexibleContexts, FlexibleInstances, + TypeFamilies, ScopedTypeVariables, + PatternGuards + ghc-options: -W + + +source-repository head + type: git + location: git://github.com/upwawet/vision.git + +source-repository head + type: git + location: git://github.com/upwawet/vision.git + tag: v0.0.2.2