wx 0.91.0.0 → 0.92.0.0
raw patch · 5 files changed
+253/−19 lines, 5 filesdep +timedep ~wxcore
Dependencies added: time
Dependency ranges changed: wxcore
Files
- license.txt +1/−1
- src/Graphics/UI/WX/Controls.hs +190/−8
- src/Graphics/UI/WX/Events.hs +51/−4
- src/Graphics/UI/WX/Window.hs +4/−1
- wx.cabal +7/−5
license.txt view
@@ -5,7 +5,7 @@ license. The documentation is subject to the wxWidgets documentation license. -See "http://www.wxwidgets.org/newlicen.htm" for the legal description +See "https://www.wxwidgets.org/about/licence/" 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
src/Graphics/UI/WX/Controls.hs view
@@ -17,6 +17,9 @@ Align(..), Aligned, alignment , Wrap(..), Wrapped, wrap , Sorted, sorted + -- * Calendar Ctrl + , calendarCtrl, date + , IsDate (..) -- * Containers , Panel, panel, panelEx , Notebook, notebook @@ -37,6 +40,8 @@ -- ** ListBox , ListBox, SingleListBox, MultiListBox , singleListBox, singleListBoxRes, multiListBox, multiListBoxRes + , ListBoxView (..), singleListBoxView, multiListBoxView, listBoxViewAddItem, listBoxViewGetItems, listBoxViewSetItems + , singleListBoxViewGetSelection, multiListBoxViewGetSelections -- ** RadioBox , RadioBox, radioBox, radioBoxRes -- ** Spin Control @@ -61,6 +66,9 @@ , ImageList, imageList, imageListFromFiles -- ** MediaCtrl , MediaCtrlBackend(..), MediaCtrl, mediaCtrl, mediaCtrlWithBackend, mediaCtrlEx + -- ** Wizard + , Wizard, wizard, wizardEx, wizardPageSimple, runWizard, next, prev, chain, wizardPageSize + , wizardEvent, wizardCurrentPage -- ** StyledTextCtrl , StyledTextCtrl, stcEvent, styledTextCtrl, styledTextCtrlEx -- ** PropertyGrid @@ -79,7 +87,10 @@ import Graphics.UI.WX.Window import Control.Monad (forM_) +import Control.Applicative +import Data.Maybe (fromMaybe, isJust, fromJust) import Data.Dynamic -- for "alignment" +import Data.Time import System.Info (os) @@ -335,7 +346,7 @@ -- be set at creation time (or the entry has default alignment (=left) ). -- This is an alias for textEntry -- --- * Instances: 'Wrap', 'Aligned', 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- * Instances: 'Wrap', 'Aligned', 'Commanding', 'Updating' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', -- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. -- entry :: Window a -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) @@ -345,7 +356,7 @@ -- | 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', +-- * Instances: 'Wrap', 'Aligned', 'Commanding', 'Updating' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', -- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. -- textEntry :: Window a -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) @@ -355,7 +366,7 @@ -- | 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', +-- * Instances: 'Wrap', 'Aligned', 'Commanding', 'Updating' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', -- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. -- textCtrl :: Window a -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) @@ -368,7 +379,7 @@ -- 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', +-- * Instances: 'Wrap', 'Aligned', 'Commanding', 'Updating' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', -- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. -- textCtrlRich :: Window a -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) @@ -377,7 +388,7 @@ -- | Create a generic text control given a certain style. -- --- * Instances: 'Wrap', 'Aligned', 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- * Instances: 'Wrap', 'Aligned', 'Commanding', 'Updating' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', -- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. -- textCtrlEx :: Window a -> Style -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) @@ -394,7 +405,7 @@ -- | Complete the construction of a text control instance which has been loaded -- from a resource file. -- --- * Instances: 'Wrap', 'Aligned', 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', +-- * Instances: 'Wrap', 'Aligned', 'Commanding', 'Updating' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child', -- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. -- textCtrlRes :: Window a -> String -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) @@ -403,6 +414,9 @@ set t props return t +instance Updating (TextCtrl a) where + update = newEvent "update" controlGetOnText controlOnText + instance Commanding (TextCtrl a) where command = newEvent "command" textCtrlGetOnTextEnter textCtrlOnTextEnter @@ -457,6 +471,50 @@ return t {-------------------------------------------------------------------------------- + Calendar Control +--------------------------------------------------------------------------------} + +class IsDate a where + toWXDate :: a -> IO (DateTime ()) + fromWXDate :: DateTime () -> IO a + +instance IsDate (DateTime ()) where + toWXDate = return + fromWXDate = return + +instance IsDate Day where + -- time zone?? + toWXDate utc = do + wxd <- dateTimeCreate + dateTimeSet wxd (fromInteger y) (m - 1) d 0 0 0 0 + return wxd + where (y,m,d) = toGregorian utc + fromWXDate wxd = fromGregorian + <$> (toInteger <$> dateTimeGetYear wxd 0) + <*> ((+1) <$> dateTimeGetMonth wxd 0) + <*> dateTimeGetDay wxd 0 + + +date :: (Typeable a, IsDate a) => Attr (CalendarCtrl w) a +date = createAttr "date" getter setter + where getter w = do + wxd <- dateTimeCreate + withObjectPtr wxd (calendarCtrlGetDate w) + fromWXDate wxd + setter w dt = do + wxd <- toWXDate dt + withObjectPtr wxd (calendarCtrlSetDate w) + +calendarCtrl :: Window a -> [Prop (CalendarCtrl ())] -> IO (CalendarCtrl ()) +calendarCtrl parent props + = feed2 props 0 $ + initialWindow $ \id rect -> \props flags -> + do dt <- dateTimeCreate + t <- calendarCtrlCreate parent id dt rect flags + set t props + return t + +{-------------------------------------------------------------------------------- Check box --------------------------------------------------------------------------------} instance Commanding (CheckBox a) where @@ -579,6 +637,10 @@ command = newEvent "command" comboBoxGetOnTextEnter comboBoxOnTextEnter +instance Updating (ComboBox a) where + update + = newEvent "update" controlGetOnText controlOnText + instance Selecting (ComboBox a) where select = newEvent "select" comboBoxGetOnCommand comboBoxOnCommand @@ -606,7 +668,7 @@ -- | Create a new combo box. -- --- * Instances: 'Selecting', 'Commanding','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', +-- * Instances: 'Selecting', 'Commanding', 'Updating', 'Selection', 'Items' -- 'Textual', 'Literate', 'Dimensions', -- 'Colored', 'Visible', 'Child', -- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. -- @@ -619,7 +681,7 @@ -- | Create a new combo box with a given set of flags. -- --- * Instances: 'Selecting', 'Commanding','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', +-- * Instances: 'Selecting', 'Commanding', 'Updating', 'Selection', 'Items' -- 'Textual', 'Literate', 'Dimensions', -- 'Colored', 'Visible', 'Child', -- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'. -- @@ -753,6 +815,56 @@ set ml props return ml +-- | A small wrapper over WX's ListCtrl, allowing us to keep the data +-- we're representing as well as its string form (shown to the user as +-- rows). +data ListBoxView b a = ListBoxView { + listBoxViewCtrl :: ListBox b, + listBoxViewItems :: Var [a], + listBoxViewToRow :: a -> String + } + +listBoxViewLayout :: ListBoxView b a -> Layout +listBoxViewLayout = fill . widget . listBoxViewCtrl + +listBoxViewSetItems :: ListBoxView b a -> [a] -> IO () +listBoxViewSetItems list its = do + set (listBoxViewItems list) [value := its] + set (listBoxViewCtrl list) [items := map (listBoxViewToRow list) its] + +listBoxViewGetItems :: ListBoxView b a -> IO [a] +listBoxViewGetItems list = get (listBoxViewItems list) value + +listBoxViewAddItem :: ListBoxView b a -> a -> IO () +listBoxViewAddItem list it = do + its <- (it:) `fmap` get (listBoxViewItems list) value + listBoxViewSetItems list its + +singleListBoxViewGetSelection :: ListBoxView (CSingleListBox ()) a -> IO (Maybe a) +singleListBoxViewGetSelection view = do + sel <- get (listBoxViewCtrl view) selection + its <- get (listBoxViewItems view) value + return $ if sel == -1 then Nothing else Just (its !! sel) + +multiListBoxViewGetSelections :: ListBoxView (CMultiListBox ()) a -> IO [a] +multiListBoxViewGetSelections view = do + sels <- get (listBoxViewCtrl view) selections + its <- get (listBoxViewItems view) value + return $ map (its !!) sels + +singleListBoxView :: Window b -> [Prop (SingleListBox ())] -> (a -> String) -> IO (ListBoxView (CSingleListBox ()) a) +singleListBoxView parent props toRow = do + ctrl <- singleListBox parent props + var <- variable [value := []] + return $ ListBoxView ctrl var toRow + +multiListBoxView :: Window b -> [Prop (MultiListBox ())] -> (a -> String) -> IO (ListBoxView (CMultiListBox ()) a) +multiListBoxView parent props toRow = do + ctrl <- multiListBox parent props + var <- variable [value := []] + return $ ListBoxView ctrl var toRow + + {-------------------------------------------------------------------------------- RadioBox --------------------------------------------------------------------------------} @@ -1329,6 +1441,76 @@ instance Media (MediaCtrl a) where play media = unitIO (mediaCtrlPlay media) stop media = unitIO (mediaCtrlStop media) + +{-------------------------------------------------------------------------------- + Wizard +--------------------------------------------------------------------------------} + +-- wxcore contains getters for next/prev, but how do we fix the conflicting types? +-- For the time being, the getters are omitted. +next :: WriteAttr (WizardPageSimple a) (Maybe (WizardPageSimple b)) +next = writeAttr "next" setter + where + setter w p = wizardPageSimpleSetNext w (fromMaybe objectNull p) +prev :: WriteAttr (WizardPageSimple a) (Maybe (WizardPageSimple b)) +prev = writeAttr "prev" setter + where + setter w p = wizardPageSimpleSetPrev w (fromMaybe objectNull p) + +wizardPageSize :: Attr (Wizard a) Size +wizardPageSize = newAttr "pageSize" getter setter + where + getter w = wizardGetPageSize w + setter w p = wizardSetPageSize w p + +-- | Chain together all given wizard pages. +chain :: [WizardPageSimple a] -> IO () +chain ws = chain1 Nothing ws + where + chain1 pr (w:ws) = do + when (isJust pr) (set w [prev := pr]) + when (not $ null ws) (set w [next := Just $ head ws]) + chain1 (Just w) ws + chain1 pr [] = return () + +-- | Create an empty wizard. +wizard :: Window a -> [Prop (Wizard ())] -> IO (Wizard ()) +wizard parent props + = wizardEx parent (wxCAPTION .-. wxSYSTEM_MENU .-. wxCLOSE_BOX) props + +wizardEx :: Window a -> Style -> [Prop (Wizard ())] -> IO (Wizard ()) +wizardEx parent style props + = feed2 props style $ + initialWindow $ \id rect -> + initialText $ \txt -> \props flags -> + do b <- wizardCreate parent id txt nullBitmap rect + set b props + return b + +-- | Create an empty simple wizard page. +wizardPageSimple :: Wizard a -> [Prop (WizardPageSimple ())] -> IO (WizardPageSimple ()) +wizardPageSimple parent props + = do + w <- wizardPageSimpleCreate parent + set w props + return w + +wizardCurrentPage :: ReadAttr (Wizard a) (Maybe (WizardPage ())) +wizardCurrentPage = readAttr "currentPage" getter + where getter w = do + x <- wizardGetCurrentPage w + return $ if objectIsNull x then Nothing else Just x + + +wizardEvent :: Event (Wizard a) (EventWizard -> IO ()) +wizardEvent + = newEvent "wizardEvent" wizardGetOnWizEvent wizardOnWizEvent + +-- | Run the wizard. +-- IMPORTANT: `windowDestroy` needs to be called on the wizard when it is no longer used. After +-- `windowDestroy` has been called, the wizard or any of its children must not be accessed anymore. +runWizard :: Wizard a -> WizardPage b -> IO Bool +runWizard wiz page = wizardRunWizard wiz page >>= return . (/=0) {-------------------------------------------------------------------------------- wxStyledTextCtrl
src/Graphics/UI/WX/Events.hs view
@@ -66,12 +66,14 @@ , Selecting, select -- ** Commanding , Commanding, command + -- ** Updating + , Updating, update -- ** Reactive , Reactive , mouse, keyboard , closing, idle, resize, focus, activate , Paint - , paint, paintRaw, repaint + , paint, paintRaw, paintGc, repaint -- * Event filters -- ** Mouse filters , enter, leave, motion, drag @@ -100,6 +102,14 @@ , EventCalendar(..) , calendarEvent + -- ** AuiNotebook event + , EventAuiNotebook(..) + , auiNotebookOnPageCloseEvent + , auiNotebookOnPageClosedEvent + , auiNotebookOnPageChangingEvent + , auiNotebookOnPageChangedEvent + + -- ** Keyboard events , EventKey (..), Key(..) , keyKey, keyModifiers, keyPos @@ -144,6 +154,13 @@ -- | A commanding event, for example a button press. command :: Event w (IO ()) +-- | 'Updating' widgets fire an 'update' event. +class Updating w where + -- | An update event, for example when the text of a 'TextCtrl' changes. + -- An update event, unlike a 'command' event, is typically a passive state + -- change and doesn't require a response. + update :: Event w (IO ()) + -- | 'Reactive' widgets are almost all visible widgets on the screen. class Reactive w where mouse :: Event w (EventMouse -> IO ()) @@ -165,8 +182,13 @@ 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. + paintRaw :: Event w (PaintDC () -> Rect -> [Rect] -> IO ()) + -- | Paint double buffered to a 'GCDC' device context, for + -- anti-aliased drawing. The context is always cleared before + -- drawing. Takes the current view rectangle (adjusted for + -- scrolling) as an argument. + paintGc :: Event w (GCDC () -> Rect -> IO ()) + -- | Emit a paint event to the specified widget. repaint :: w -> IO () @@ -324,11 +346,36 @@ calendarEvent = newEvent "calendarEvent" calendarCtrlGetOnCalEvent calendarCtrlOnCalEvent +{-------------------------------------------------------------------- + AuiNotebook event filters +--------------------------------------------------------------------} +newAuiEvent :: String -> EventId -> Event (AuiNotebook a) (EventAuiNotebook -> IO ()) +newAuiEvent s evId = newEvent s (auiNotebookGetOnAuiNotebookEvent evId) (auiNotebookOnAuiNotebookEvent s evId) + +-- AUI Notebook PageClose +auiNotebookOnPageCloseEvent :: Event (AuiNotebook a) (EventAuiNotebook -> IO ()) +auiNotebookOnPageCloseEvent = newAuiEvent "auiNotebookOnPageClose" wxEVT_AUINOTEBOOK_PAGE_CLOSE + +-- AUINotebook PageClosed +auiNotebookOnPageClosedEvent :: Event (AuiNotebook a) (EventAuiNotebook -> IO ()) +auiNotebookOnPageClosedEvent = newAuiEvent "auiNotebookOnPageClosed" wxEVT_AUINOTEBOOK_PAGE_CLOSED + +-- AUINotebook PageChange +auiNotebookOnPageChangingEvent :: Event (AuiNotebook a) (EventAuiNotebook -> IO ()) +auiNotebookOnPageChangingEvent = newAuiEvent "auiNotebookOnPageChanging" wxEVT_AUINOTEBOOK_PAGE_CHANGING + +-- AUINotebook PageChanged +auiNotebookOnPageChangedEvent :: Event (AuiNotebook a) (EventAuiNotebook -> IO ()) +auiNotebookOnPageChangedEvent = newAuiEvent "auiNotebookOnPageChanged" wxEVT_AUINOTEBOOK_PAGE_CHANGED + + + + {-------------------------------------------------------------------- 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)+ = Event (newAttr name getter setter)
src/Graphics/UI/WX/Window.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} -------------------------------------------------------------------------------- {-| Module : Window Copyright : (c) Daan Leijen 2003 @@ -436,4 +438,5 @@ instance Paint (Window a) where paint = newEvent "paint" windowGetOnPaint (\w h -> windowOnPaint w h) paintRaw = newEvent "paintRaw" windowGetOnPaintRaw (\w h -> windowOnPaintRaw w h) + paintGc = newEvent "paintGc" windowGetOnPaintGc (\w h -> windowOnPaintGc w h) repaint w = windowRefresh w False
wx.cabal view
@@ -1,5 +1,5 @@ Name: wx -Version: 0.91.0.0 +Version: 0.92.0.0 License: OtherLicense License-file: license.txt Homepage: http://haskell.org/haskellwiki/WxHaskell @@ -24,8 +24,9 @@ Library if flag(splitBase) - build-depends: wxcore >= 0.91, - stm + build-depends: wxcore >= 0.92, + stm, + time >= 1.4.0 if flag(newBase) build-depends: base >= 4 && < 5 @@ -34,8 +35,9 @@ base >= 3 && < 4 else build-depends: base < 3, - wxcore >= 0.91, - stm + wxcore >= 0.92, + stm, + time >= 1.4.0 Exposed-Modules: Graphics.UI.WX.Draw