diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -0,0 +1,573 @@ +---------------------------------------------------------------------- + PREAMBLE + +The wxHaskell libraries are distributed under the wxWindows library +license. The documentation is subject to the wxWidgets documentation +license. + +See "http://www.wxwidgets.org/newlicen.htm" for the legal description +of the license, which is also included in this document. + +The wxWindows library licence is essentially the L-GPL (Library General +Public Licence), with an exception stating that derived works in binary +form may be distributed on the user's own terms. This means that it is +possible to create commercial software with this library without paying +royalties or disclosing source code. This is a solution that satisfies +those who wish to produce GPL'ed software using wxHaskell, and also +those producing proprietary software. + +This library 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 wxWidgets +library license for more details. + + +---------------------------------------------------------------------- + WXWINDOWS LIBRARY LICENCE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + This library is free software; you can redistribute it and/or modify it + under the terms of the GNU Library General Public Licence as published by + the Free Software Foundation; either version 2 of the Licence, or (at + your option) any later version. + + This library 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 Library + General Public Licence for more details. + + You should have received a copy of the GNU Library General Public Licence + along with this software, usually in a file named COPYING.LIB. If not, + write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + Boston, MA 02111-1307 USA. + + EXCEPTION NOTICE + + 1. As a special exception, the copyright holders of this library give + permission for additional uses of the text contained in this release of + the library as licenced under the wxWindows Library Licence, applying + either version 3 of the Licence, or (at your option) any later version of + the Licence as published by the copyright holders of version 3 of the + Licence document. + + 2. The exception is that you may use, copy, link, modify and distribute + under the user's own terms, binary object code versions of works based + on the Library. + + 3. If you copy code from files distributed under the terms of the GNU + General Public Licence or the GNU Library General Public Licence into a + copy of this library, as this licence permits, the exception does not + apply to the code that you add in this way. To avoid misleading anyone as + to the status of such modified files, you must delete this exception + notice from such code and/or adjust the licensing conditions notice + accordingly. + + 4. If you write modifications of your own for this library, it is your + choice whether to permit this exception to apply to your modifications. + If you do not wish that, you must delete the exception notice from such + code and/or adjust the licensing conditions notice accordingly. + + +---------------------------------------------------------------------- + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +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 this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +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 +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser 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 Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "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 +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY 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 +LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey 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 library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/src/Graphics/UI/WX.hs b/src/Graphics/UI/WX.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX.hs @@ -0,0 +1,60 @@ +-------------------------------------------------------------------------------- +{-| Module : WX + Copyright : (c) Daan Leijen 2003 + License : wxWindows + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + The WX module just re-exports functionality from helper modules and + defines the 'start' function. + + The WX library provides a /haskellized/ interface to the raw wxWindows + functionality provided by the "Graphics.UI.WXCore" library. +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX + ( -- * Functions + start + -- * Modules + , module Graphics.UI.WX.Types + , module Graphics.UI.WX.Attributes + , module Graphics.UI.WX.Classes + , module Graphics.UI.WX.Variable + , module Graphics.UI.WX.Layout + , module Graphics.UI.WX.Events + + , module Graphics.UI.WX.Window + , module Graphics.UI.WX.Frame + , module Graphics.UI.WX.Timer + , module Graphics.UI.WX.Media + , module Graphics.UI.WX.Menu + , module Graphics.UI.WX.Controls + , module Graphics.UI.WX.Dialogs + , module Graphics.UI.WX.Draw + ) where + +import Graphics.UI.WX.Types +import Graphics.UI.WX.Attributes +import Graphics.UI.WX.Classes +import Graphics.UI.WX.Variable +import Graphics.UI.WX.Layout +import Graphics.UI.WX.Events + +import Graphics.UI.WX.Window +import Graphics.UI.WX.Frame +import Graphics.UI.WX.Timer +import Graphics.UI.WX.Media +import Graphics.UI.WX.Menu + +import Graphics.UI.WX.Controls +import Graphics.UI.WX.Dialogs +import Graphics.UI.WX.Draw + +import Graphics.UI.WXCore + +-- | 'start' runs the GUI. +start :: IO a -> IO () +start io + = run (unitIO io) diff --git a/src/Graphics/UI/WX/Attributes.hs b/src/Graphics/UI/WX/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Attributes.hs @@ -0,0 +1,344 @@ +{-# OPTIONS -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : Attributes + Copyright : (c) Daan Leijen 2003 + License : wxWindows + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + + Widgets @w@ can have attributes of type @a@ represented by the type 'Attr' @w a@. + An example of an attribute is 'Graphics.UI.WX.Classes.text' with type: + + > text :: Attr (Window a) String + + This means that any object derived from 'Window' has a 'Graphics.UI.WX.Classes.text' attribute of type 'String'. + An attribute can be read with the 'get' function: + + > get w title :: IO String + + When an attribute is associated with a value, we call it a /property/ of type 'Prop' @w@. + Properties are constructed by assigning a value to an attribute with the (':=') constructor: + + > text := "hello world" :: Prop (Window a) + + A list of properties can be set with the 'set' function: + + > set w [text := "Hi"] :: IO () + + The (':~') constructor is used to transform an attribute value with an update function. + For example, the 'interval' on a timer can be doubled with the following expression. + + > set timer [interval :~ (*2)] + + The functions 'get', 'set', (':='), and (':~') are polymorphic and work for all widgets, but + the @text@ attribute just works for windows. Many attributes work for different kind + of objects and are organised into type classes. Actually, the real type of the + 'Graphics.UI.WX.Classes.text' attribute is: + + > Textual w => Attr w String + + and 'Window' derived objects are part of this class: + + > instance Textual (Window a) + + But also menus and status fields: + + > instance Textual (Menu a) + > instance Textual (StatusField) + + Sometimes, it is convenient to also get a reference to the object itself when setting + a property. The operators ('::=') and ('::~') provide this reference. +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX.Attributes + ( + -- * Attributes + Attr, Prop((:=),(:~),(::=),(::~)), ReadAttr, WriteAttr, CreateAttr + , get, set, swap + , mapAttr, mapAttrW + + + -- * Internal + + -- ** Attributes + , newAttr, readAttr, writeAttr, nullAttr, constAttr, makeAttr + + -- ** Reflection + , attrName, propName, containsProperty + + -- ** Reflective attributes + , reflectiveAttr, createAttr, withProperty, findProperty + , withStyleProperty, withStylePropertyNot + + -- *** Filter + , PropValue(..) + , filterProperty + + -- ** Cast + , castAttr, castProp, castProps + ) where + +import Graphics.UI.WX.Types +import Data.Dynamic + +infixr 0 :=,:~,::=,::~ + +-- | A property of a widget @w@ is an attribute that +-- is already associated with a value. . +data Prop w = forall a. Attr w a := a -- ^ Assign a value to an attribute. + | forall a. Attr w a :~ (a -> a) -- ^ Apply an update function to an attribute. + | forall a. Attr w a ::= (w -> a) -- ^ Assign a value to an attribute with the widget as argument. + | forall a. Attr w a ::~ (w -> a -> a) -- ^ Apply an update function to an attribute with the widget as an argument. + + +-- | An attribute that should be specified at creation time. Just for documentation purposes. +type CreateAttr w a = Attr w a + +-- | A read-only attribute. Just for documentation purposes. +type ReadAttr w a = Attr w a + +-- | A write-only attribute. Just for documentation purposes. +type WriteAttr w a = Attr w a + +-- | Widgets @w@ can have attributes of type @a@. +data Attr w a = Attr String (Maybe (a -> Dynamic, Dynamic -> Maybe a)) -- name, dynamic conversion + (w -> IO a) (w -> a -> IO ()) -- getter setter + (w -> (a -> a) -> IO a) -- updater + + +-- | Cast attributes. +castAttr :: (v -> w) -> Attr w a -> Attr v a +castAttr coerce (Attr name mbdyn getter setter upd) + = Attr name mbdyn (\v -> getter (coerce v)) (\v x -> (setter (coerce v) x)) + (\v f -> upd (coerce v) f) + +-- | Cast properties +castProp :: (v -> w) -> Prop w -> Prop v +castProp coerce prop + = case prop of + (attr := x) -> (castAttr coerce attr) := x + (attr :~ f) -> (castAttr coerce attr) :~ f + (attr ::= f) -> (castAttr coerce attr) ::= (\v -> f (coerce v)) + (attr ::~ f) -> (castAttr coerce attr) ::~ (\v x -> f (coerce v) x) + +-- | Cast a list of properties. +castProps :: (v -> w) -> [Prop w] -> [Prop v] +castProps coerce props + = map (castProp coerce) props + +-- | Create a /reflective/ attribute with a specified name: value can possibly +-- retrieved using 'getPropValue'. Note: the use of this function is discouraged +-- as it leads to non-compositional code. +reflectiveAttr :: Typeable a => String -> (w -> IO a) -> (w -> a -> IO ()) -> Attr w a +reflectiveAttr name getter setter + = Attr name (Just (toDyn, fromDynamic)) getter setter updater + where + updater w f = do x <- getter w; setter w (f x); return x + +-- | Create a /reflective/ attribute with a specified name: value can possibly +-- retrieved using 'getPropValue'. Note: the use of this function is discouraged +-- as it leads to non-compositional code. +createAttr :: Typeable a => String -> (w -> IO a) -> (w -> a -> IO ()) -> CreateAttr w a +createAttr name getter setter + = reflectiveAttr name getter setter + +-- | Create a new attribute with a specified name, getter, setter, and updater function. +makeAttr :: String -> (w -> IO a) -> (w -> a -> IO ()) -> (w -> (a -> a) -> IO a) -> Attr w a +makeAttr name getter setter updater + = Attr name Nothing getter setter updater + + +-- | Create a new attribute with a specified name, getter and setter function. +newAttr :: String -> (w -> IO a) -> (w -> a -> IO ()) -> Attr w a +newAttr name getter setter + = makeAttr name getter setter updater + where + updater w f = do x <- getter w; setter w (f x); return x + + +-- | Define a read-only attribute. +readAttr :: String -> (w -> IO a) -> ReadAttr w a +readAttr name getter + = newAttr name getter (\w x -> ioError (userError ("attribute '" ++ name ++ "' is read-only."))) + +-- | Define a write-only attribute. +writeAttr :: String -> (w -> a -> IO ()) -> WriteAttr w a +writeAttr name setter + = newAttr name (\w -> ioError (userError ("attribute '" ++ name ++ "' is write-only."))) setter + +-- | A dummy attribute. +nullAttr :: String -> WriteAttr w a +nullAttr name + = writeAttr name (\w x -> return ()) + +-- | A constant attribute. +constAttr :: Typeable a => String -> a -> Attr w a +constAttr name x + = newAttr name (\w -> return x) (\w x -> return ()) + + +-- | (@mapAttr get set attr@) maps an attribute of @Attr w a@ to +-- @Attr w b@ where (@get :: a -> b@) is used when the attribute is +-- requested and (@set :: a -> b -> a@) is applied to current +-- value when the attribute is set. +mapAttr :: (a -> b) -> (a -> b -> a) -> Attr w a -> Attr w b +mapAttr get set (Attr name reflect getter setter updater) + = Attr name Nothing + (\w -> do a <- getter w; return (get a)) + (\w b -> do a <- getter w; setter w (set a b)) + (\w f -> do a <- updater w (\a -> set a (f (get a))); return (get a)) + +-- | (@mapAttrW conv attr@) maps an attribute of @Attr w a@ to +-- @Attr v a@ where (@conv :: v -> w@) is used to convert a widget +-- @v@ into a widget of type @w@. +mapAttrW :: (v -> w) -> Attr w a -> Attr v a +mapAttrW f attr + = castAttr f attr + +-- | Get the value of an attribute +-- +-- > t <- get w text +-- +get :: w -> Attr w a -> IO a +get w (Attr name reflect getter setter updater) + = getter w + +-- | Set a list of properties. +-- +-- > set w [text := "Hi"] +-- +set :: w -> [Prop w] -> IO () +set w props + = mapM_ setprop props + where + setprop ((Attr name reflect getter setter updater) := x) + = setter w x + setprop ((Attr name reflect getter setter updater) :~ f) + = do updater w f; return () + setprop ((Attr name reflect getter setter updater) ::= f) + = setter w (f w) + setprop ((Attr name reflect getter setter updater) ::~ f) + = do updater w (f w); return () + +-- | Set the value of an attribute and return the old value. +swap :: w -> Attr w a -> a -> IO a +swap w (Attr name reflect getter setter updater) x + = updater w (const x) + +-- | Retrieve the name of an attribute +attrName :: Attr w a -> String +attrName (Attr name _ _ _ _) + = name + +-- | Retrieve the name of a property. +propName :: Prop w -> String +propName (attr := x) = attrName attr +propName (attr :~ f) = attrName attr +propName (attr ::= f) = attrName attr +propName (attr ::~ f) = attrName attr + + +-- | Is a certain property in a list of properties? +containsProperty :: Attr w a -> [Prop w] -> Bool +containsProperty attr props + = containsPropName (attrName attr) props + +-- | Is a certain property in a list of properties? +containsPropName :: String -> [Prop w] -> Bool +containsPropName name props + = any (\p -> propName p == name) props + + +-- | Property value: used when retrieving a property from a list. +data PropValue a = PropValue a + | PropModify (a -> a) + | PropNone + +instance Show a => Show (PropValue a) where + show (PropValue x) = "PropValue " ++ show x + show (PropModify f) = "PropModify" + show (PropNone) = "PropNone" + +-- | Retrieve the value of a property and the list with the property removed. +filterProperty :: Typeable a => Attr w a -> [Prop w] -> (PropValue a, [Prop w]) +filterProperty (Attr name _ _ _ _) props + = walk [] PropNone props + where + -- Daan: oh, how a simple thing like properties can result into this... ;-) + walk :: Typeable a => [Prop w] -> PropValue a -> [Prop w] -> (PropValue a, [Prop w]) + walk acc res props + = case props of + -- Property setter found. + (((Attr attr (Just (todyn,fromdyn)) _ _ _) := x):rest) | name == attr + -> case fromDynamic (todyn x) of + Just x -> walk acc (PropValue x) rest + Nothing -> walk acc res props + + -- Property modifier found. + (((Attr attr (Just (todyn,fromdyn)) _ _ _) :~ f):rest) | name == attr + -> let dynf x = case fromdyn (toDyn x) of + Just xx -> case fromDynamic (todyn (f xx)) of + Just y -> y + Nothing -> x -- identity + Nothing -> x -- identity + in case res of + PropValue x -> walk acc (PropValue (dynf x)) rest + PropModify g -> walk acc (PropModify (dynf . g)) rest + PropNone -> walk acc (PropModify dynf) rest + + -- Property found, but with the wrong arguments + (((Attr attr _ _ _ _) := _):rest) | name == attr -> stop + (((Attr attr _ _ _ _) :~ _):rest) | name == attr -> stop + (((Attr attr _ _ _ _) ::= _):rest) | name == attr -> stop + (((Attr attr _ _ _ _) ::~ _):rest) | name == attr -> stop + + -- Defaults + (prop:rest) + -> walk (prop:acc) res rest + [] -> stop + where + stop = (res, reverse acc ++ props) + + +-- | Try to find a property value and call the contination function with that value +-- and the property list witht the searched property removed. If the property is not +-- found, use the default value and the unchanged property list. +withProperty :: Typeable a => Attr w a -> a -> (a -> [Prop w] -> b) -> [Prop w] -> b +withProperty attr def cont props + = case filterProperty attr props of + (PropValue x, ps) -> cont x ps + (PropModify f, ps) -> cont (f def) ps + (PropNone, ps) -> cont def ps + +-- | Try to find a property value. Return |Nothing| if not found at all. +findProperty :: Typeable a => Attr w a -> a -> [Prop w] -> Maybe (a,[Prop w]) +findProperty attr def props + = case filterProperty attr props of + (PropValue x, ps) -> Just (x,ps) + (PropModify f, ps) -> Just (f def,ps) + (PropNone, ps) -> Nothing + + + +-- | Transform the properties based on a style property. +withStyleProperty :: Attr w Bool -> Style -> ([Prop w] -> Style -> a) -> [Prop w] -> Style -> a +withStyleProperty prop flag + = withStylePropertyEx prop (bitsSet flag) (\isSet style -> if isSet then (style .+. flag) else (style .-. flag)) + +-- | Transform the properties based on a style property. The flag is interpreted negatively, i.e. |True| +-- removes the bit instead of setting it. +withStylePropertyNot :: Attr w Bool -> Style -> ([Prop w] -> Style -> a) -> [Prop w] -> Style -> a +withStylePropertyNot prop flag + = withStylePropertyEx prop (not . bitsSet flag) (\isSet style -> if isSet then (style .-. flag) else (style .+. flag)) + + +-- | Transform the properties based on a style property. +withStylePropertyEx :: Attr w Bool -> (Style -> Bool) -> (Bool -> Style -> Style) -> ([Prop w] -> Style -> a) -> [Prop w] -> Style -> a +withStylePropertyEx prop def transform cont props style + = case filterProperty prop props of + (PropValue x, ps) -> cont ps (transform x style) + (PropModify f, ps) -> cont ps (transform (f (def style)) style) + (PropNone, ps) -> cont ps style diff --git a/src/Graphics/UI/WX/Classes.hs b/src/Graphics/UI/WX/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Classes.hs @@ -0,0 +1,372 @@ +{-# OPTIONS -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : Classes + Copyright : (c) Daan Leijen 2003 + License : wxWindows + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + This modules defines attributes common to many widgets and + organizes them into Haskell classes. Look at the instance definitions + to see what kind of widgets support the attributes. + + Sometimes it is + hard to find what attributes a certain widget supports since the instance + definitions might be on some class higher in the hierarchy. For example, + many instances are defined for 'Window' @a@ -- this means that all + those attributes are applicable to any kind of 'Window', i.e. frames, + buttons, panels etc. However, these attributes will not be explicitly + listed at the type definitions of those classes. +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX.Classes + ( + -- * Data types + Border(..) + + -- * Text + , Textual(text,appendText) + , Literate(font ,fontFamily, fontFace, fontSize, fontWeight, fontUnderline, fontShape + ,textColor,textBgcolor) + -- * Rendering + , Dimensions(..) + , Colored(..) + , Visible(..) + , Bordered(..) + -- * Hierarchy + , Child(..) + , Parent(..) + , Closeable(..) + -- * Containers + , Selection( selection ) + , Selections( selections ) + , Items( itemCount, item, items, itemAppend, itemDelete, itemsDelete ) + -- * Misc. + , Able( enabled ) -- , enable + , Help( help ) + , Tipped( tooltip ) + , Identity( identity ) + , Styled( style ) + , Framed( resizeable, maximizeable, minimizeable, closeable ) + , Checkable( checkable, checked ) + , Dockable( dockable ) + , Pictured( picture ) + , Valued( value ) + , Sized( size ) + ) where + +import Data.Dynamic +import Graphics.UI.WXCore + +import Graphics.UI.WX.Types +import Graphics.UI.WX.Attributes +import Graphics.UI.WX.Layout + + +-- | Widgets with a label or text field. +class Textual w where + -- | The text of a widget. It is interpreted differently for + -- for different widgets, for example, the title of a frame or the content of a + -- static text control. + text :: Attr w String + appendText :: w -> String -> IO () + + appendText w s + = set w [text :~ (++s)] + + +-- | Widgets with a picture. +class Pictured w where + -- | The image of a widget. + picture :: Attr w FilePath + + +-- | Widgets with a font. +class Literate w where + -- | The font of the widget. + font :: Attr w FontStyle + + -- | The font size. + fontSize :: Attr w Int + + -- | The font weight. + fontWeight :: Attr w FontWeight + + -- | The font family. + fontFamily :: Attr w FontFamily + + -- | The font style. + fontShape :: Attr w FontShape + + -- | The font /face/: determines a platform dependent font. + fontFace :: Attr w String + + -- | Is the font underlined? + fontUnderline :: Attr w Bool + + -- | Text color. + textColor :: Attr w Color + + -- | Text background color + textBgcolor:: Attr w Color + + fontSize = mapAttr _fontSize (\finfo x -> finfo{ _fontSize = x }) font + fontWeight = mapAttr _fontWeight (\finfo x -> finfo{ _fontWeight = x }) font + fontFamily = mapAttr _fontFamily (\finfo x -> finfo{ _fontFamily = x }) font + fontShape = mapAttr _fontShape (\finfo x -> finfo{ _fontShape = x }) font + fontFace = mapAttr _fontFace (\finfo x -> finfo{ _fontFace = x }) font + fontUnderline = mapAttr _fontUnderline (\finfo x -> finfo{ _fontUnderline = x }) font + + + +-- | Widgets that have a size. +class Dimensions w where + -- | The outer size of a widget (in pixels). + outerSize :: Attr w Size + -- | The (relative) position of a widget. + position :: Attr w Point + -- | The occupied area. + area :: Attr w Rect + -- | The preferred size of a widget. + bestSize :: ReadAttr w Size + -- | The area available for client use (i.e. without the border etc). + clientSize :: Attr w Size + -- | The virtual size of a widget (ie. the total scrolling area) + virtualSize :: Attr w Size + + -- defaults + outerSize + = mapAttr rectSize (\r sz -> rect (rectTopLeft r) sz) area + position + = mapAttr rectTopLeft (\r pt -> rect pt (rectSize r)) area + area + = newAttr "area" getArea setArea + where + getArea w + = do sz <- get w outerSize + pt <- get w position + return (rect pt sz) + setArea w rect + = set w [outerSize := rectSize rect, position := rectTopLeft rect] + + clientSize + = outerSize + bestSize + = outerSize + virtualSize + = clientSize + +class Colored w where + -- | The background color. + bgcolor :: Attr w Color + -- | The (foreground) color + color :: Attr w Color + + bgcolor + = nullAttr "bgcolor" + color + = nullAttr "color" + +-- | Visible widgets. +class Visible w where + -- | Is the widget visible? + visible :: Attr w Bool + -- | Refresh the widget explicitly. + refresh :: w -> IO () + + -- | Should the widget be fully repainted on resize? This attribute only + -- has effect when set at creation. If 'False', you will have to repaint + -- the new window area manually at a resize, but flickering caused by + -- background redraws can be prevented in this way. ('False' by default) + fullRepaintOnResize :: Attr w Bool + fullRepaintOnResize + = nullAttr "fullRepaintOnResize" + + -- defaults + visible + = nullAttr "visible" + refresh w + = return () + +-- | Parent widgets. +class Parent w where + -- | Get the child widgets of a window. + children :: ReadAttr w [Window ()] + children = nullAttr "window" + + -- | Reduce flicker by not redrawing the background under child controls. + -- This attribute has to be set at creation time. ('True' by default) + clipChildren :: Attr w Bool + clipChildren + = nullAttr "clipChildren" + + +-- | Window borders +data Border = BorderSimple -- ^ Displays a thin border around the window. + | BorderDouble -- ^ Displays a double border. Windows only. + | BorderSunken -- ^ Displays a sunken border. + | BorderRaised -- ^ Displays a raised border. + | BorderStatic -- ^ Displays a border suitable for a static control. Windows only + | BorderNone -- ^ No border + deriving (Eq,Show,Read,Typeable) + +instance BitMask Border where + assocBitMask + = [(BorderSimple, wxBORDER) + ,(BorderDouble, wxDOUBLE_BORDER) + ,(BorderSunken, wxSUNKEN_BORDER) + ,(BorderRaised, wxRAISED_BORDER) + ,(BorderStatic, wxSTATIC_BORDER) + ,(BorderNone, 0)] + + +-- | Widgets with a border. +class Bordered w where + -- | Specify the border of a widget. + border :: Attr w Border + border = nullAttr "border" + + +-- | Widgets that are part of a hierarchical order. +class Child w where + -- | The parent widget. + parent :: ReadAttr w (Window ()) + + -- defaults + parent + = readAttr "parent" (\w -> return objectNull) + + +-- | Widgets that can be closed. +class Closeable w where + -- | Close the widget. + close :: w -> IO () + +-- | Widgets that have a system frame around them. +class Framed w where + -- | Make the widget user resizeable? This attribute must be set at creation time. + resizeable :: Attr w Bool + resizeable = nullAttr "resizeable" + + -- | Can the widget be minimized? This attribute must be set at creation time. + minimizeable :: Attr w Bool + minimizeable = nullAttr "minimizeable" + + -- | Can the widget be maximized? This attribute must be set at creation time + -- and is normally used together with 'resizeable'. + maximizeable :: Attr w Bool + maximizeable = nullAttr "maximizeable" + + -- | Can the widget be closed by the user? This attribute must be set at creation time. + closeable :: Attr w Bool + closeable = nullAttr "closeable" + + +-- | Widgets that can be enabled or disabled. +class Able w where + -- | Enable, or disable, the widget. + enabled :: Attr w Bool + +-- | Deprecated: use 'enabled' instead +enable :: Able w => Attr w Bool +enable = enabled + +-- | Widgets with help text. +class Help w where + -- | Short help text, normally displayed in the status bar or popup balloon. + help :: Attr w String + +-- | Checkable widgets +class Checkable w where + -- | Is the widget checkable? + checkable :: Attr w Bool + -- | Is the widget checked? + checked :: Attr w Bool + +-- | The identity determines the wxWindows ID of a widget. +class Identity w where + -- | The identity determines the wxWindows ID of a widget. + identity :: Attr w Int + + +-- | The style is a bitmask that determines various properties of a widget. +class Styled w where + -- | The windows style. + style :: Attr w Int + +-- | Dockable widgets. +class Dockable w where + -- | Is the widget dockable? + dockable :: Attr w Bool + +-- | Widgets that have a tooltip +class Tipped w where + -- | The tooltip information + tooltip :: Attr w String + +-- | Widgets with a single selection (radio group or listbox) +class Selection w where + -- | The current selection as a zero-based index. + -- Certain widgets return -1 when no item is selected. + selection :: Attr w Int + +-- | Widget with zero or more selections (multi select list boxes) +class Selections w where + -- | The currently selected items in zero-based indices. + selections :: Attr w [Int] + + +-- | Widgets containing certain items (like strings in a listbox) +class Items w a | w -> a where + -- | Number of items. + itemCount :: ReadAttr w Int + -- | All the items as a list. This attribute might not be writable for some widgets (like radioboxes) + items :: Attr w [a] + -- | An item by zero-based index. + item :: Int -> Attr w a + -- | Delete an item. Only valid for writeable items. + itemDelete :: w -> Int -> IO () + -- | Delete all items. Only valid for writeable items. + itemsDelete :: w -> IO () + -- | Append an item. Only valid for writeable items. + itemAppend :: w -> a -> IO () + + items + = newAttr "items" getter setter + where + getter :: w -> IO [a] + getter w + = do n <- get w itemCount + mapM (\i -> get w (item i)) [0..n-1] + + setter :: w -> [a] -> IO () + setter w xs + = do itemsDelete w + mapM_ (\x -> itemAppend w x) xs + + itemAppend w x + = do xs <- get w items + set w [items := xs ++ [x]] + + itemsDelete w + = do count <- get w itemCount + sequence_ (replicate count (itemDelete w 0)) + +{-------------------------------------------------------------------------- + Values +--------------------------------------------------------------------------} +-- | Items with a value. +class Valued w where + -- | The value of an object. + value :: Attr (w a) a + +{-------------------------------------------------------------------------- + Size +--------------------------------------------------------------------------} +-- | Sized objects (like bitmaps) +class Sized w where + -- | The size of an object. (is 'outerSize' for 'Dimensions' widgets). + size :: Attr w Size + diff --git a/src/Graphics/UI/WX/Controls.hs b/src/Graphics/UI/WX/Controls.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Controls.hs @@ -0,0 +1,1104 @@ +{-# OPTIONS -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : Controls + Copyright : (c) Daan Leijen 2003 + (c) Shelarcy (shelarcy@gmail.com) 2006 + License : wxWindows + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + Defines common GUI controls. +-} + +{- + Modification History: + When Who What + 300806 jeremy.odonoghue@gmail.com Set list item mask (wxLIST_MASK_TEXT) + (on behalf of shelarcy@gmail.com) +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX.Controls + ( -- * Classes + Align(..), Aligned, alignment + , Wrap(..), Wrapped, wrap + , Sorted, sorted + -- * Containers + , Panel, panel, panelEx, defaultButton + , Notebook, notebook + , focusOn + -- * Controls + -- ** Button + , Button, button, buttonEx, smallButton + , BitmapButton, bitmapButton + -- ** Text entry + , TextCtrl, entry, textEntry, textCtrl, textCtrlRich, textCtrlEx + , processEnter, processTab + -- ** CheckBox + , CheckBox, checkBox + -- ** Choice + , Choice, choice, choiceEx + -- ** ComboBox + , ComboBox, comboBox, comboBoxEx + -- ** ListBox + , ListBox, SingleListBox, MultiListBox, singleListBox, multiListBox + -- ** RadioBox + , RadioBox, radioBox + -- ** Spin Control + , SpinCtrl, spinCtrl + -- ** Slider + , Slider, hslider, vslider, sliderEx + -- ** Gauge + , Gauge, hgauge, vgauge, gaugeEx + -- ** Tree control + , TreeCtrl, treeCtrl, treeCtrlEx, treeEvent + -- ** List control + , ListCtrl, listCtrl, listCtrlEx, listEvent, columns + -- ** Static text + , StaticText, staticText + -- ** SplitterWindow + , SplitterWindow, splitterWindow + -- ** ImageList + , ImageList, imageList, imageListFromFiles + -- ** MediaCtrl + , MediaCtrlBackend(..), MediaCtrl, mediaCtrl, mediaCtrlWithBackend, mediaCtrlEx + -- ** StyledTextCtrl + , StyledTextCtrl, stcEvent, styledTextCtrl, styledTextCtrlEx + ) where + +import Graphics.UI.WXCore hiding (Event) + +import Graphics.UI.WX.Types +import Graphics.UI.WX.Attributes +import Graphics.UI.WX.Classes +import Graphics.UI.WX.Events +import Graphics.UI.WX.Layout +import Graphics.UI.WX.Media (Media(..)) +import Graphics.UI.WX.Window + +import Data.Dynamic -- for "alignment" + + +defaultStyle + = wxCLIP_CHILDREN -- .+. wxNO_FULL_REPAINT_ON_RESIZE + +-- | Create a 'Panel', a window that is normally used as a container for +-- controls. It has a standard background and maintains standard keyboard +-- navigation (ie. /Tab/ moves through the controls). +-- +-- * Attributes: 'defaultButton', 'focusOn' +-- +-- * Instances: 'Form' -- 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', +-- 'Textual', 'Literate' +panel :: Window a -> [Prop (Panel ())] -> IO (Panel ()) +panel parent props + = panelEx parent (wxTAB_TRAVERSAL .+. defaultStyle) props + + +-- | Create a 'Panel' with a specific style. +-- +-- * Attributes: 'defaultButton', 'focusOn' +-- +-- * Instances: 'Form' -- 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', +-- 'Textual', 'Literate', 'Reactive', 'Paint' +panelEx :: Window a -> Style -> [Prop (Panel ())] -> IO (Panel ()) +panelEx parent style props + = feed2 props style $ + initialContainer $ \id rect -> \props flags -> + do p <- panelCreate parent id rect flags + windowSetFocus p + set p props + return p + +instance Form (Panel a) where + layout + = writeAttr "layout" windowSetLayout + +defaultButton :: Attr (Panel p) (Button ()) +defaultButton + = newAttr "defaultButton" getter setter + where + getter panel + = panelGetDefaultItem panel + + setter panel button + = do panelSetDefaultItem panel button + -- buttonSetDefault button -- note: seems to enlarge the button on GTK? + focusOn button + +-- | Set the initial focus on this control. +focusOn :: Window a -> IO () +focusOn w + = windowSetFocus w + + +-- | Create a 'Notebook'. Layout is managed with the 'tabs' combinator. +-- +-- * Instances: 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', +-- 'Textual', 'Literate', 'Reactive', 'Paint' +notebook :: Window a -> [Prop (Notebook ())] -> IO (Notebook ()) +notebook parent props + = feed2 props defaultStyle $ + initialContainer $ \id rect -> \props flags -> + do nb <- notebookCreate parent id rect flags + set nb props + return nb + +{-------------------------------------------------------------------------------- + Button +--------------------------------------------------------------------------------} + +-- | Create a standard push button. +-- +-- * Instances: 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +button :: Window a -> [Prop (Button ())] -> IO (Button ()) +button parent props + = buttonEx parent 0 props + +-- | Create a minimially sized push button. +-- +-- +-- * Instances: 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +smallButton :: Window a -> [Prop (Button ())] -> IO (Button ()) +smallButton parent props + = buttonEx parent wxBU_EXACTFIT props + + +-- | Create a standard push button with the given flags. +-- +-- * Instances: 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +buttonEx :: Window a -> Style -> [Prop (Button ())] -> IO (Button ()) +buttonEx parent stl props + = feed2 props stl $ + initialWindow $ \id rect -> + initialText $ \txt -> \props flags -> + do b <- buttonCreate parent id txt rect flags + set b props + return b + +instance Commanding (Button a) where + command = newEvent "command" buttonGetOnCommand buttonOnCommand + +-- | Create a bitmap button. Use the 'image' attribute to set the +-- bitmap. +-- +-- * Instances: 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +bitmapButton :: Window a -> [Prop (BitmapButton ())] -> IO (BitmapButton ()) +bitmapButton parent props + = feed2 props wxBU_AUTODRAW $ + initialWindow $ \id rect -> \props flags -> + do bb <- bitmapButtonCreate parent id nullBitmap rect flags + set bb props + return bb + +instance Pictured (BitmapButton a) where + picture + = writeAttr "picture" setter + where + setter w fname + = do fpath <- getAbsoluteFilePath fname + withBitmapFromFile fpath (bitmapButtonSetBitmapLabel w) + + +{-------------------------------------------------------------------------------- + Text entry +--------------------------------------------------------------------------------} +-- | Alignment. +data Align = AlignLeft | AlignRight | AlignCentre + deriving (Eq,Show,Read,Typeable) + +-- | Wrap mode. +data Wrap = WrapNone -- ^ No wrapping (and show a horizontal scrollbar). + | WrapLine -- ^ Wrap lines that are too long at any position. + | WrapWord -- ^ Wrap lines that are too long at word boundaries. + deriving (Eq,Show,Read,Typeable) + +instance BitMask Align where + assocBitMask + = [(AlignCentre,wxALIGN_CENTRE_HORIZONTAL) + ,(AlignRight, wxALIGN_RIGHT) + ,(AlignLeft, wxALIGN_LEFT)] + +instance BitMask Wrap where + assocBitMask + = [(WrapNone, wxHSCROLL) + ,(WrapLine, wxTE_LINEWRAP) + ,(WrapWord, wxTE_WORDWRAP)] + + +-- | Widgets that can have aligned content. +-- Note: this property is not +-- used to set the alignment of a widget itself -- See "Graphics.UI.WXCore.Layout" +-- for more information about layout. +class Aligned w where + -- | Set the alignment of the content. Due to wxWidgets constrictions, + -- this property has to be set at creation time. + alignment :: CreateAttr w Align + +initialAlignment :: Aligned w => ([Prop w] -> Style -> a) -> [Prop w] -> Style -> a +initialAlignment cont props style + = case filterProperty alignment props of + (PropValue x, ps) -> cont ps (setBitMask x style) + (PropModify f, ps) -> cont ps (setBitMask (f (fromBitMask style)) style) + (PropNone, ps) -> cont ps style + + +instance Aligned (TextCtrl a) where + alignment + = reflectiveAttr "alignment" getter setter + where + getter w + = do st <- get w style + return (fromBitMask st) + + setter w align + = set w [style :~ setBitMask align ] + +-- | Widgets that have wrappable content. +class Wrapped w where + -- | Set the wrap mode of a widget. + wrap :: CreateAttr w Wrap + +initialWrap cont props style + = case filterProperty wrap props of + (PropValue x, ps) -> cont ps (setBitMask x style) + (PropModify f, ps) -> cont ps (setBitMask (f (fromBitMask style)) style) + (PropNone, ps) -> cont ps style + +instance Wrapped (TextCtrl a) where + wrap + = reflectiveAttr "wrap" getter setter + where + getter w + = do st <- get w style + return (fromBitMask st) + + setter w mode + = set w [style :~ setBitMask mode] + + + +{- +instance Able (TextCtrl a) where + enabled + = newAttr "enabled" textCtrlIsEditable textCtrlSetEditable +-} + +-- | Create a single-line text entry control. Note: 'alignment' has to +-- be set at creation time (or the entry has default alignment (=left) ). +-- +-- * Instances: 'Wrap', 'Aligned', 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +entry :: Window a -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) +entry parent props + = textCtrlEx parent 0 props + +-- | Create a single-line text entry control. Note: 'alignment' has to +-- be set at creation time (or the entry has default alignment (=left) ). +-- +-- * Instances: 'Wrap', 'Aligned', 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +textEntry :: Window a -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) +textEntry parent props + = textCtrlEx parent 0 props + +-- | Create a multi-line text control. Note: the 'wrap' and 'alignment' +-- have to be set at creation time or the default to 'WrapNone' and 'AlignLeft' respectively. +-- +-- * Instances: 'Wrap', 'Aligned', 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +textCtrl :: Window a -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) +textCtrl parent props + = textCtrlEx parent wxTE_MULTILINE props + + +-- | Create a multi-line text rich-text control with a certain wrap mode +-- Enables font and color settings on windows, while being equal to 'textCtrl' +-- on other platforms. Note: the 'wrap' and 'alignment' +-- have to be set at creation time or the default to 'WrapNone' and 'AlignLeft' respectively. +-- +-- * Instances: 'Wrap', 'Aligned', 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +textCtrlRich :: Window a -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) +textCtrlRich parent props + = textCtrlEx parent (wxTE_MULTILINE .+. wxTE_RICH2) props + +-- | Create a generic text control given a certain style. +-- +-- * Instances: 'Wrap', 'Aligned', 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +textCtrlEx :: Window a -> Style -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) +textCtrlEx parent stl props + = feed2 props stl $ + initialWindow $ \id rect -> + initialText $ \txt -> + initialWrap $ + initialAlignment $ \props flags -> + do e <- textCtrlCreate parent id txt rect flags + set e props + return e + + +instance Commanding (TextCtrl a) where + command = newEvent "command" textCtrlGetOnTextEnter textCtrlOnTextEnter + +-- | Process @enter@ key events, used in a 'comboBox' or 'textCtrl' and +-- catched using a 'on' 'command' handler. +-- (otherwise pressing @Enter@ is either processed +-- internally by the control or used for navigation between dialog controls). +processEnter :: Styled w => Attr w Bool +processEnter + = newAttr "processEnter" getter setter + where + getter w + = do s <- get w style + return (bitsSet wxTE_PROCESS_ENTER s) + setter w p + = set w [style :~ \stl -> stl .+. wxTE_PROCESS_ENTER] + + +-- | Process @tab@ key events, used in a 'comboBox' or 'textCtrl'. +-- (otherwise pressing @Tab@ is either processed +-- internally by the control or used for navigation between dialog controls). +processTab :: Styled w => Attr w Bool +processTab + = newAttr "processTab" getter setter + where + getter w + = do s <- get w style + return (bitsSet wxTE_PROCESS_TAB s) + setter w p + = set w [style :~ \stl -> stl .+. wxTE_PROCESS_TAB] + + +{-------------------------------------------------------------------------------- + Static text +--------------------------------------------------------------------------------} +-- | Create static text label, see also 'label'. +staticText :: Window a -> [Prop (StaticText ())] -> IO (StaticText ()) +staticText parent props + = feed2 props 0 $ + initialWindow $ \id rect -> + initialText $ \txt -> \props flags -> + do t <- staticTextCreate parent id txt rect flags {- (wxALIGN_LEFT + wxST_NO_AUTORESIZE) -} + set t props + return t + + +{-------------------------------------------------------------------------------- + Check box +--------------------------------------------------------------------------------} +instance Commanding (CheckBox a) where + command = newEvent "command" checkBoxGetOnCommand checkBoxOnCommand + +instance Checkable (CheckBox a) where + checkable + = enabled + + checked + = newAttr "checked" checkBoxGetValue checkBoxSetValue + +-- | Create a new checkbox. +-- +-- * Instances: 'Commanding','Checkable' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +checkBox :: Window a -> [Prop (CheckBox ())] -> IO (CheckBox ()) +checkBox parent props + = feed2 props 0 $ + initialWindow $ \id rect -> + initialText $ \txt -> \props flags -> + do c <- checkBoxCreate parent id txt rect flags + set c props + return c + +{-------------------------------------------------------------------------------- + Choice +--------------------------------------------------------------------------------} +-- | Widgets that have sorted contents. +class Sorted w where + -- | Is the content of the widget sorted? + sorted :: CreateAttr w Bool + +instance Sorted (Choice a) where + sorted + = createAttr "sorted" getter setter + where + getter w + = do st <- get w style + return (bitsSet wxCB_SORT st) + setter w sort + = set w [style :~ \st -> if sort then st .+. wxCB_SORT else st .-. wxCB_SORT] + +initialSorted :: Sorted w => ([Prop w] -> Style -> a) -> [Prop w] -> Style -> a +initialSorted + = withStyleProperty sorted wxCB_SORT + + +instance Selecting (Choice ()) where + select = newEvent "select" choiceGetOnCommand choiceOnCommand + +instance Selection (Choice ()) where + selection + = newAttr "selection" choiceGetSelection choiceSetSelection + + +instance Items (Choice a) String where + itemCount + = readAttr "itemCount" choiceGetCount + + item i + = newAttr "item" (\w -> choiceGetString w i) (\w x -> choiceSetString w i x) + + itemAppend w x + = choiceAppend w x + + itemDelete w i + = choiceDelete w i + + +-- | Create a choice item to select a one of a list of strings. +-- +-- * Instances: 'Sorted', 'Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +choice :: Window a -> [Prop (Choice ())] -> IO (Choice ()) +choice parent props + = choiceEx parent 0 props + + +-- | Create a choice item, given a set of style flags, to select a one of a list of strings +-- +-- * Instances: 'Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +choiceEx :: Window a -> Style -> [Prop (Choice ())] -> IO (Choice ()) +choiceEx parent flags props + = feed2 props flags $ + initialWindow $ \id rect -> + initialSorted $ \props flags -> + do c <- choiceCreate parent id rect [] flags + set c props + return c + +{-------------------------------------------------------------------------------- + ComboBox +--------------------------------------------------------------------------------} +instance Commanding (ComboBox a) where + command + = newEvent "command" comboBoxGetOnTextEnter comboBoxOnTextEnter + +instance Selecting (ComboBox a) where + select + = newEvent "select" comboBoxGetOnCommand comboBoxOnCommand + +instance Selection (ComboBox a) where + selection + = newAttr "selection" comboBoxGetSelection comboBoxSetSelection + + +-- implemented by choice +{- +instance Items (ComboBox a) String where + itemCount + = readAttr "itemCount" comboBoxGetCount + + item i + = readAttr "item" (\w -> comboBoxGetString w i) -- (\w x -> comboBoxSetString w i x) + + itemAppend w x + = comboBoxAppend w x + + itemDelete w i + = comboBoxDelete w i +-} + +-- | Create a new combo box. +-- +-- * Instances: 'Selecting', 'Commanding','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', +-- 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +-- A 'command' event is triggered when the @enter@ key is pressed and when +-- 'processEnter' has been set to 'True'. +comboBox :: Window a -> [Prop (ComboBox ())] -> IO (ComboBox ()) +comboBox parent props + = comboBoxEx parent (wxCB_DROPDOWN) props + + +-- | Create a new combo box with a given set of flags. +-- +-- * Instances: 'Selecting', 'Commanding','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', +-- 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +-- A 'command' event is triggered when the @enter@ key is pressed and when +-- 'processEnter' has been set to 'True'. +comboBoxEx :: Window a -> Style -> [Prop (ComboBox ())] -> IO (ComboBox ()) +comboBoxEx parent flags props + = feed2 props flags $ + initialWindow $ \id rect -> + initialText $ \txt -> + initialSorted $ \props flags -> + do cb <- comboBoxCreate parent id txt rect [] flags + set cb props + return cb + + +{-------------------------------------------------------------------------------- + ListBox +--------------------------------------------------------------------------------} +instance Sorted (ListBox a) where + sorted + = createAttr "sorted" getter setter + where + getter w + = do st <- get w style + return (bitsSet wxLB_SORT st) + setter w sort + = set w [style :~ \st -> if sort then st .+. wxLB_SORT else st .-. wxLB_SORT] + + + +instance Selecting (ListBox a) where + select + = newEvent "select" listBoxGetOnCommand listBoxOnCommand + +instance Items (ListBox a) String where + itemCount + = readAttr "itemCount" listBoxGetCount + + item i + = newAttr "item" (\w -> listBoxGetString w i) (\w x -> listBoxSetString w i x) + + itemAppend w x + = listBoxAppend w x + + itemDelete w i + = listBoxDelete w i + +-- | Pointer to single selection list boxes, deriving from 'ListBox'. +type SingleListBox a = ListBox (CSingleListBox a) + +-- | Abstract type of the 'SingleListBox' class. +data CSingleListBox a = CSingleListBox + +instance Selection (SingleListBox a) where + selection + = newAttr "selection" listBoxGetSelection (\w x -> listBoxSetSelection w x True) + + +-- | Pointer to multiple selection list boxes, deriving from 'ListBox'. +type MultiListBox a = ListBox (CMultiListBox a) + +-- | Abstract type of the 'MultiListBox' class. +data CMultiListBox a = CMultiListBox + +instance Selections (MultiListBox a) where + selections + = newAttr "selections" listBoxGetSelectionList setter + where + setter w is = + do oldSelection <- listBoxGetSelectionList w + sequence_ [ listBoxSetSelection w i False -- deselect old selections + | i <- oldSelection + , i `notElem` is -- but not the ones in the new selection + ] + mapM_ (\i -> listBoxSetSelection w i True) is + + +-- | Create a single selection list box. +-- +-- * Instances: 'Sorted','Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +singleListBox :: Window a -> [Prop (SingleListBox ())] -> IO (SingleListBox ()) +singleListBox parent props + = feed2 props (wxLB_SINGLE .+. wxHSCROLL .+. wxLB_NEEDED_SB) $ + initialWindow $ \id rect -> + initialSorted $ \props flags -> + do lb <- listBoxCreate parent id rect [] flags + let sl = (objectCast lb :: SingleListBox ()) + set sl props + return sl + +-- | Create a multi selection list box. +---- +-- * Instances: 'Sorted', 'Selecting','Selections','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +multiListBox :: Window a -> [Prop (MultiListBox ())] -> IO (MultiListBox ()) +multiListBox parent props + = feed2 props (wxLB_MULTIPLE .+. wxLB_EXTENDED .+. wxHSCROLL .+. wxLB_NEEDED_SB) $ + initialWindow $ \id rect -> + initialSorted $ \props flags -> + do lb <- listBoxCreate parent id rect [] flags + let ml = (objectCast lb :: MultiListBox ()) + set ml props + return ml + +{-------------------------------------------------------------------------------- + RadioBox +--------------------------------------------------------------------------------} +instance Selecting (RadioBox a) where + select + = newEvent "select" radioBoxGetOnCommand radioBoxOnCommand + +instance Selection (RadioBox a) where + selection + = newAttr "selection" radioBoxGetSelection radioBoxSetSelection + +instance Items (RadioBox a) String where + itemCount + = readAttr "itemCount" radioBoxNumber + + item i + = newAttr "item" (\r -> radioBoxGetItemLabel r i) (\r s -> radioBoxSetItemLabel r i s) + + itemAppend + = error "Controls.itemAppend: you can not append items to a radiobox" + + itemDelete + = error "Controls.itemDelete: you can not delete items of a radiobox" + + +-- | Create a new radio button group with an initial orientation and a list of +-- labels. Use 'selection' to get the currently selected item. +-- +-- * Instances: 'Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +radioBox :: Window a -> Orientation -> [String] -> [Prop (RadioBox ())] -> IO (RadioBox ()) +radioBox parent direction labels props + = feed2 props (if (direction==Horizontal) then wxRA_SPECIFY_ROWS else wxRA_SPECIFY_COLS) $ + initialWindow $ \id rect -> + initialText $ \title -> \props flags -> + do r <- radioBoxCreate parent id title rect labels 1 flags + set r props + return r + +{-------------------------------------------------------------------------------- + Gauge +--------------------------------------------------------------------------------} +-- | Create a horizontal gauge with a specified integer range (max value). +-- The 'selection' attribute determines the position of the gauge. +-- +-- * Instances: 'Selection' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +hgauge :: Window a -> Int -> [Prop (Gauge ())] -> IO (Gauge ()) +hgauge parent range props + = gaugeEx parent range (wxHORIZONTAL .+. wxGA_SMOOTH) props + +-- | Create a vertical gauge with a specified integer range (max value). +-- The 'selection' attribute determines the position of the gauge. +-- +-- * Instances: 'Selection' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +vgauge :: Window a -> Int -> [Prop (Gauge ())] -> IO (Gauge ()) +vgauge parent range props + = gaugeEx parent range (wxVERTICAL .+. wxGA_SMOOTH) props + +-- | Create a gauge control. +-- The 'selection' attribute determines the position of the gauge. +-- +-- * Instances: 'Selection' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +gaugeEx :: Window a -> Int -> Style -> [Prop (Gauge ())] -> IO (Gauge ()) +gaugeEx parent range style props + = do g <- gaugeCreate parent idAny range rectNull style + set g props + return g + + +instance Selection (Gauge a) where + selection + = newAttr "selection" getter setter + where + getter g + = do i <- gaugeGetValue g + hi <- gaugeGetRange g + return (max 0 (min hi i)) + + setter g i + = do hi <- gaugeGetRange g + gaugeSetValue g (max 0 (min hi i)) + +{-------------------------------------------------------------------------------- + Slider +--------------------------------------------------------------------------------} +instance Commanding (Slider a) where + command = newEvent "command" sliderGetOnCommand sliderOnCommand + +-- | Create a horizontal slider with a specified minimum and maximum. Set +-- the 'Bool' argument to 'True' to show labels (minimumn, maximum, and +-- current value). The 'selection' attribute gives the current value. +-- +-- * Instances: 'Commanding','Selection' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +hslider :: Window a -> Bool -> Int -> Int -> [Prop (Slider ())] -> IO (Slider ()) +hslider parent showLabels min max props + = sliderEx parent min max (wxHORIZONTAL .+. (if showLabels then wxSL_LABELS else 0)) props + +-- | Create a vertical slider with a specified minimum and maximum. Set +-- the 'Bool' argument to 'True' to show labels (minimumn, maximum, and +-- current value). The 'selection' attribute gives the current value. +-- +-- * Instances: 'Commanding','Selection' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +vslider :: Window a -> Bool -> Int -> Int -> [Prop (Slider ())] -> IO (Slider ()) +vslider parent showLabels min max props + = sliderEx parent min max (wxVERTICAL .+. (if showLabels then wxSL_LABELS else 0)) props + +-- | Create a slider with a specified minimum and maximum. The +-- 'selection' attribute gives the current value. +-- +-- * Instances: 'Commanding','Selection' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +sliderEx :: Window a -> Int -> Int -> Style -> [Prop (Slider ())] -> IO (Slider ()) +sliderEx parent min max style props + = do s <- sliderCreate parent style min min max rectNull style + set s props + return s + +instance Selection (Slider a) where + selection + = newAttr "selection" getter setter + where + getter s + = do i <- sliderGetValue s + lo <- sliderGetMin s + hi <- sliderGetMax s + return (max lo (min hi i)) + + setter s i + = do lo <- sliderGetMin s + hi <- sliderGetMax s + sliderSetValue s (max lo (min hi i)) + + +{-------------------------------------------------------------------------------- + SpinCtrl +--------------------------------------------------------------------------------} +-- | Create a spin control: a text field with up\/down buttons. The value ('selection') +-- is always between a specified minimum and maximum. +-- +-- * Instances: 'Selection', 'Selecting' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +spinCtrl :: Window a -> Int -> Int -> [Prop (SpinCtrl ())] -> IO (SpinCtrl ()) +spinCtrl parent lo hi props + = feed2 props wxSP_ARROW_KEYS $ + initialWindow $ \id rect -> + initialText $ \txt -> \props flags -> + do sc <- spinCtrlCreate parent id txt rect flags (min lo hi) (max lo hi) lo + set sc props + return sc + +instance Selection (SpinCtrl a) where + selection + = newAttr "selection" getter setter + where + getter sc + = do i <- spinCtrlGetValue sc + lo <- spinCtrlGetMin sc + hi <- spinCtrlGetMax sc + return (max lo (min hi i)) + + setter sc i + = do lo <- spinCtrlGetMin sc + hi <- spinCtrlGetMax sc + spinCtrlSetValue sc (max lo (min hi i)) + + +instance Selecting (SpinCtrl a) where + select + = newEvent "select" spinCtrlGetOnCommand spinCtrlOnCommand + + +{-------------------------------------------------------------------------------- + TreeCtrl +--------------------------------------------------------------------------------} +-- | Tree control events. +treeEvent :: Event (TreeCtrl a) (EventTree -> IO ()) +treeEvent + = newEvent "treeEvent" treeCtrlGetOnTreeEvent treeCtrlOnTreeEvent + +-- | Create a single-selection tree control with buttons (i.e. + and - signs). +-- +-- * Attributes: 'treeEvent' +-- +-- * Instances: 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +treeCtrl :: Window a -> [Prop (TreeCtrl ())] -> IO (TreeCtrl ()) +treeCtrl parent props + = treeCtrlEx parent (wxTR_HAS_BUTTONS .+. defaultStyle) props + +-- | Create a tree control. +-- +-- * Attributes: 'treeEvent' +-- +-- * Instances: 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +treeCtrlEx :: Window a -> Style -> [Prop (TreeCtrl ())] -> IO (TreeCtrl ()) +treeCtrlEx parent style props + = feed2 props style $ + initialContainer $ \id rect -> \props flags -> + do t <- treeCtrlCreate2 parent id rect flags + set t props + return t + +{-------------------------------------------------------------------------------- + ListCtrl +--------------------------------------------------------------------------------} +instance Items (ListCtrl a) [String] where + itemCount + = readAttr "itemCount" listCtrlGetItemCount + + item i + = newAttr "item" getter setter + where + getter l + = bracket listItemCreate + listItemDelete + (\li -> do count <- listCtrlGetColumnCount l + mapM (\column -> do listItemSetColumn li (column-1) + listItemSetId li i + listItemSetMask li wxLIST_MASK_TEXT + listCtrlGetItem l li + listItemGetText li) [1..count]) + + + setter l texts + = do count <- listCtrlGetItemCount l + when (i == count) (do listCtrlInsertItemWithLabel l i (show i) (-1); return ()) + mapM_ (\(column,txt) -> listCtrlSetItem l i column txt (-1)) (zip [0..] texts) + + itemAppend l texts + = do count <- listCtrlGetItemCount l + listCtrlInsertItemWithLabel l count (show count) (-1) + mapM_ (\(column,txt) -> listCtrlSetItem l count column txt (-1)) (zip [0..] texts) + + itemDelete l i + = do listCtrlDeleteItem l i + return () + + itemsDelete l + = do listCtrlDeleteAllItems l + return () + +-- | The @columns@ attribute controls the columns in a report-view list control. +columns :: Attr (ListCtrl a) [(String,Align,Int)] +columns + = newAttr "columns" getter setter + where + setter l xs + = do n <- listCtrlGetColumnCount l + mapM_ (\c -> listCtrlDeleteColumn l 0) (reverse [1..n]) + mapM_ (insertColumn l) (zip [0..] xs) + where + insertColumn l (idx,(name,align,width)) + = let alignment = case align of + AlignRight -> wxLIST_FORMAT_RIGHT + AlignCentre-> wxLIST_FORMAT_CENTER + other -> wxLIST_FORMAT_LEFT + in listCtrlInsertColumn l idx name alignment width + + getter l + = do n <- listCtrlGetColumnCount l + mapM (getColumn l) [0..n] + where + getColumn l idx + = bracket (listCtrlGetColumn2 l idx) + (listItemDelete) + (\item -> do name <- listItemGetText item + alignment <- listItemGetAlign item + width <- listItemGetWidth item + let align | alignment == wxLIST_FORMAT_RIGHT = AlignRight + | alignment == wxLIST_FORMAT_CENTER = AlignCentre + | otherwise = AlignLeft + return (name,align,width) + ) + + + +-- | List control events. +listEvent :: Event (ListCtrl a) (EventList -> IO ()) +listEvent + = newEvent "listEvent" listCtrlGetOnListEvent listCtrlOnListEvent + +-- | Create a report-style list control. +-- +-- * Attributes: 'listEvent', 'columns' +-- +-- * Instances: 'Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +listCtrl :: Window a -> [Prop (ListCtrl ())] -> IO (ListCtrl ()) +listCtrl parent props + = listCtrlEx parent (wxLC_REPORT .+. defaultStyle) props + +-- | Create a list control. +-- +-- * Attributes: 'listEvent', 'columns' +-- +-- * Instances: 'Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +listCtrlEx :: Window a -> Style -> [Prop (ListCtrl ())] -> IO (ListCtrl ()) +listCtrlEx parent style props + = feed2 props style $ + initialContainer $ \id rect -> \props flags -> + do l <- listCtrlCreate parent id rect flags + set l props + return l + +{-------------------------------------------------------------------------------- + SplitterWindow +--------------------------------------------------------------------------------} +-- | Create a splitter window. +-- +-- * Instances: 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +splitterWindow :: Window a -> [Prop (SplitterWindow ())] -> IO (SplitterWindow ()) +splitterWindow parent props + = feed2 props (defaultStyle .+. wxSP_LIVE_UPDATE) $ + initialContainer $ \id rect -> \props flags -> + do s <- splitterWindowCreate parent id rect flags + set s props + return s + +{-------------------------------------------------------------------------------- + ImageList +--------------------------------------------------------------------------------} +-- | Create an empty image list that will contain images of the desired size. +imageList :: Size -> IO (ImageList ()) +imageList size + = imageListCreate size True 10 + +-- | Create an image list containing the images in the supplied file name list +-- that will be scaled towards the desired size. +imageListFromFiles :: Size -> [FilePath] -> IO (ImageList ()) +imageListFromFiles size files + = do images <- imageListCreate size True (length files) + imageListAddIconsFromFiles images size files + return images + +{-------------------------------------------------------------------------------- + MediaCtrl +--------------------------------------------------------------------------------} + +-- | Optional back-end for your MediaCtrl. +-- If you want to know more about back-end, you must see wxWidgets' Document. +-- +data MediaCtrlBackend = + DirectShow -- ^ Use ActiveMovie\/DirectShow. Default back-end on Windows. + | MediaControlInterface -- ^ Use Media Command Interface. Windows Only. + | WindowsMediaPlayer10 -- ^ Use Windows Media Player 10. Windows Only. Require to use wxWidgets 2.8.x. + | QuickTime -- ^ Use QuickTime. Mac Only. + | GStreamer -- ^ Use GStreamer. Unix Only. Require GStreamer and GStreamer Support. + | DefaultBackend -- ^ Use default back-end on your platform. + deriving (Eq,Show) + +fromMediaCtrlBackend :: MediaCtrlBackend -> String +fromMediaCtrlBackend back + = case back of + DirectShow -> wxMEDIABACKEND_DIRECTSHOW + MediaControlInterface -> wxMEDIABACKEND_MCI + WindowsMediaPlayer10 -> wxMEDIABACKEND_WMP10 + QuickTime -> wxMEDIABACKEND_QUICKTIME + GStreamer -> wxMEDIABACKEND_GSTREAMER + DefaultBackend -> "" + +-- FIXME: Change wxDirect to Support STRING type in Eiffel file (*.e) +-- instead of write definition directory here. +wxMEDIABACKEND_DIRECTSHOW = "wxAMMediaBackend" +wxMEDIABACKEND_MCI = "wxMCIMediaBackend" +wxMEDIABACKEND_WMP10 = "wxWMP10MediaBackend" +wxMEDIABACKEND_QUICKTIME = "wxQTMediaBackend" +wxMEDIABACKEND_GSTREAMER = "wxGStreamerMediaBackend" + +mediaCtrl :: Window a -> [Prop (MediaCtrl ())] -> IO (MediaCtrl ()) +mediaCtrl parent props + = mediaCtrlEx parent defaultStyle DefaultBackend props + +-- | Create MediaCtrl with choosing back-end. This is useful to select back-end on +-- Windows. But if you don't want to cause any effect to other platforms, you must +-- use wxToolkit or #ifdef macro to choose correct function for platforms. +-- For example, +-- +-- > import Graphics.UI.WXCore.Defines +-- > ... +-- > m <- case wxToolkit of +-- > WxMSW -> mediaCtrlWithBackend f MediaControlInterface [] +-- > _ -> mediaCtrl f [] +-- +-- or +-- +-- > #ifdef mingw32_HOST_OS || mingw32_TARGET_OS +-- > m <- mediaCtrlWithBackend f MediaControlInterface [] +-- > #else +-- > m <- mediaCtrl f [] +-- > #endif +-- +mediaCtrlWithBackend :: Window a -> MediaCtrlBackend -> [Prop (MediaCtrl ())] -> IO (MediaCtrl ()) +mediaCtrlWithBackend parent back props + = mediaCtrlEx parent defaultStyle back props + +mediaCtrlEx :: Window a -> Style -> MediaCtrlBackend -> [Prop (MediaCtrl ())] -> IO (MediaCtrl ()) +mediaCtrlEx parent style back props + = feed2 props style $ + initialContainer $ \id rect -> \props flags -> + do s <- mediaCtrlCreate parent id "" rect style (fromMediaCtrlBackend back) "" + set s props + return s + +instance Media (MediaCtrl a) where + play media = unitIO (mediaCtrlPlay media) + stop media = unitIO (mediaCtrlStop media) + +{-------------------------------------------------------------------------------- + wxStyledTextCtrl +--------------------------------------------------------------------------------} + +stcEvent :: Event (StyledTextCtrl ()) (EventSTC -> IO ()) +stcEvent + = newEvent "stcEvent" stcGetOnSTCEvent stcOnSTCEvent + + +styledTextCtrl :: Window a -> [Prop (StyledTextCtrl ())] -> IO (StyledTextCtrl ()) +styledTextCtrl parent props + = styledTextCtrlEx parent defaultStyle props + +styledTextCtrlEx :: Window a -> Style -> [Prop (StyledTextCtrl ())] -> IO (StyledTextCtrl ()) +styledTextCtrlEx parent style props + = feed2 props style $ + initialContainer $ \id rect -> \props flags -> + do s <- styledTextCtrlCreate parent id "" rect style + set s props + return s diff --git a/src/Graphics/UI/WX/Dialogs.hs b/src/Graphics/UI/WX/Dialogs.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Dialogs.hs @@ -0,0 +1,82 @@ +{-# OPTIONS -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : Dialogs + Copyright : (c) Daan Leijen 2003 + License : wxWindows + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + Defines common dialogs. + + * Instances: 'Form', 'Framed' -- + 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', + 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX.Dialogs + ( -- * Generic dialogs + Dialog, dialog, showModal + -- * Messages + , errorDialog, warningDialog, infoDialog + , confirmDialog, proceedDialog + -- * Files + , fileOpenDialog, filesOpenDialog + , fileSaveDialog + , dirOpenDialog + -- * Misc. + , fontDialog + , colorDialog + , passwordDialog + , textDialog + , numberDialog + -- * Primitive + , dialogEx + ) where + +import Graphics.UI.WXCore + +import Graphics.UI.WX.Types +import Graphics.UI.WX.Attributes +import Graphics.UI.WX.Layout +import Graphics.UI.WX.Classes +import Graphics.UI.WX.Window +import Graphics.UI.WX.Events -- just for haddock +import Graphics.UI.WX.Frame + +instance Form (Dialog a) where + layout + = writeAttr "layout" windowSetLayout + +-- | Create a dialog window. Use 'showModal' for a modal dialog. Use +-- the 'visible' property to show\/hide a modeless dialog. +dialog :: Window a -> [Prop (Dialog ())] -> IO (Dialog ()) +dialog parent props + = dialogEx parent (dialogDefaultStyle {- .+. wxNO_FULL_REPAINT_ON_RESIZE -}) props + +-- | Create a dialog window with a certain style. +dialogEx :: Window a -> Style -> [Prop (Dialog ())] -> IO (Dialog ()) +dialogEx parent style props + = feed2 props style $ + initialFrame $ \id rect txt -> \props flags -> + do d <- dialogCreate parent id txt rect flags + set d props + return d + +-- | Show a modal dialog. Take a function as argument that takes a function itself +-- as argument that can be used to end the modal dialog. The argument of this function +-- is returned as the result of the dialog. The result is 'Nothing' when the dialog +-- is dismissed via the system menu. +-- +-- > d <- dialog w [text := "Demo"] +-- > ok <- button d [text := "Ok"] +-- > ... +-- > result <- showModal d (\stop -> set ok [on command := stop (Just 42)]) +-- +showModal :: Dialog b -> ((Maybe a -> IO ()) -> IO ()) -> IO (Maybe a) +showModal dialog f + = do ret <- varCreate Nothing + f (\x -> do{ varSet ret x; dialogEndModal dialog 0} ) + dialogShowModal dialog + varGet ret diff --git a/src/Graphics/UI/WX/Draw.hs b/src/Graphics/UI/WX/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Draw.hs @@ -0,0 +1,219 @@ +{-# OPTIONS -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : Draw + Copyright : (c) Daan Leijen 2003 + License : wxWindows + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + Drawing. + + A /Device Context/ or 'DC', is an instance of 'Drawn', 'Brushed', + 'Literate', and 'Colored'. +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX.Draw + ( + -- * Classes + Drawn, pen, penKind, penWidth, penCap, penJoin, penColor + , Brushed, brush, brushKind, brushColor + -- * Types + , DC, Bitmap + -- * Drawing + , circle, arc, ellipse, ellipticArc + , line, polyline, polygon + , drawPoint, drawRect, roundedRect + , drawText, rotatedText, drawBitmap, drawImage + -- * Internal + , dcWith, dcClear + ) where + +import Graphics.UI.WXCore + + +import Graphics.UI.WX.Types +import Graphics.UI.WX.Attributes +import Graphics.UI.WX.Layout +import Graphics.UI.WX.Classes +import Graphics.UI.WX.Window + + + +{-------------------------------------------------------------------------------- + +--------------------------------------------------------------------------------} +class Drawn w where + pen :: Attr w PenStyle + penKind :: Attr w PenKind + penWidth :: Attr w Int + penCap :: Attr w CapStyle + penJoin :: Attr w JoinStyle + penColor :: Attr w Color + +class Brushed w where + brush :: Attr w BrushStyle + brushKind :: Attr w BrushKind + brushColor :: Attr w Color + +instance Drawn (DC a) where + pen + = newAttr "pen" dcGetPenStyle dcSetPenStyle + + penKind + = mapAttr _penKind (\pstyle x -> pstyle{ _penKind = x }) pen + + penWidth + = mapAttr _penWidth (\pstyle x -> pstyle{ _penWidth = x }) pen + + penCap + = mapAttr _penCap (\pstyle x -> pstyle{ _penCap = x }) pen + + penJoin + = mapAttr _penJoin (\pstyle x -> pstyle{ _penJoin = x }) pen + + penColor + = mapAttr _penColor (\pstyle color -> pstyle{ _penColor = color }) pen + +instance Brushed (DC a) where + brush + = newAttr "brush" dcGetBrushStyle dcSetBrushStyle + + brushKind + = mapAttr _brushKind (\bstyle x -> bstyle{ _brushKind = x }) brush + + brushColor + = mapAttr _brushColor (\bstyle color -> bstyle{ _brushColor = color }) brush + +instance Literate (DC a) where + font + = newAttr "font" dcGetFontStyle dcSetFontStyle + + textColor + = newAttr "textcolor" dcGetTextForeground dcSetTextForeground + + textBgcolor + = newAttr "textbgcolor" dcGetTextBackground dcSetTextForeground + +instance Colored (DC a) where + color + = newAttr "color" (\dc -> get dc penColor) (\dc c -> set dc [penColor := c, textColor := c]) + + bgcolor + = newAttr "bgcolor" (\dc -> get dc brushColor) (\dc c -> set dc [brushColor := c, textBgcolor := c]) + + +-- Save pen/font/brush efficiently. +dcWith :: DC a -> [Prop (DC a)] -> IO b -> IO b +dcWith dc props io + | null props = io + | otherwise = dcEncapsulate dc (do set dc props; io) + +-- | Draw a circle given a center point and radius. +circle :: DC a -> Point -> Int -> [Prop (DC a)] -> IO () +circle dc center radius props + = dcWith dc props (dcDrawCircle dc center radius) + +-- | Draw an arc of a circle. Takes the center of the circle, +-- its radius and a starting and ending point relative to the +-- three-o\'clock position. Angles are in degrees and positive +-- values denote a counter clockwise motion. If the angles are +-- equal, an entire circle is drawn. +arc :: DC a -> Point -> Int -> Double -> Double -> [Prop (DC a)] -> IO () +arc dc center radius start end props + = ellipticArc dc bounds start end props + where + bounds + = rect (pt (pointX center - radius) (pointY center - radius)) (sz (2*radius) (2*radius)) +{- + = dcWith dc props (dcDrawArc dc center (point start) (point end) ) + where + point angle + = let radians = (2*pi*angle)/360 + x = px center + round (cos radians * fromIntegral radius) + y = py center - round (sin radians * fromIntegral radius) + in (pt x y) +-} + +-- | Draw an ellipse, bounded by a certain rectangle. +ellipse :: DC a -> Rect -> [Prop (DC a)] -> IO () +ellipse dc rect props + = dcWith dc props (dcDrawEllipse dc rect) + +-- | Draw an elliptic arc. Takes the bounding rectangle, +-- and a starting and ending point relative to the +-- three-o\'clock position from the center of the rectangle. +-- Angles are in degrees and positive +-- values denote a counter clockwise motion. If the angles are +-- equal, an entire ellipse is drawn. +ellipticArc :: DC a -> Rect -> Double -> Double -> [Prop (DC a)] -> IO () +ellipticArc dc rect start end props + = dcWith dc props (dcDrawEllipticArc dc rect start end) + +-- | Draw a line. +line :: DC a -> Point -> Point -> [Prop (DC a)] -> IO () +line dc start end props + = dcWith dc props (dcDrawLine dc start end) + +-- | Draw a polyline. +polyline :: DC a -> [Point] -> [Prop (DC a)] -> IO () +polyline dc points props + = dcWith dc props (drawLines dc points) + +-- | Draw a polygon. The polygon is filled with the odd-even rule. +-- Note that the polygon is automatically closed. +polygon :: DC a -> [Point] -> [Prop (DC a)] -> IO () +polygon dc points props + = dcWith dc props (drawPolygon dc points) + + +-- | Draw a single point. +drawPoint :: DC a -> Point -> [Prop (DC a)] -> IO () +drawPoint dc center props + = dcWith dc props (dcDrawPoint dc center) + +-- | Draw a rectangle. +drawRect :: DC a -> Rect -> [Prop (DC a)] -> IO () +drawRect dc rect props + = dcWith dc props (dcDrawRectangle dc rect) + +-- | Draw a rectangle with rounded corners. The corners are +-- quarter circles with the given radius. +-- If radius is positive, the value is assumed to be the radius of the rounded corner. +-- If radius is negative, the absolute value is assumed to be the proportion of the smallest +-- dimension of the rectangle. This means that the corner can be a sensible size relative to +-- the size of the rectangle, and also avoids the strange effects X produces when the corners +-- are too big for the rectangle. +roundedRect :: DC a -> Rect -> Double -> [Prop (DC a)] -> IO () +roundedRect dc rect radius props + = dcWith dc props (dcDrawRoundedRectangle dc rect radius) + +-- | Draw text. +drawText :: DC a -> String -> Point -> [Prop (DC a)] -> IO () +drawText dc text point props + = dcWith dc props (dcDrawText dc text point) + +-- | Draw rotated text. Takes an angle in degrees relative to the +-- three-o\'clock position. +rotatedText :: DC a -> String -> Point -> Double -> [Prop (DC a)] -> IO () +rotatedText dc text point angle props + = dcWith dc props (dcDrawRotatedText dc text point angle) + +-- | Draw a bitmap. Takes a bitmap, a point and a boolean +-- that is 'True' when the bitmap is drawn with a transparency mask. +drawBitmap :: DC a -> Bitmap () -> Point -> Bool -> [Prop (DC a)] -> IO () +drawBitmap dc bitmap point transparent props + = if bitmap == nullBitmap || objectIsNull bitmap + then return () + else do ok <- bitmapOk bitmap + if not ok + then return () + else dcWith dc props (dcDrawBitmap dc bitmap point transparent) + +-- | Draw an image. +drawImage :: DC a -> Image b -> Point -> [Prop (DC a)] -> IO () +drawImage dc image pt props + = do bm <- bitmapCreateFromImage image (-1) + drawBitmap dc bm pt False props + bitmapDelete bm diff --git a/src/Graphics/UI/WX/Events.hs b/src/Graphics/UI/WX/Events.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Events.hs @@ -0,0 +1,341 @@ +{-# OPTIONS -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : Events + Copyright : (c) Daan Leijen 2003 + (c) Shelarcy (shelarcy@gmail.com) 2006 + License : wxWindows + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + Define event handling. Events are parametrised by the widget that can + correspond to a certain event and the type of the event handler. + For example, the 'resize' event has type: + + > Reactive w => Event w (IO ()) + + This means that all widgets in the 'Reactive' class can respond to + 'resize' events. (and since 'Window' is an instance of this class, this + means that basically all visible widgets are reactive). + + An @Event w a@ can be transformed into an attribute of type 'Attr' @w a@ + using the 'on' function. + + > do f <- frame [text := "test"] + > set f [on resize := set f [text := "resizing"]] + + For convenience, the 'mouse' and 'keyboard' have a serie of /event filters/: + 'click', 'drag', 'enterKey', 'charKey', etc. These filters are write-only + and do not overwrite any previous mouse or keyboard handler but all stay + active at the same time. However, all filter will be overwritten again + when 'mouse' or 'keyboard' is set again. For example, the following program + makes sense: + + > set w [on click := ..., on drag := ...] + + But in the following program, only the handler for 'mouse' will be called: + + > set w [on click := ..., on mouse := ...] + + If you want to set the 'mouse' later but retain the old event filters, + you can first read the current 'mouse' handler and call it in the + new handler (and the same for the 'keyboard' of course). This implemenation + technique is used to implement event filters themselves and is also + very useful when setting an event handler for a 'closing' event: + + > set w [on closing :~ \previous -> do{ ...; previous }] + + Note that you should call 'propagateEvent' (or 'Graphics.UI.WXCore.Events.skipCurrentEvent') whenever + you do not process the event yourself in an event handler. This propagates + the event to the parent event handlers and give them a chance to + handle the event in an appropiate way. This gives another elegant way to install + a 'closing' event handler: + + > set w [on closing := do{ ...; propagateEvent }] +-} + +{- + Modification History: + When Who What + 300806 jeremy.odonoghue@gmail.com Add support for calendar event + (on behalf of shelarcy@gmail.com) +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX.Events + ( -- * Event + Event + , on + , mapEvent + , propagateEvent + -- * Basic events + -- ** Selecting + , Selecting, select + -- ** Commanding + , Commanding, command + -- ** Reactive + , Reactive + , mouse, keyboard + , closing, idle, resize, focus, activate + , Paint + , paint, paintRaw, repaint + -- * Event filters + -- ** Mouse filters + , enter, leave, motion, drag + , click, unclick, doubleClick + , clickRight, unclickRight + -- * Keyboard event filters + , anyKey, key, charKey + , enterKey,tabKey,escKey,helpKey + , delKey,homeKey,endKey + , pgupKey,pgdownKey + , downKey,upKey,leftKey,rightKey + , rebind + -- * Types + -- ** Modifiers + , Modifiers(..) + , showModifiers + , noneDown, justShift, justAlt, justControl, justMeta, isNoneDown + , isNoShiftAltControlDown + + -- ** Mouse events + , EventMouse (..) + , showMouse + , mousePos, mouseModifiers + + -- ** Calender event + , EventCalendar(..) + , calendarEvent + + -- ** Keyboard events + , EventKey (..), Key(..) + , keyKey, keyModifiers, keyPos + , showKey, showKeyModifiers + -- * Internal + , newEvent + ) where + +import Graphics.UI.WXCore hiding (Event) + +import Graphics.UI.WX.Types +import Graphics.UI.WX.Attributes +import Graphics.UI.WX.Layout +import Graphics.UI.WX.Classes + +{-------------------------------------------------------------------- + Basic events +--------------------------------------------------------------------} +-- | An event for a widget @w@ that expects an event handler of type @a@. +data Event w a = Event (Attr w a) + +-- | Transform an event to an attribute. +on :: Event w a -> Attr w a +on (Event attr) + = attr + +-- | Change the event type. +mapEvent :: (a -> b) -> (a -> b -> a) -> Event w a -> Event w b +mapEvent get set (Event attr) + = Event (mapAttr get set attr) + +{-------------------------------------------------------------------- + Event classes +--------------------------------------------------------------------} +-- | 'Selecting' widgets fire a 'select' event when an item is selected. +class Selecting w where + -- | A 'select' event is fired when an item is selected. + select :: Event w (IO ()) + +-- | 'Commanding' widgets fire a 'command' event. +class Commanding w where + -- | A commanding event, for example a button press. + command :: Event w (IO ()) + +-- | 'Reactive' widgets are almost all visible widgets on the screen. +class Reactive w where + mouse :: Event w (EventMouse -> IO ()) + keyboard :: Event w (EventKey -> IO ()) + + closing :: Event w (IO ()) + idle :: Event w (IO Bool) + resize :: Event w (IO ()) + focus :: Event w (Bool -> IO ()) + activate :: Event w (Bool -> IO ()) + +-- | 'Paint' widgets can serve as a canvas. +-- /Note:/ it is illegal to use both a 'paint' and 'paintRaw' +-- event handler at the same widget. +class Paint w where + -- | Paint double buffered to a device context. The context is always + -- cleared before drawing. Takes the current view rectangle (adjusted + -- for scrolling) as an argument. + paint :: Event w (DC () -> Rect -> IO ()) + -- | Paint directly to the on-screen device context. Takes the current + -- view rectangle and a list of dirty rectangles as arguments.\ + paintRaw :: Event w (DC () -> Rect -> [Rect] -> IO ()) + -- | Emit a paint event to the specified widget. + repaint :: w -> IO () + + +{-------------------------------------------------------------------- + Mouse event filters +--------------------------------------------------------------------} +click :: Reactive w => Event w (Point -> IO ()) +click + = mouseFilter "click" filter + where + filter (MouseLeftDown point mod) = isNoShiftAltControlDown mod + filter other = False + +unclick :: Reactive w => Event w (Point -> IO ()) +unclick + = mouseFilter "unclick" filter + where + filter (MouseLeftUp point mod) = isNoShiftAltControlDown mod + filter other = False + +doubleClick :: Reactive w => Event w (Point -> IO ()) +doubleClick + = mouseFilter "doubleClick" filter + where + filter (MouseLeftDClick point mod) = isNoShiftAltControlDown mod + filter other = False + +drag :: Reactive w => Event w (Point -> IO ()) +drag + = mouseFilter "drag" filter + where + filter (MouseLeftDrag point mod) = isNoShiftAltControlDown mod + filter other = False + +motion :: Reactive w => Event w (Point -> IO ()) +motion + = mouseFilter "motion" filter + where + filter (MouseMotion point mod) = isNoShiftAltControlDown mod + filter other = False + +clickRight :: Reactive w => Event w (Point -> IO ()) +clickRight + = mouseFilter "clickRight" filter + where + filter (MouseRightDown point mod) = isNoShiftAltControlDown mod + filter other = False + +unclickRight :: Reactive w => Event w (Point -> IO ()) +unclickRight + = mouseFilter "unclickRight" filter + where + filter (MouseRightUp point mod) = isNoShiftAltControlDown mod + filter other = False + +enter :: Reactive w => Event w (Point -> IO ()) +enter + = mouseFilter "enter" filter + where + filter (MouseEnter point mod) = True + filter other = False + +leave :: Reactive w => Event w (Point -> IO ()) +leave + = mouseFilter "leave" filter + where + filter (MouseLeave point mod) = True + filter other = False + +mouseFilter :: Reactive w => String -> (EventMouse -> Bool) -> Event w (Point -> IO ()) +mouseFilter name filter + = mapEvent get set mouse + where + get prev x + = ioError (userError ("WX.Events: the " ++ name ++ " event is write-only.")) + + set prev new mouseEvent + = if (filter mouseEvent) + then new (mousePos mouseEvent) + else prev mouseEvent + +{-------------------------------------------------------------------- + Keyboard filter events +--------------------------------------------------------------------} +rebind :: Event w (IO ()) -> Event w (IO ()) +rebind event + = mapEvent get set event + where + get prev + = prev + + set new prev + = new + +enterKey,tabKey,escKey,helpKey,delKey,homeKey,endKey :: Reactive w => Event w (IO ()) +pgupKey,pgdownKey,downKey,upKey,leftKey,rightKey :: Reactive w => Event w (IO ()) +enterKey = key KeyReturn +tabKey = key KeyTab +escKey = key KeyEscape +helpKey = key KeyHelp +delKey = key KeyDelete +homeKey = key KeyHome +endKey = key KeyEnd +pgupKey = key KeyPrior +pgdownKey = key KeyNext +downKey = key KeyDown +upKey = key KeyUp +leftKey = key KeyLeft +rightKey = key KeyRight + +charKey :: Reactive w => Char -> Event w (IO ()) +charKey c + = key (KeyChar c) + +key :: Reactive w => Key -> Event w (IO ()) +key k + = keyboardFilter "key" filter + where + filter (EventKey x mod pt) = k==x + + +anyKey :: Reactive w => Event w (Key -> IO ()) +anyKey + = keyboardFilter1 "anyKey" (const True) + + +keyboardFilter :: Reactive w => String -> (EventKey -> Bool) -> Event w (IO ()) +keyboardFilter name filter + = mapEvent get set keyboard + where + get prev + = ioError (userError ("WX.Events: the " ++ name ++ " event is write-only.")) + + set prev new keyboardEvent + = do when (filter keyboardEvent) new + prev keyboardEvent + +keyboardFilter1 :: Reactive w => String -> (EventKey -> Bool) -> Event w (Key -> IO ()) +keyboardFilter1 name filter + = mapEvent get set keyboard + where + get prev key + = ioError (userError ("WX.Events: the " ++ name ++ " event is write-only.")) + + set prev new keyboardEvent + = if (filter keyboardEvent) + then new (keyKey keyboardEvent) + else prev keyboardEvent + + +{-------------------------------------------------------------------- + Calender event filters +--------------------------------------------------------------------} +calendarEvent :: Event (CalendarCtrl a) (EventCalendar -> IO ()) +calendarEvent + = newEvent "calendarEvent" calendarCtrlGetOnCalEvent calendarCtrlOnCalEvent + + +{-------------------------------------------------------------------- + Generic event creators +-------------------------------------------------------------------} +-- | Create a new event from a get and set function. +newEvent :: String -> (w -> IO a) -> (w -> a -> IO ()) -> Event w a +newEvent name getter setter + = Event (newAttr name getter setter) diff --git a/src/Graphics/UI/WX/Frame.hs b/src/Graphics/UI/WX/Frame.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Frame.hs @@ -0,0 +1,284 @@ +{-# OPTIONS -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : Frame + Copyright : (c) Daan Leijen 2003 + License : wxWindows + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + Frames. + + * Instances: 'HasImage', 'Form', 'Closeable', 'Framed' -- + 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', + 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. + + +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX.Frame + ( -- * Frames + Frame, frame, frameFixed, frameTool, frameEx + -- * MDI Frames + , MDIParentFrame, MDIChildFrame + , mdiParentFrame, mdiChildFrame + , mdiParentFrameEx, mdiChildFrameEx + -- ** Operations + , activeChild, activateNext, activatePrevious, arrangeIcons + , cascade, tile + -- * Internal + , initialFrame, initialResizeable, initialMaximizeable, initialMinimizeable, initialCloseable + ) where + +import Graphics.UI.WXCore + +import Graphics.UI.WX.Types +import Graphics.UI.WX.Attributes +import Graphics.UI.WX.Layout +import Graphics.UI.WX.Classes +import Graphics.UI.WX.Window +import Graphics.UI.WX.Events + +defaultStyle + = frameDefaultStyle -- .+. wxTAB_TRAVERSAL -- .+. wxNO_FULL_REPAINT_ON_RESIZE + +-- | Create a top-level frame window. +frame :: [Prop (Frame ())] -> IO (Frame ()) +frame props + = frameEx defaultStyle props objectNull + +-- | Create a top-level frame window that is not resizeable. +frameFixed :: [Prop (Frame ())] -> IO (Frame ()) +frameFixed props + = frameEx (defaultStyle .-. wxMAXIMIZE_BOX .-. wxRESIZE_BORDER) props objectNull + +-- | Create a tool window; floats on the parent and has a small caption. +frameTool :: [Prop (Frame ())] -> Window a -> IO (Frame ()) +frameTool props parent + = frameEx (defaultStyle .-. wxFRAME_TOOL_WINDOW .-. wxFRAME_FLOAT_ON_PARENT) props parent + + +-- | Create a top-level frame window in a custom style. +frameEx :: Style -> [Prop (Frame ())] -> Window a -> IO (Frame ()) +frameEx style props parent + = feed2 props style $ + initialFrame $ \id rect txt -> \props style -> + do f <- frameCreate parent id txt rect style + let initProps = (if (containsProperty visible props) + then [] else [visible := True]) ++ + (if (containsProperty bgcolor props) + then [] else [bgcolor := colorSystem Color3DFace]) + set f initProps + set f props + return f + + +-- | initial Frame flags +initialFrame :: (Id -> Rect -> String -> [Prop (Window w)] -> Style -> a) -> [Prop (Window w)] -> Style -> a +initialFrame cont + = initialContainer $ \id rect -> + initialText $ \txt -> + initialResizeable $ + initialMinimizeable $ + initialMaximizeable $ + initialCloseable $ + initialClipChildren $ + initialFullRepaintOnResize $ + cont id rect txt + + +-- The icon of a frame. +instance Pictured (Frame a) where + picture + = writeAttr "picture" frameSetIconFromFile + + +instance Form (Frame a) where + layout + = writeAttr "layout" windowSetLayout + +instance Closeable (Frame a) where + close f + = unitIO (windowClose f True {- force? -}) + + +instance Framed (Frame a) where + resizeable + = windowResizeable + + maximizeable + = windowMaximizeable + + minimizeable + = windowMinimizeable + + closeable + = windowCloseable + + +instance Framed (Dialog a) where + resizeable + = windowResizeable + + maximizeable + = windowMaximizeable + + minimizeable + = windowMinimizeable + + closeable + = windowCloseable + + + +{-------------------------------------------------------------------------- + MDI frames +--------------------------------------------------------------------------} +-- | Create an MDI parent frame. +mdiParentFrame :: [Prop (MDIParentFrame ())] -> IO (MDIParentFrame ()) +mdiParentFrame props + = mdiParentFrameEx objectNull defaultStyle props + + +-- | Create an MDI parent frame with a custom style. +mdiParentFrameEx :: Window a -> Style -> [Prop (MDIParentFrame ())] -> IO (MDIParentFrame ()) +mdiParentFrameEx parent stl props + = feed2 props stl $ + initialFrame $ \id rect txt -> \props stl -> + do f <- mdiParentFrameCreate parent id txt rect stl + let initProps = (if (containsProperty visible props) + then [] else [visible := True]) ++ + (if (containsProperty bgcolor props) + then [] else [bgcolor := colorSystem Color3DFace]) + set f initProps + set f props + return f + + +-- | Create a MDI child frame. +mdiChildFrame :: MDIParentFrame a -> [Prop (MDIChildFrame ())] -> IO (MDIChildFrame ()) +mdiChildFrame parent props + = mdiChildFrameEx parent defaultStyle props + +-- | Create a MDI child frame with a custom style. +mdiChildFrameEx :: MDIParentFrame a -> Style -> [Prop (MDIChildFrame ())] -> IO (MDIChildFrame ()) +mdiChildFrameEx parent stl props + = feed2 props stl $ + initialFrame $ \id rect txt -> \props stl -> + do f <- mdiChildFrameCreate parent id txt rect stl + let initProps = (if (containsProperty visible props) + then [] else [visible := True]) ++ + (if (containsProperty bgcolor props) + then [] else [bgcolor := colorSystem Color3DFace]) + set f initProps + set f props + return f + + + +-- | Return the active child frame ('objectIsNull' when no child is active) +activeChild :: ReadAttr (MDIParentFrame a) (MDIChildFrame ()) +activeChild = readAttr "activeChild" mdiParentFrameGetActiveChild + +-- | Activate the next child frame. +activateNext :: MDIParentFrame a -> IO () +activateNext = mdiParentFrameActivateNext + +-- | Activate the previous child frame +activatePrevious :: MDIParentFrame a -> IO () +activatePrevious = mdiParentFrameActivatePrevious + +-- | Arrange iconized mdi child frames. +arrangeIcons :: MDIParentFrame a -> IO () +arrangeIcons = mdiParentFrameArrangeIcons + +-- | Cascade the child frames. +cascade :: MDIParentFrame a -> IO () +cascade = mdiParentFrameCascade + +-- | Tile the child frames +tile :: MDIParentFrame a -> IO () +tile = mdiParentFrameTile + + +{-------------------------------------------------------------------------- + Framed instances +--------------------------------------------------------------------------} +-- | Display a resize border on a 'Frame' or 'Dialog' window. Also enables or +-- disables the the maximize box. +-- This attribute must be set at creation time. +windowResizeable :: CreateAttr (Window a) Bool +windowResizeable + = reflectiveAttr "resizeable" getFlag setFlag + where + getFlag w + = do s <- get w style + return (bitsSet wxRESIZE_BORDER s) + setFlag w resize + = set w [style :~ \stl -> if resize + then stl .+. wxRESIZE_BORDER .+. wxMAXIMIZE_BOX + else stl .-. wxRESIZE_BORDER .-. wxMAXIMIZE_BOX] + +-- | Helper function that transforms the style accordding +-- to the 'windowResizable' flag in of the properties +initialResizeable :: ([Prop (Window w)] -> Style -> a) -> [Prop (Window w)] -> Style -> a +initialResizeable + = withStyleProperty windowResizeable (wxRESIZE_BORDER .+. wxMAXIMIZE_BOX) + + +-- | Display a maximize box on a 'Frame' or 'Dialog' window. +-- This attribute must be set at creation time. +windowMaximizeable :: CreateAttr (Window a) Bool +windowMaximizeable + = reflectiveAttr "maximizeable" getFlag setFlag + where + getFlag w + = do s <- get w style + return (bitsSet wxMAXIMIZE_BOX s) + setFlag w max + = set w [style :~ \stl -> if max then stl .+. wxMAXIMIZE_BOX else stl .-. wxMAXIMIZE_BOX] + +-- | Helper function that transforms the style accordding +-- to the 'windowMaximizable' flag in of the properties +initialMaximizeable :: ([Prop (Window w)] -> Style -> a) -> [Prop (Window w)] -> Style -> a +initialMaximizeable + = withStyleProperty windowMaximizeable wxMAXIMIZE_BOX + + +-- | Display a minimize box on a 'Frame' or 'Dialog' window. +-- This attribute must be set at creation time. +windowMinimizeable :: CreateAttr (Window a) Bool +windowMinimizeable + = reflectiveAttr "minimizeable" getFlag setFlag + where + getFlag w + = do s <- get w style + return (bitsSet wxMINIMIZE_BOX s) + setFlag w min + = set w [style :~ \stl -> if min then stl .+. wxMINIMIZE_BOX else stl .-. wxMINIMIZE_BOX] + +-- | Helper function that transforms the style accordding +-- to the 'windowMinimizable' flag in of the properties +initialMinimizeable :: ([Prop (Window w)] -> Style -> a) -> [Prop (Window w)] -> Style -> a +initialMinimizeable + = withStyleProperty windowMinimizeable wxMINIMIZE_BOX + + +-- | Display a close box on a 'Frame' or 'Dialog' window. +-- This attribute must be set at creation time. +windowCloseable :: CreateAttr (Window a) Bool +windowCloseable + = reflectiveAttr "closeable" getFlag setFlag + where + getFlag w + = do s <- get w style + return (bitsSet wxCLOSE_BOX s) + setFlag w min + = set w [style :~ \stl -> if min then stl .+. wxCLOSE_BOX else stl .-. wxCLOSE_BOX] + +-- | Helper function that transforms the style accordding +-- to the 'windowMinimizable' flag in of the properties +initialCloseable :: ([Prop (Window w)] -> Style -> a) -> [Prop (Window w)] -> Style -> a +initialCloseable + = withStyleProperty windowCloseable wxCLOSE_BOX diff --git a/src/Graphics/UI/WX/Layout.hs b/src/Graphics/UI/WX/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Layout.hs @@ -0,0 +1,43 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------------------- +{-| Module : Layout + Copyright : (c) Daan Leijen 2003 + License : BSD-style + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + Just re-exports functionality of "Graphics.UI.WXCore.Layout". See that module + for a description of layout combinators. + + Any object in the 'Form' class has a 'layout' attribute to specify the + layout. Here is a short example: + + > do f <- frame [text := "layout demo"] + > q <- button f [text := "quit", on command := close f] + > set f [layout := margin 10 $ + > floatCentre $ + > column 5 [label "hi",widget q]] + +-} +----------------------------------------------------------------------------------------- +module Graphics.UI.WX.Layout + ( + -- * Classes + Form, layout + -- * Layout + , module Graphics.UI.WXCore.Layout + ) where + +import Graphics.UI.WXCore.Layout +import Graphics.UI.WX.Types +import Graphics.UI.WX.Attributes + +{-------------------------------------------------------------------- + +--------------------------------------------------------------------} +-- | Forms can contain other widgets. +class Form w where + -- | Set the layout of the child widgets. + layout :: Attr w Layout diff --git a/src/Graphics/UI/WX/Media.hs b/src/Graphics/UI/WX/Media.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Media.hs @@ -0,0 +1,118 @@ +{-# OPTIONS -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : Media + Copyright : (c) Daan Leijen 2003 + Copyright : (c) shelarcy 2007 + License : wxWindows + + Maintainer : shelarcy@gmail.com + Stability : provisional + Portability : portable + + Images, Media, Sounds, and action! +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX.Media + ( -- * Media + Media(..) + + -- * Sound + , Wave, sound, playLoop, playWait + -- * Images + , image, imageCreateFromFile, imageCreateFromPixels, imageGetPixels + , imageCreateFromPixelArray, imageGetPixelArray + + -- * Bitmaps + , bitmap, bitmapCreateFromFile, bitmapFromImage + ) where + +import System.IO.Unsafe( unsafePerformIO ) +import Graphics.UI.WXCore +import Graphics.UI.WX.Types( Var, varGet, varSet, varCreate ) +import Graphics.UI.WX.Attributes +import Graphics.UI.WX.Classes + +{-------------------------------------------------------------------- + Bitmaps +--------------------------------------------------------------------} +-- | Return a managed bitmap object. Bitmaps are abstract images used +-- for drawing to a device context. The file path should point to +-- a valid bitmap file, normally a @.ico@, @.bmp@, @.xpm@, or @.png@, +-- but any file format supported by |Image| is correctly loaded. +-- +-- Instances: 'Sized'. +bitmap :: FilePath -> Bitmap () +bitmap fname + = unsafePerformIO $ bitmapCreateFromFile fname + +instance Sized (Bitmap a) where + size = newAttr "size" bitmapGetSize bitmapSetSize + +-- | Create a bitmap from an image with the same color depth. +bitmapFromImage :: Image a -> IO (Bitmap ()) +bitmapFromImage image + = bitmapCreateFromImage image (-1) + +{-------------------------------------------------------------------- + Images +--------------------------------------------------------------------} +-- | Return a managed image. Images are platform independent representations +-- of pictures, using an array of rgb pixels. See "Graphics.UI.WXCore.Image" for +-- lowlevel pixel manipulation. The file path should point to +-- a valid image file, like @.jpg@, @.bmp@, @.xpm@, or @.png@, for example. +-- +-- Instances: 'Sized'. +image :: FilePath -> Image () +image fname + = unsafePerformIO $ imageCreateFromFile fname + +instance Sized (Image a) where + size = newAttr "size" imageGetSize imageRescale + +{-------------------------------------------------------------------- + Media +--------------------------------------------------------------------} +-- | Abstract layer between 'MediaCtrl' and 'Sound'. This class intends to +-- avoid breaking backward-compatibility. +class Media w where + -- | If use this method with 'Sound', play a sound fragment asynchronously. + -- If use this method with 'MediaCtrl', play media that is loaded by + -- 'mediaCtrlLoad'. + play :: w -> IO () + stop :: w -> IO () + +{-------------------------------------------------------------------- + Sounds +--------------------------------------------------------------------} +-- | Return a managed sound object. The file path points to +-- a valid sound file, normally a @.wav@. +sound :: FilePath -> Sound () +sound fname + = unsafePerformIO $ soundCreate fname False + +{-# DEPRECATED Wave "Use Sound instead" #-} +-- | Define Wave type synonym for people who are familiar with +-- wxWidgets 2.4.x or lower name. +type Wave a = Sound a + +instance Media (Sound a) where + play sound = + if (div wxVersion 100) == 24 + then unitIO (soundPlayCompatible sound True False) + else unitIO (soundPlay sound wxSOUND_ASYNC) + stop = undefined + +-- | Play a sound fragment repeatedly (and asynchronously). +playLoop :: Sound a -> IO () +playLoop sound + = if (div wxVersion 100) == 24 + then unitIO (soundPlayCompatible sound True True) + else unitIO (soundPlay sound $ wxSOUND_ASYNC .+. wxSOUND_LOOP) + +-- | Play a sound fragment synchronously (i.e. wait till completion). +playWait :: Sound a -> IO () +playWait sound + = if (div wxVersion 100) == 24 + then unitIO (soundPlayCompatible sound False False) + else unitIO (soundPlay sound wxSOUND_SYNC) + diff --git a/src/Graphics/UI/WX/Menu.hs b/src/Graphics/UI/WX/Menu.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Menu.hs @@ -0,0 +1,621 @@ +{-# OPTIONS -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : Menu + Copyright : (c) Daan Leijen 2003 + (c) Shelarcy (shelarcy@gmail.com) 2006 + License : wxWindows + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + Defines Menus, toolbars, and statusbars. + + The function 'menuPane' is used to create a menu + that can contain 'menuItem's. Menu items can contain event handlers + using ('on' 'command'), but they can also be set, using the 'menu' + function, on a frame or (mdi) window so that the menu command is handled + in the context of the active window instead of the context of the + entire application. + + > do frame <- frame [text := "Demo"] + > file <- menuPane [text := "&File"] + > mclose <- menuItem file [text := "&Close\tCtrl+C", help := "Close the document"] + > set frame [menuBar := [file] + > ,on (menu mclose) := ...] + +-} +{- + Modification History: + When Who What + 300806 jeremy.odonoghue@gmail.com Add support for toolbar divider + (on behalf of shelarcy@gmail.com) +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX.Menu + ( -- * Menu + -- ** Menu containers + MenuBar, Menu, menuBar, menuPopup, menuPane, menuHelp + -- ** Menu events + , menu, menuId + -- ** Menu items + , MenuItem, menuItem, menuQuit, menuAbout, menuItemEx + , menuLine, menuSub, menuRadioItem + -- * Tool bar + , ToolBar, toolBar, toolBarEx + , ToolBarItem, toolMenu, toolItem, toolControl, tool + -- * Status bar + , StatusField, statusBar, statusField, statusWidth + -- * Deprecated + , menuList, menubar, statusbar + ) where + +import Data.Char( toUpper ) +import Data.List( partition, intersperse ) +import System.IO.Unsafe (unsafePerformIO) +import Foreign.Ptr( nullPtr ) +import Graphics.UI.WXCore hiding (Event) + +import Graphics.UI.WX.Types +import Graphics.UI.WX.Attributes +import Graphics.UI.WX.Layout +import Graphics.UI.WX.Classes +import Graphics.UI.WX.Events + + +{-------------------------------------------------------------------------------- + Menubar +--------------------------------------------------------------------------------} +-- | /Deprecated/: use 'menuBar'. +menubar :: WriteAttr (Frame a) [Menu ()] +menubar + = menuBar + +-- | Set the menu bar of a frame. +menuBar :: WriteAttr (Frame a) [Menu ()] +menuBar + = writeAttr "menubar" setter + where + setter frame menus + = do mb <- menuBarCreate wxMB_DOCKABLE + mapM_ (append mb) menus + frameSetMenuBar frame mb + -- set delayed menu handlers on the frame + mapM_ (evtHandlerSetAndResetMenuCommands frame) menus + -- work around menu bug in wxMac 2.5.1 + vis <- windowIsShown frame + if (vis && wxToolkit == WxMac && (div wxVersion 100) >= 25) + then do windowHide frame + windowShow frame + return () + else return () + + append mb menu + = do title <- menuGetTitle menu + menuSetTitle menu "" + menuBarAppend mb menu title + +-- | Show a popup menu for a certain window. +menuPopup :: Menu b -> Point -> Window a -> IO () +menuPopup menu pt parent + = do windowPopupMenu parent menu pt + return () + +{-------------------------------------------------------------------------------- + Menu +--------------------------------------------------------------------------------} +-- | /Deprecated/: use 'menuPane'. +menuList :: [Prop (Menu ())] -> IO (Menu ()) +menuList + = menuPane + +-- | Create a new menu with a certain title (corresponds with 'text' attribute). +-- +-- * Instances: 'Textual' +-- +menuPane :: [Prop (Menu ())] -> IO (Menu ()) +menuPane props + = do m <- menuCreate "" wxMENU_TEAROFF + set m props + return m + +-- | Append a /help/ menu item (@"&Help"@). On some platforms, +-- the /help/ menu is handled specially +menuHelp :: [Prop (Menu ())] -> IO (Menu ()) +menuHelp props + = menuPane ([text := "&Help"] ++ props) + +instance Textual (Menu a) where + text + = newAttr "text" menuGetTitle menuSetTitle + +{-------------------------------------------------------------------------------- + Menu items +--------------------------------------------------------------------------------} +-- | Create a submenu item. +menuSub :: Menu b -> Menu a -> [Prop (MenuItem ())] -> IO (MenuItem ()) +menuSub parent menu props + = do id <- idCreate + label <- case (findProperty text "" props) of + Just (txt,_) -> return txt + Nothing -> do title <- menuGetTitle menu + if (null title) + then return "" + else return title + menuSetTitle menu "" -- remove title on submenus + menuAppendSub parent id label menu "" + menuPropagateEvtHandlers menu -- move the evtHandlers to the parent + item <- menuFindItem parent id nullPtr + set item props + return item + +-- | Add a menu seperator. +menuLine :: Menu a -> IO () +menuLine menu + = menuAppendSeparator menu + + +-- | Append a menu item. The label can contain +-- menu accellerators by using an ampersand. It can also contain keyboard accellerators +-- after a tab (@'\\t'@) character. +-- +-- > menuItem menu [text := "&Open\tCtrl+O", help := "Opens an existing document"] +-- +-- You can create a checkable menu item by setting 'checkable' to 'True' in the +-- properties of a menu item. +-- +-- Note: on GTK, it is required to set the 'text' attribute immediately at creation time. +-- +-- * Events: 'menu', 'menuId' +-- +-- * Instances: 'Textual', 'Able', 'Help', 'Checkable', 'Identity', 'Commanding'. +-- +menuItem :: Menu a -> [Prop (MenuItem ())] -> IO (MenuItem ()) +menuItem menu props + = do let kind = case (findProperty checkable False props) of + Just (True,_) -> wxITEM_CHECK + _ -> wxITEM_NORMAL + menuItemKind menu kind props + +-- | Append a radio menu item. These items are 'checkable' by default. +-- A sequence of radio menu items form automatically a group. +-- A different kind of menu item, like a 'menuLine', terminates the group. +-- Note: one sometimes has to set the first selected radio item +-- specifically after setting the "menubar" property, or otherwise the +-- radio item bullet is not displayed on windows. +-- See 'menuItem' for other properties of menu radio items. +menuRadioItem :: Menu a -> [Prop (MenuItem ())] -> IO (MenuItem ()) +menuRadioItem menu props + = menuItemKind menu wxITEM_RADIO ([checked := True] ++ props) + +menuItemKind menu kind props + = do id <- idCreate + let label = case (findProperty text "" props) of + Nothing -> "" + Just (txt,_) -> txt + menuItemEx menu id label kind props + + + +-- | Append an /about/ menu item (@"&About..."@). On some platforms, +-- the /about/ menu is handled specially. +-- +-- * Events: 'menu', 'menuId' +-- +-- * Instances: 'Textual', 'Able', 'Help', 'Checkable', 'Identity', 'Commanding'. +-- +menuAbout :: Menu a -> [Prop (MenuItem ())] -> IO (MenuItem ()) +menuAbout menu props + = menuItemId menu wxID_ABOUT "&About..." props + +-- | Append an /quit/ menu item (@"&Quit\tCtrl+Q"@). On some platforms, +-- the /quit/ menu is handled specially +-- +-- * Events: 'menu', 'menuId' +-- +-- * Instances: 'Textual', 'Able', 'Help', 'Checkable', 'Identity', 'Commanding'. +-- +menuQuit :: Menu a -> [Prop (MenuItem ())] -> IO (MenuItem ()) +menuQuit menu props + = menuItemId menu wxID_EXIT "&Quit\tCtrl+Q" props + +-- | Append a menu item with a specific id and label. +-- +-- * Events: 'menu', 'menuId' +-- +-- * Instances: 'Textual', 'Able', 'Help', 'Checkable', 'Identity', 'Commanding'. +-- +menuItemId :: Menu a -> Id -> String -> [Prop (MenuItem ())] -> IO (MenuItem ()) +menuItemId menu id label props + = menuItemEx menu id label wxITEM_NORMAL props + +-- | Append a menu item with a specific id, label, and kind (like 'wxITEM_CHECK'). +-- +-- * Events: 'menu', 'menuId' +-- +-- * Instances: 'Textual', 'Able', 'Help', 'Checkable', 'Identity', 'Commanding'. +-- +menuItemEx :: Menu a -> Id -> String -> Int -> [Prop (MenuItem ())] -> IO (MenuItem ()) +menuItemEx menu id label kind props + = do if (kind == wxITEM_RADIO) + then menuAppendRadioItem menu id label "" + else menuAppend menu id label "" (kind == wxITEM_CHECK) + item <- menuFindItem menu id nullPtr + set item props + return item + +instance Able (MenuItem a) where + enabled = newAttr "enabled" menuItemIsEnabled menuItemEnable + +instance Textual (MenuItem a) where + text + = reflectiveAttr "text" menuItemGetText menuItemSetText + +instance Help (MenuItem a) where + help = newAttr "help" menuItemGetHelp menuItemSetHelp + +instance Checkable (MenuItem a) where + checkable = reflectiveAttr "checkable" menuItemIsCheckable (\m c -> menuItemSetCheckable m (intFromBool c)) + checked = newAttr "checked" menuItemIsChecked menuItemCheck + +instance Identity (MenuItem a) where + identity = newAttr "identity" menuItemGetId menuItemSetId + +{-------------------------------------------------------------------------------- + Events +--------------------------------------------------------------------------------} +-- | React to menu events. +menu :: MenuItem a -> Event (Window w) (IO ()) +menu item + = let id = unsafePerformIO (get item identity) + in menuId id + +-- | React to a menu event based on identity. +menuId :: Id -> Event (Window w) (IO ()) +menuId id + = newEvent "menu" (\w -> evtHandlerGetOnMenuCommand w id) (\w h -> evtHandlerOnMenuCommand w id h) + +{-------------------------------------------------------------------------------- + Menu commands: + + Ok, we would like to set command handlers in two ways: + 1) As an "on command" on the menu item itself. + 2) With an "on (menu xxx)" on a window. + + Unfortunately, wxWindows does not support method (1) for menus that are + part of a menubar and assumes they are set on using (2) on the associated + frame. We can't tell whether a menu is part of a menubar or popupmenu untill + the user sets it. Thus we both set the eventhandlers always directly on the + top level menu (this is good enough for popup menus) and we maintain + a list of menu item id's and associated event handler as client data on the + top level menu. When the menu is set as part of a menubar, we install the + handlers on the associated frame. +--------------------------------------------------------------------------------} +instance Commanding (MenuItem a) where + command + = newEvent "command" menuItemGetOnCommand menuItemOnCommand + +menuItemGetOnCommand :: MenuItem a -> IO (IO ()) +menuItemGetOnCommand item + = do id <- get item identity + topmenu <- menuItemGetTopMenu item + evtHandlerGetOnMenuCommand topmenu id + +menuItemOnCommand :: MenuItem a -> IO () -> IO () +menuItemOnCommand item io + = do id <- get item identity + topmenu <- menuItemGetTopMenu item + -- always set it on the menu itself (has only effect on popup menus) + evtHandlerOnMenuCommand topmenu id io + -- update the haskell event handler list for delayed frame installation + menuUpdateEvtHandlers topmenu (insert id io) + -- and set it directly on the frame if already instantiated. + frame <- menuGetFrame topmenu + when (not (objectIsNull frame)) (evtHandlerOnMenuCommand frame id io) + where + insert key val [] = [(key,val)] + insert key val ((k,v):xs) | key == k = (key,val):xs + | otherwise = (k,v):insert key val xs + + +-- Propagate the (delayed) event handlers of a submenu to the parent menu. +-- This is necessary for event handlers set on menu items in a submenu that +-- was not yet assigned to a parent menu. +menuPropagateEvtHandlers :: Menu a -> IO () +menuPropagateEvtHandlers menu + = do parent <- menuGetTopMenu menu + handlers <- menuGetEvtHandlers menu + menuSetEvtHandlers menu [] + menuSetEvtHandlers parent handlers + +-- Get associated frame of a menu in a menubar. Returns NULL for popup and sub menus. +menuGetFrame :: Menu a -> IO (Frame ()) +menuGetFrame menu + = do menubar <- menuGetMenuBar menu + if (objectIsNull menubar) + then return objectNull + else menuBarGetFrame menubar + +-- Get top level menu of a menu item (never null) +menuItemGetTopMenu :: MenuItem a -> IO (Menu ()) +menuItemGetTopMenu item + = do menu <- menuItemGetMenu item + menuGetTopMenu menu + +-- Get the top level menu of a possible sub menu +menuGetTopMenu :: Menu a -> IO (Menu ()) +menuGetTopMenu menu + = do parent <- menuGetParent menu + if (objectIsNull parent) + then return (downcastMenu menu) + else menuGetTopMenu parent + +-- Set all menu event handlers on a certain window (EvtHandler) +evtHandlerSetAndResetMenuCommands :: EvtHandler a -> Menu b -> IO () +evtHandlerSetAndResetMenuCommands evtHandler menu + = do handlers <- menuGetEvtHandlers menu + menuSetEvtHandlers menu [] + mapM_ (\(id,io) -> evtHandlerOnMenuCommand evtHandler id io) handlers + +-- Update the menu event handler list. +menuUpdateEvtHandlers menu f + = do hs <- menuGetEvtHandlers menu + menuSetEvtHandlers menu (f hs) + +menuGetEvtHandlers :: Menu a -> IO [(Id,IO ())] +menuGetEvtHandlers menu + = do mbHandlers <- unsafeEvtHandlerGetClientData menu + case mbHandlers of + Nothing -> return [] + Just hs -> return hs + +menuSetEvtHandlers :: Menu a -> [(Id,IO ())] -> IO () +menuSetEvtHandlers menu hs + = evtHandlerSetClientData menu (return ()) hs + + +{-------------------------------------------------------------------------------- + Toolbar +--------------------------------------------------------------------------------} +-- | Create a toolbar window with a divider and text labels. +-- Normally, you can use 'toolMenu' to add tools in the toolbar +-- that behave like normal menu items. +-- +-- > tbar <- toolBar f [] +-- > toolMenu tbar open "Open" "open.png" [] +-- > toolMenu tbar about "About" "about.png" [] +-- +toolBar :: Frame a -> [Prop (ToolBar ())] -> IO (ToolBar ()) +toolBar parent props + = toolBarEx parent True True props + +-- | Create a toolbar window. The second argument specifies whether text labels +-- should be shown, and the third argument whether a divider line is present +-- above the toolbar. +toolBarEx :: Frame a -> Bool -> Bool -> [Prop (ToolBar ())] -> IO (ToolBar ()) +toolBarEx parent showText showDivider props + = do let style = ( wxTB_DOCKABLE .+. wxTB_FLAT + .+. (if showText then wxTB_TEXT else 0) + .+. (if showDivider then 0 else wxTB_NODIVIDER) + ) + t <- toolBarCreate parent idAny rectNull style + frameSetToolBar parent t + {- + t <- frameCreateToolBar parent style + -} + set t props + return t + +-- | A tool in a toolbar. +-- +-- * Events: 'tool' +-- +-- * Instances: 'Textual', 'Able', 'Help', 'Tipped', 'Checkable', 'Identity', 'Commanding'. +-- +data ToolBarItem = ToolBarItem (ToolBar ()) Id Bool + +instance Able ToolBarItem where + enabled + = newAttr "enabled" getter setter + where + getter (ToolBarItem toolbar id isToggle) + = toolBarGetToolEnabled toolbar id + + setter (ToolBarItem toolbar id isToggle) enable + = toolBarEnableTool toolbar id enable + + +instance Tipped ToolBarItem where + tooltip + = newAttr "tooltip" getter setter + where + getter (ToolBarItem toolbar id isToggle) + = toolBarGetToolShortHelp toolbar id + + setter (ToolBarItem toolbar id isToggle) txt + = toolBarSetToolShortHelp toolbar id txt + +instance Help ToolBarItem where + help + = newAttr "help" getter setter + where + getter (ToolBarItem toolbar id isToggle) + = toolBarGetToolLongHelp toolbar id + + setter (ToolBarItem toolbar id isToggle) txt + = toolBarSetToolLongHelp toolbar id txt + + +instance Checkable ToolBarItem where + checkable + = readAttr "checkable" getter + where + getter (ToolBarItem toolbar id isToggle) + = return isToggle + + checked + = newAttr "checked" getter setter + where + getter (ToolBarItem toolbar id isToggle) + = toolBarGetToolState toolbar id + + setter (ToolBarItem toolbar id isToggle) toggle + = toolBarToggleTool toolbar id toggle + + +instance Identity ToolBarItem where + identity + = readAttr "identity" getter + where + getter (ToolBarItem toolbar id isToggle) + = return id + + +instance Commanding ToolBarItem where + command + = newEvent "command" getter setter + where + getter (ToolBarItem toolbar id isToggle) + = evtHandlerGetOnMenuCommand toolbar id + + setter (ToolBarItem toolbar id isToggle) io + = evtHandlerOnMenuCommand toolbar id io + +-- | React on tool event. (normally handled by 'menu' though, so only use this +-- for orphan toolbar items). +tool :: ToolBarItem -> Event (Window w) (IO ()) +tool (ToolBarItem toolbar id isToggle) + = newEvent "tool" getter setter + where + getter w + = evtHandlerGetOnMenuCommand w id + setter w io + = evtHandlerOnMenuCommand w id io + +-- | Create a tool bar item based on a menu. Takes a a relevant menu +-- item, a label and an image file (bmp,png,gif,ico,etc.) as arguments. The image +-- file is normally 16x15 pixels. +-- The toolbar item will fire the relevant menu items just as if the menu has been selected. +-- Checkable menus will give a checkable toolbar item. Beware though that checkable tools +-- normally require a specific @on command@ handler to keep them synchronised with the +-- corresponding menu item. +toolMenu :: ToolBar a -> MenuItem a -> String -> FilePath -> [Prop ToolBarItem] -> IO ToolBarItem +toolMenu toolbar menuitem label bitmapPath props + = do isToggle <- get menuitem checkable + id <- get menuitem identity + lhelp <- get menuitem help + shelp <- get menuitem help + withBitmapFromFile bitmapPath $ \bitmap -> + do toolBarAddTool2 toolbar id label bitmap nullBitmap + (if isToggle then wxITEM_CHECK else wxITEM_NORMAL) + shelp lhelp + let t = ToolBarItem (downcastToolBar toolbar) id isToggle + set t props + toolBarRealize toolbar + return t + +-- | Create an /orphan/ toolbar item that is unassociated with a menu. Takes a +-- label, a flag that is 'True' when the item is 'checkable' and a path to an image +-- (bmp,png,gif,ico,etc.) as arguments. +toolItem :: ToolBar a -> String -> Bool -> FilePath -> [Prop ToolBarItem] -> IO ToolBarItem +toolItem toolbar label isCheckable bitmapPath props + = withBitmapFromFile bitmapPath $ \bitmap -> + do id <- idCreate + toolBarAddTool2 toolbar id label bitmap nullBitmap + (if isCheckable then wxITEM_CHECK else wxITEM_NORMAL) + "" "" + let t = ToolBarItem (downcastToolBar toolbar) id isCheckable + set t props + toolBarRealize toolbar + return t + +-- | Add an arbitrary control to a toolbar (typically a 'ComboBox'). The control +-- must be created with the toolbar as the parent. +toolControl :: ToolBar a -> Control b -> IO () +toolControl toolbar control + = do toolBarAddControl toolbar control + return () + + +{-------------------------------------------------------------------------------- + Statusbar +--------------------------------------------------------------------------------} +-- | A field in a status bar. +-- +-- * Instances: 'Textual' +-- +data StatusField = SF (Var Int) (Var (StatusBar ())) (Var Int) (Var String) + +-- | The status width attribute determines the width of a status bar field. +-- A negative width makes the field strechable. The width than determines +-- the amount of stretch in relation with other fields. The default +-- status width is @-1@, ie. all fields stretch evenly. +-- +-- Here is an example of a statusbar +-- with three fields, where the last field is 50 pixels wide, the first takes +-- 66% of the remaining space and the second field 33%. +-- +-- > field1 <- statusField [statusWidth := -2] +-- > field2 <- statusField [text := "hi"] +-- > field3 <- statusField [statusWidth := 50] +-- > set frame [statusBar := [field1,field2,field3]] +-- +statusWidth :: Attr StatusField Int +statusWidth + = newAttr "statusWidth" getter setter + where + getter (SF vwidth _ _ _) + = varGet vwidth + + setter (SF vwidth _ _ _) w + = varSet vwidth w + +-- | Create a status field. +statusField :: [Prop StatusField] -> IO StatusField +statusField props + = do vwidth<- varCreate (-1) + vsbar <- varCreate objectNull + vidx <- varCreate (-1) + vtext <- varCreate "" + let sf = SF vwidth vsbar vidx vtext + set sf props + return sf + + +instance Textual StatusField where + text + = newAttr "text" get set + where + get (SF _ vsbar vidx vtext) + = varGet vtext + + set (SF _ vsbar vidx vtext) text + = do varSet vtext text + idx <- varGet vidx + if (idx >= 0) + then do sbar <- varGet vsbar + statusBarSetStatusText sbar text idx + else return () + + + +-- | /Deprecated/: use 'statusBar'. +statusbar :: WriteAttr (Frame a) [StatusField] +statusbar + = statusBar + +-- | Specify the statusbar of a frame. +statusBar :: WriteAttr (Frame a) [StatusField] +statusBar + = writeAttr "statusbar" set + where + set f fields + = do ws <- mapM (\field -> get field statusWidth) fields + sb <- statusBarCreateFields f ws + mapM_ (setsb sb) (zip [0..] fields ) + + setsb sb (idx,SF _ vsbar vidx vtext) + = do varSet vsbar sb + varSet vidx idx + text <- varGet vtext + statusBarSetStatusText sb text idx -- initialize diff --git a/src/Graphics/UI/WX/Timer.hs b/src/Graphics/UI/WX/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Timer.hs @@ -0,0 +1,74 @@ +{-# OPTIONS -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : Timer + Copyright : (c) Daan Leijen 2003 + License : wxWindows + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + Support for milli-second timers. +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX.Timer + ( Timer, timer, interval + ) where + +import Graphics.UI.WXCore.WxcClasses hiding (Timer) +import Graphics.UI.WXCore.Events + +import Graphics.UI.WX.Types +import Graphics.UI.WX.Attributes +import Graphics.UI.WX.Layout +import Graphics.UI.WX.Classes +import Graphics.UI.WX.Events + +{-------------------------------------------------------------------- + +--------------------------------------------------------------------} +-- | A timer generates a 'command' event on a specified milli-second 'interval'. +-- +-- * Attributes: 'interval' +-- +-- * Instances: 'Able', 'Commanding' +-- +type Timer = TimerEx () + +-- | Create a new timer with a 1 second interval. The timer is automatically discarded +-- when the parent is deleted. +timer :: Window a -> [Prop Timer] -> IO Timer +timer parent props + = do t <- windowTimerCreate parent + timerStart t 1000 False + set t props + return t + +-- | The milli-second interval of the timer. +interval :: Attr Timer Int +interval + = newAttr "timer-interval" + (\t -> timerGetInterval t) + (\t i -> do runs <- timerIsRuning t + if (runs) + then do timerStop t + isone <- timerIsOneShot t + timerStart t i isone + return () + else do timerStart t i True + timerStop t) + +instance Able Timer where + enabled + = newAttr "enabled" + (\t -> timerIsRuning t) + (\t able -> do runs <- timerIsRuning t + when (runs /= able) + (if able then do i <- get t interval + timerStart t i False + return () + else do timerStop t)) + +instance Commanding Timer where + command + = newEvent "command" timerGetOnCommand timerOnCommand diff --git a/src/Graphics/UI/WX/Types.hs b/src/Graphics/UI/WX/Types.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Types.hs @@ -0,0 +1,142 @@ +{-# OPTIONS -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : Types + Copyright : (c) Daan Leijen 2003 + License : wxWindows + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + Basic types. +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX.Types + ( + + -- * Basic Types + Orientation(..) + + -- ** Objects + , ( # ), feed, feed2 + , Object, objectNull, objectIsNull, objectCast, objectIsManaged + , objectDelete + +-- , Managed, managedNull, managedIsNull, managedCast, createManaged, withManaged, managedTouch + + -- ** Identifiers + , Id, idAny, idCreate + + -- ** Mutable variables + , Var, varCreate, varGet, varSet, varUpdate, varSwap + + -- ** Bits + , BitMask(..), mask, (.+.), (.-.), bits, bitsSet + + -- ** Booleans + , boolFromInt, intFromBool + + -- ** Misc. + , Style + , EventId + , TreeItem + + -- * Graphical types + + -- ** Colors + , Color, rgb, colorRGB, colorRed, colorGreen, colorBlue + , black, darkgrey, dimgrey, mediumgrey, grey, lightgrey, white + , red, green, blue + , cyan, magenta, yellow + -- *** System colors + , SystemColor(..), colorSystem + + -- ** Font + , FontStyle(..), FontFamily(..), FontShape(..), FontWeight(..) + , fontDefault, fontSwiss, fontSmall, fontItalic, fontFixed + + -- ** Brush + , BrushStyle(..), BrushKind(..) + , HatchStyle(..) + , brushDefault + , brushTransparent + + -- ** Pen + , PenStyle(..), PenKind(..), CapStyle(..), JoinStyle(..), DashStyle(..) + , penDefault, penColored, penTransparent + + -- * Geometrical types + + -- ** Points + , Point(Point,pointX,pointY), point, pt, pointFromVec, pointFromSize, pointZero, pointNull + , pointMove, pointMoveBySize, pointAdd, pointSub, pointScale + + -- ** Sizes + , Size(Size,sizeW,sizeH), sz, sizeFromPoint, sizeFromVec, sizeZero, sizeNull, sizeEncloses + , sizeMin, sizeMax + + -- ** Vectors + , Vector(Vector,vecX,vecY), vector, vec, vecFromPoint, vecFromSize, vecZero, vecNull + , vecNegate, vecOrtogonal, vecAdd, vecSub, vecScale, vecBetween, vecLength + + -- ** Rectangles + , Rect(Rect,rectLeft,rectTop,rectWidth,rectHeight) + , rectTopLeft, rectTopRight, rectBottomLeft, rectBottomRight, rectBottom, rectRight + , rect, rectBetween, rectFromSize, rectZero, rectNull, rectSize, rectIsEmpty + , rectContains, rectMoveTo, rectFromPoint, rectCentralPoint, rectCentralRect, rectStretchTo + , rectMove, rectOverlaps, rectsDiff, rectUnion, rectOverlap, rectUnions + + -- * IO Control + , unitIO, bracket, bracket_, finally, finalize, when + + ) where + +import Graphics.UI.WXCore.Types +import Graphics.UI.WXCore.Draw +import Graphics.UI.WXCore.Events( Orientation(..) ) + +-- | Inverse application, i.e. @feed x f@ = @f x@. +feed :: a -> (a -> b) -> b +feed x f + = f x + +-- | Composed Inverse application, i.e. @feed2 x y f@ = @f x y@. +feed2 :: a -> b -> (a -> b -> c) -> c +feed2 x y f + = f x y + +-- | Data types that can be represented through a bit mask. Only the @assocBitMask@ method +-- is required for a new instance. +class Eq b => BitMask b where + -- | Give the association between the constructors and the bits. If a constructor + -- corresponds to no bits set, it should come as the last element. + assocBitMask :: [(b,Int)] + + -- | Convert to a bitmask + toBitMask :: b -> Int + -- | Convert from a bitmask + fromBitMask :: Int -> b + -- | Set the correct bits corresponding to a constructor in a mask. + setBitMask :: b -> Int -> Int + + toBitMask x + = case lookup x assocBitMask of + Just m -> m + Nothing -> 0 + + fromBitMask i + = walk assocBitMask + where + walk [] = error "Graphics.UI.WX.Types.fromBitMask: empty list" + walk [(x,0)] = x + walk ((x,m):xs) | bitsSet m i = x + | otherwise = walk xs + + setBitMask x i + = i .-. (bits (map snd (assocBitMask::[(b,Int)]))) .+. toBitMask x + + +-- | Create a bitmask from a list of types. +mask :: BitMask b => [b] -> Int +mask xs + = foldr (.+.) 0 (map toBitMask xs) diff --git a/src/Graphics/UI/WX/Variable.hs b/src/Graphics/UI/WX/Variable.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Variable.hs @@ -0,0 +1,33 @@ +-------------------------------------------------------------------------------- +{-| Module : Variable + Copyright : (c) Daan Leijen 2003 + License : wxWindows + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + Mutable variables. +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX.Variable + ( variable + ) where + +import Data.IORef +import Graphics.UI.WX.Types( Var, varGet, varSet, varCreate, varUpdate ) +import Graphics.UI.WX.Attributes +import Graphics.UI.WX.Classes + +{-------------------------------------------------------------------- + +--------------------------------------------------------------------} +instance Valued IORef where + value = makeAttr "value" varGet varSet varUpdate + +-- | Create a mutable variable. Change the value using the |value| attribute. +variable :: [Prop (Var a)] -> IO (Var a) +variable props + = do v <- varCreate (error "Graphics.UI.WX.Variable: uninitialized variable, use the 'value' attribute at creation") + set v props + return v diff --git a/src/Graphics/UI/WX/Window.hs b/src/Graphics/UI/WX/Window.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WX/Window.hs @@ -0,0 +1,438 @@ +{-# OPTIONS -fglasgow-exts #-} +-------------------------------------------------------------------------------- +{-| Module : Window + Copyright : (c) Daan Leijen 2003 + License : wxWindows + + Maintainer : daan@cs.uu.nl + Stability : provisional + Portability : portable + + Exports default instances for generic windows. + + * Instances: 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', + 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-} +-------------------------------------------------------------------------------- +module Graphics.UI.WX.Window + ( -- * Window + Window, window, refit, refitMinimal, rootParent, frameParent, tabTraversal + -- * ScrolledWindow + , ScrolledWindow, scrolledWindow, scrollRate + -- * Internal + , initialWindow, initialContainer + , initialIdentity, initialStyle, initialText + , initialFullRepaintOnResize, initialClipChildren + ) where + +import Graphics.UI.WXCore + +import Graphics.UI.WX.Types +import Graphics.UI.WX.Attributes +import Graphics.UI.WX.Layout +import Graphics.UI.WX.Classes +import Graphics.UI.WX.Events + + +{-------------------------------------------------------------------------------- + ScrolledWindow +--------------------------------------------------------------------------------} +-- | A scrollable window. Use 'virtualSize' and 'scrollRate' to set the scrollbar +-- behaviour. +-- +-- * Attributes: 'scrollRate' +-- +-- * Instances: 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +-- +scrolledWindow :: Window a -> [Prop (ScrolledWindow ())] -> IO (ScrolledWindow ()) +scrolledWindow parent props + = feed2 props 0 $ + initialContainer $ \id rect -> \props style -> + do sw <- scrolledWindowCreate parent id rect style + set sw props + return sw + + +-- | The horizontal and vertical scroll rate of scrolled window. Use @0@ to disable +-- scrolling in that direction. +scrollRate :: Attr (ScrolledWindow a) Size +scrollRate + = newAttr "scrollRate" getter setter + where + getter sw + = do p <- scrolledWindowGetScrollPixelsPerUnit sw + return (sizeFromPoint p) + + setter sw size + = scrolledWindowSetScrollRate sw (sizeW size) (sizeH size) + + +{-------------------------------------------------------------------------------- + Plain window +--------------------------------------------------------------------------------} +-- | Create a plain window. Can be used to define custom controls for example. +-- +-- * Attributes: 'rootParent', 'frameParent', 'tabTraversal' +-- +-- * Instances: 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. +window :: Window a -> [Prop (Window ())] -> IO (Window ()) +window parent props + = feed2 props 0 $ + initialWindow $ \id rect -> \props flags -> + do w <- windowCreate parent id rect flags + set w props + return w + + +{-------------------------------------------------------------------------------- + Properties +--------------------------------------------------------------------------------} +-- | Helper function that retrieves initial window settings, including +-- |identity|, |style|, and |area| (or |position| and |outerSize|). +initialWindow :: (Id -> Rect -> [Prop (Window w)] -> Style -> a) -> [Prop (Window w)] -> Style -> a +initialWindow cont + = initialIdentity $ \id -> + initialArea $ \rect -> + initialStyle $ + initialBorder $ + cont id rect + +-- | Helper function that retrieves initial window settings, including |clipChildren| +-- and |fullRepaintOnResize|. +initialContainer :: (Id -> Rect -> [Prop (Window w)] -> Style -> a) -> [Prop (Window w)] -> Style -> a +initialContainer cont + = initialWindow $ \id rect -> + initialFullRepaintOnResize $ + initialClipChildren $ + cont id rect + + +instance Able (Window a) where + enabled + = newAttr "enabled" windowIsEnabled setter + where + setter w enable + | enable = unitIO $ windowEnable w + | otherwise = unitIO $ windowDisable w + + +instance Textual (Window a) where + text + = reflectiveAttr "text" getter setter + where + getter w + = fst (getset w) + setter w x + = snd (getset w) x + + getset w + = ifInstanceOf w classComboBox + (\cb -> (comboBoxGetValue cb, \s -> do comboBoxClear cb; comboBoxAppend cb s)) $ + ifInstanceOf w classTextCtrl + (\tc -> (textCtrlGetValue tc, \s -> do textCtrlClear tc; textCtrlWriteText tc s)) $ + (windowGetLabel w,windowSetLabel w) + + appendText w s + = ifInstanceOf w classComboBox + (\cb -> comboBoxAppend cb s) $ + ifInstanceOf w classTextCtrl + (\tc -> textCtrlAppendText tc s) + (set w [text :~ (++s)]) + + +-- | Retrieve the initial title from the |text| attribute. +initialText :: Textual w => (String -> [Prop w] -> a) -> [Prop w] -> a +initialText cont props + = withProperty text "" cont props + + +instance Dimensions (Window a) where + outerSize + = newAttr "size" windowGetSize setSize + where + setSize w sz + = windowSetSize w (rect (pt (-1) (-1)) sz) wxSIZE_USE_EXISTING + + area + = newAttr "area" windowGetRect setArea + where + setArea w rect + = windowSetSize w rect wxSIZE_USE_EXISTING + + bestSize + = readAttr "bestSize" windowGetAdjustedBestSize + + position + = newAttr "position" windowGetPosition windowMove + + clientSize + = newAttr "clientSize" windowGetClientSize windowSetClientSize + + virtualSize + = newAttr "virtualSize" windowGetVirtualSize windowSetVirtualSize + + +instance Sized (Window a) where + size = outerSize + +-- | Retrieve the initial creation area from the |area|, or the |position| and +-- |outerSize| properties. +initialArea :: Dimensions w => (Rect -> [Prop w] -> a) -> [Prop w] -> a +initialArea cont props + = case findProperty area rectNull props of + Just (rect,props') -> cont rect props' + Nothing + -> case findProperty position pointNull props of + Just (p,props') -> case findProperty outerSize sizeNull props of + Just (sz,props'') -> cont (rect p sz) props'' + Nothing -> cont (rect p sizeNull) props' + Nothing -> case findProperty outerSize sizeNull props of + Just (sz,props') -> cont (rect pointNull sz) props' + Nothing -> cont rectNull props + + + +instance Colored (Window a) where + bgcolor + = newAttr "bgcolor" windowGetBackgroundColour (\w x -> do{ windowSetBackgroundColour w x; return ()}) + + color + = newAttr "color" windowGetForegroundColour (\w x -> do windowSetForegroundColour w x; return ()) + + +instance Literate (Window a) where + font + = newAttr "font" getter setter + where + getter w + = ifInstanceOf w classTextCtrl + (\textCtrl -> bracket (textCtrlGetDefaultStyle textCtrl) + (textAttrDelete) + (\attr -> do hasFont <- textAttrHasFont attr + if (hasFont) + then getFont (textAttrGetFont attr) + else getFont (windowGetFont w))) + (getFont (windowGetFont w)) + where + getFont io + = bracket io fontDelete fontGetFontStyle + + setter w info + = ifInstanceOf w classTextCtrl + (\textCtrl -> bracket (textAttrCreateDefault) + (textAttrDelete) + (\attr -> withFontStyle info $ \fnt -> + do textAttrSetFont attr fnt + textCtrlSetDefaultStyle textCtrl attr + return ())) + (withFontStyle info $ \fnt -> + do windowSetFont w fnt + return ()) + + textColor + = newAttr "textcolor" getter setter + where + getter w + = ifInstanceOf w classTextCtrl + (\textCtrl -> bracket (textCtrlGetDefaultStyle textCtrl) + (textAttrDelete) + (\attr -> do hasColor <- textAttrHasTextColour attr + if (hasColor) then textAttrGetTextColour attr + else get w color)) + (get w color) + + setter w c + = ifInstanceOf w classTextCtrl + (\textCtrl -> bracket (textAttrCreateDefault) + (textAttrDelete) + (\attr -> do textAttrSetTextColour attr c + textCtrlSetDefaultStyle textCtrl attr + return ())) + (set w [color := c]) + + textBgcolor + = newAttr "textbgcolor" getter setter + where + getter w + = ifInstanceOf w classTextCtrl + (\textCtrl -> bracket (textCtrlGetDefaultStyle textCtrl) + (textAttrDelete) + (\attr -> do hasColor <- textAttrHasBackgroundColour attr + if (hasColor) then textAttrGetBackgroundColour attr + else get w bgcolor)) + (get w bgcolor) + + setter w c + = ifInstanceOf w classTextCtrl + (\textCtrl -> bracket (textAttrCreateDefault) + (textAttrDelete) + (\attr -> do textAttrSetBackgroundColour attr c + textCtrlSetDefaultStyle textCtrl attr + return ())) + (set w [bgcolor := c]) + + + +instance Visible (Window a) where + visible + = newAttr "visible" windowIsShown setVisible + where + setVisible w vis + = if vis + then do{ windowShow w; windowRaise w } + else unitIO (windowHide w) + + refresh w + = windowRefresh w True + + fullRepaintOnResize + = reflectiveAttr "fullRepaintOnResize" getFlag setFlag + where + getFlag w + = do s <- get w style + return (not (bitsSet wxNO_FULL_REPAINT_ON_RESIZE s)) + + setFlag w repaint + = set w [style :~ \stl -> if repaint + then stl .-. wxNO_FULL_REPAINT_ON_RESIZE + else stl .+. wxNO_FULL_REPAINT_ON_RESIZE] + +instance Parent (Window a) where + children + = readAttr "children" windowChildren + + clipChildren + = reflectiveAttr "clipChildren" getFlag setFlag + where + getFlag w + = do s <- get w style + return (bitsSet wxCLIP_CHILDREN s) + setFlag w clip + = set w [style :~ \stl -> if clip + then stl .+. wxCLIP_CHILDREN + else stl .-. wxCLIP_CHILDREN] + + +-- | Helper function that transforms the style accordding +-- to the 'fullRepaintOnResize' flag in of the properties +initialFullRepaintOnResize :: Visible w => ([Prop w] -> Style -> a) -> [Prop w] -> Style -> a +initialFullRepaintOnResize + = withStylePropertyNot fullRepaintOnResize wxNO_FULL_REPAINT_ON_RESIZE + + +-- | Helper function that transforms the style accordding +-- to the 'clipChildren' flag out of the properties +initialClipChildren :: Parent w => ([Prop w] -> Style -> a) -> [Prop w] -> Style -> a +initialClipChildren + = withStyleProperty clipChildren wxCLIP_CHILDREN + + + + +instance Child (Window a) where + parent + = readAttr "parent" windowGetParent + +-- | Ensure that a widget is refitted inside a window when +-- its size changes, for example when the 'text' of a +-- 'staticText' control changes. (calls 'windowReFit') +refit :: Window a -> IO () +refit w + = windowReFit w + +-- | Ensure that a widget is refitted inside a window when +-- its size changes, for example when the 'text' of a +-- 'staticText' control changes. Always resizes the +-- window to its minimal acceptable size. (calls 'windowReFitMinimal') +refitMinimal :: Window a -> IO () +refitMinimal w + = windowReFitMinimal w + +-- | The ultimate root parent of the widget. +rootParent :: ReadAttr (Window a) (Window ()) +rootParent + = readAttr "rootParent" windowGetRootParent + +-- | The parent frame or dialog of a widget. +frameParent :: ReadAttr (Window a) (Window ()) +frameParent + = readAttr "frameParent" windowGetFrameParent + + +-- | Enable (or disable) tab-traversal. (= wxTAB_TRAVERSAL) +tabTraversal :: Attr (Window a) Bool +tabTraversal + = newAttr "tabTraversal" getter setter + where + getter w + = do st <- get w style + return (bitsSet wxTAB_TRAVERSAL st) + setter w enable + = set w [style :~ \stl -> if enable then stl .+. wxTAB_TRAVERSAL else stl .-. wxTAB_TRAVERSAL] + + +instance Identity (Window a) where + identity + = reflectiveAttr "identity" windowGetId windowSetId + +-- | Helper function that retrieves the initial |identity|. +initialIdentity :: Identity w => (Id -> [Prop w] -> a) -> [Prop w] -> a +initialIdentity + = withProperty identity idAny + +instance Styled (Window a) where + style + = reflectiveAttr "style" windowGetWindowStyleFlag windowSetWindowStyleFlag + +-- | Helper function that retrieves the initial |style|. +initialStyle :: Styled w => ([Prop w] -> Style -> a) -> [Prop w] -> Style -> a +initialStyle cont props stl + = withProperty style stl (\stl' props' -> cont props' stl') props + +instance Tipped (Window a) where + tooltip + = newAttr "tooltip" windowGetToolTip windowSetToolTip + +{- +instance Help (Window a) where + help + = newAttr "help" windowSetHelpText windowGetHelpText +-} + +{-------------------------------------------------------------------------------- + Borders +--------------------------------------------------------------------------------} +instance Bordered (Window a) where + border + = reflectiveAttr "border" getter setter + where + getter w + = do st <- get w style + return (fromBitMask st) + setter w b + = set w [style :~ \stl -> setBitMask b stl] + +initialBorder cont props style + = case filterProperty border props of + (PropValue x, ps) -> cont ps (setBitMask x style) + (PropModify f, ps) -> cont ps (setBitMask (f (fromBitMask style)) style) + (PropNone, ps) -> cont ps style + +{-------------------------------------------------------------------------------- + Events +--------------------------------------------------------------------------------} +instance Reactive (Window a) where + mouse = newEvent "mouse" windowGetOnMouse (\w h -> windowOnMouse w True h) + keyboard = newEvent "keyboard" windowGetOnKeyChar (windowOnKeyChar) + closing = newEvent "closing" windowGetOnClose windowOnClose + idle = newEvent "idle" windowGetOnIdle windowOnIdle + resize = newEvent "resize" windowGetOnSize windowOnSize + focus = newEvent "focus" windowGetOnFocus windowOnFocus + activate = newEvent "activate" windowGetOnActivate windowOnActivate + +instance Paint (Window a) where + paint = newEvent "paint" windowGetOnPaint (\w h -> windowOnPaint w h) + paintRaw = newEvent "paintRaw" windowGetOnPaintRaw (\w h -> windowOnPaintRaw w h) + repaint w = windowRefresh w False diff --git a/wx.cabal b/wx.cabal new file mode 100644 --- /dev/null +++ b/wx.cabal @@ -0,0 +1,39 @@ +Name: wx +Version: 0.10.1 +License: LGPL +License-file: license.txt +Author: Daan Leijen +Build-Type: Simple +Category: GUI +Cabal-Version: >= 1.2 +Description: wxHaskell is a portable and native GUI library for Haskell. It is built on top of wxWidgets - a comprehensive C++ library that is portable across all major GUI platforms; including GTK, Windows, X11, and MacOS X. +Maintainer: wxhaskell-users@lists.sourceforge.net +Synopsis: wxHaskell +Data-Files: wx.cabal + +Flag splitBase + Description: Choose the new smaller, split-up base package. + +Library + if flag(splitBase) + build-depends: base >= 3, wxcore >= 0.10.1 + else + build-depends: base < 3, wxcore >= 0.10.1 + + Exposed-Modules: + Graphics.UI.WX.Draw + Graphics.UI.WX.Media + Graphics.UI.WX.Attributes + Graphics.UI.WX.Window + Graphics.UI.WX.Variable + Graphics.UI.WX.Events + Graphics.UI.WX.Frame + Graphics.UI.WX.Layout + Graphics.UI.WX.Controls + Graphics.UI.WX.Types + Graphics.UI.WX.Dialogs + Graphics.UI.WX.Classes + Graphics.UI.WX.Timer + Graphics.UI.WX.Menu + Graphics.UI.WX + Hs-Source-Dirs: src