packages feed

wx (empty) → 0.10.1

raw patch · 18 files changed

+4891/−0 lines, 18 filesdep +basedep +wxcoresetup-changed

Dependencies added: base, wxcore

Files

+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ license.txt view
@@ -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.++    <one line to give the library's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    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.++  <signature of Ty Coon>, 1 April 1990+  Ty Coon, President of Vice++That's all there is to it!
+ src/Graphics/UI/WX.hs view
@@ -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)
+ src/Graphics/UI/WX/Attributes.hs view
@@ -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
+ src/Graphics/UI/WX/Classes.hs view
@@ -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+
+ src/Graphics/UI/WX/Controls.hs view
@@ -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.+--   <http://www.wxwidgets.org/manuals/stable/wx_wxmediactrl.html#choosingbackendwxmediactrl>+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
+ src/Graphics/UI/WX/Dialogs.hs view
@@ -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
+ src/Graphics/UI/WX/Draw.hs view
@@ -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
+ src/Graphics/UI/WX/Events.hs view
@@ -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)
+ src/Graphics/UI/WX/Frame.hs view
@@ -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
+ src/Graphics/UI/WX/Layout.hs view
@@ -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
+ src/Graphics/UI/WX/Media.hs view
@@ -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)+
+ src/Graphics/UI/WX/Menu.hs view
@@ -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 "<empty>"+                                      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      -> "<empty>"+                     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
+ src/Graphics/UI/WX/Timer.hs view
@@ -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
+ src/Graphics/UI/WX/Types.hs view
@@ -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)
+ src/Graphics/UI/WX/Variable.hs view
@@ -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
+ src/Graphics/UI/WX/Window.hs view
@@ -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
+ wx.cabal view
@@ -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