wxcore 0.92.0.0 → 0.92.1.0
raw patch · 23 files changed
+941/−859 lines, 23 files
Files
- src/haskell/Graphics/UI/WXCore.hs +9/−8
- src/haskell/Graphics/UI/WXCore/Controls.hs +14/−15
- src/haskell/Graphics/UI/WXCore/Defines.hs +13/−12
- src/haskell/Graphics/UI/WXCore/Dialogs.hs +10/−10
- src/haskell/Graphics/UI/WXCore/DragAndDrop.hs +24/−27
- src/haskell/Graphics/UI/WXCore/Draw.hs +42/−25
- src/haskell/Graphics/UI/WXCore/Events.hs +301/−273
- src/haskell/Graphics/UI/WXCore/Frame.hs +8/−8
- src/haskell/Graphics/UI/WXCore/Image.hs +25/−24
- src/haskell/Graphics/UI/WXCore/Layout.hs +172/−171
- src/haskell/Graphics/UI/WXCore/OpenGL.hs +15/−17
- src/haskell/Graphics/UI/WXCore/Print.hs +30/−31
- src/haskell/Graphics/UI/WXCore/Process.hs +38/−40
- src/haskell/Graphics/UI/WXCore/Types.hs +35/−34
- src/haskell/Graphics/UI/WXCore/WxcClassInfo.hs +12/−11
- src/haskell/Graphics/UI/WXCore/WxcClassTypes.hs +8/−7
- src/haskell/Graphics/UI/WXCore/WxcClasses.hs +8/−7
- src/haskell/Graphics/UI/WXCore/WxcClassesAL.hs +10/−9
- src/haskell/Graphics/UI/WXCore/WxcClassesMZ.hs +10/−9
- src/haskell/Graphics/UI/WXCore/WxcDefs.hs +13/−8
- src/haskell/Graphics/UI/WXCore/WxcObject.hs +11/−15
- src/haskell/Graphics/UI/WXCore/WxcTypes.hs +129/−96
- wxcore.cabal +4/−2
src/haskell/Graphics/UI/WXCore.hs view
@@ -1,11 +1,12 @@ ----------------------------------------------------------------------------------------- -{-| Module : WXCore - Copyright : (c) Daan Leijen 2003 - License : wxWindows +{-| +Module : WXCore +Copyright : (c) Daan Leijen 2003 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable The "WXCore" module is the interface to the core wxWidgets functionality. @@ -69,10 +70,10 @@ -- from this initialisation action or from event handlers, otherwise bad -- things will happen :-) run :: IO a -> IO () -run init +run action = do enableGUI appOnInit (do wxcAppInitAllImageHandlers - init + _ <- action return ()) performGC performGC
src/haskell/Graphics/UI/WXCore/Controls.hs view
@@ -1,11 +1,12 @@ -------------------------------------------------------------------------------- -{-| Module : Controls - Copyright : (c) Daan Leijen 2003 - License : wxWindows +{-| +Module : Controls +Copyright : (c) Daan Leijen 2003 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable -} -------------------------------------------------------------------------------- module Graphics.UI.WXCore.Controls @@ -26,11 +27,9 @@ ) where import Graphics.UI.WXCore.WxcTypes -import Graphics.UI.WXCore.WxcDefs import Graphics.UI.WXCore.WxcClasses import Graphics.UI.WXCore.Types -import Foreign.Storable import Foreign.Marshal.Array import Foreign.Marshal.Utils @@ -49,14 +48,14 @@ -- | Get a @TreeCookie@ to iterate through the children of tree node. treeCtrlGetChildCookie :: TreeCtrl a -> TreeItem -> IO TreeCookie -treeCtrlGetChildCookie treeCtrl parent +treeCtrlGetChildCookie _treeCtrl parent = do pcookie <- varCreate (CookieFirst parent) return (TreeCookie pcookie) -- | Get the next child of a tree node. Returns 'Nothing' when -- the end of the list is reached. This also invalidates the tree cookie. treeCtrlGetNextChild2 :: TreeCtrl a -> TreeCookie -> IO (Maybe TreeItem) -treeCtrlGetNextChild2 treeCtrl treeCookie@(TreeCookie pcookie) +treeCtrlGetNextChild2 treeCtrl (TreeCookie pcookie) = do cookie <- varGet pcookie case cookie of CookieInvalid -> return Nothing @@ -99,22 +98,22 @@ = do n <- listBoxGetSelections listBox ptrNull 0 let count = abs n allocaArray count $ \carr -> - do listBoxGetSelections listBox carr count + do _ <- listBoxGetSelections listBox carr count xs <- peekArray count carr return (map fromCInt xs) -- | Sets the active log target and deletes the old one. logDeleteAndSetActiveTarget :: Log a -> IO () -logDeleteAndSetActiveTarget log - = do oldlog <- logSetActiveTarget log +logDeleteAndSetActiveTarget log' + = do oldlog <- logSetActiveTarget log' when (not (objectIsNull oldlog)) (logDelete oldlog) -- | Set a text control as a log target. textCtrlMakeLogActiveTarget :: TextCtrl a -> IO () textCtrlMakeLogActiveTarget textCtrl - = do log <- logTextCtrlCreate textCtrl - logDeleteAndSetActiveTarget log + = do log' <- logTextCtrlCreate textCtrl + logDeleteAndSetActiveTarget log' -- | Use a 'clipboardSetData' or 'clipboardGetData' in this function. But don't
src/haskell/Graphics/UI/WXCore/Defines.hs view
@@ -1,11 +1,12 @@ ----------------------------------------------------------------------------------------- -{-| Module : Defines - Copyright : (c) Daan Leijen 2003 - License : wxWindows +{-| +Module : Defines +Copyright : (c) Daan Leijen 2003 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Exports standard /defines/ of wxWidgets. -} @@ -91,13 +92,13 @@ then return fname else do appdir <- getApplicationDir let appdirfname = appdir </> fname - exist <- doesFileExist appdirfname - if exist + appdirfnameExists <- doesFileExist appdirfname + if appdirfnameExists then return appdirfname else do cwd <- getCurrentDirectory let cwdfname = cwd </> fname - exist <- doesFileExist cwdfname - if exist + cwdfnameExists <- doesFileExist cwdfname + if cwdfnameExists then return cwdfname else return fname @@ -107,7 +108,7 @@ dirSep = case wxToolkit of WxMSW -> "\\" - other -> "/" + _other -> "/" {-# DEPRECATED pathSep "Use System.FilePath module's searchPathSeparator instead" #-} -- | deprecated: Use System.FilePath module\'s 'searchPathSeparator' instead. @@ -115,5 +116,5 @@ pathSep = case wxToolkit of WxMSW -> ";" - other -> ":" + _other -> ":"
src/haskell/Graphics/UI/WXCore/Dialogs.hs view
@@ -1,11 +1,12 @@ -------------------------------------------------------------------------------- -{-| Module : Dialogs - Copyright : (c) Daan Leijen 2003 - License : wxWindows +{-| +Module : Dialogs +Copyright : (c) Daan Leijen 2003 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Standard dialogs and (non modal) tip windows. -} @@ -46,8 +47,7 @@ -- when the user clicks the window or when it loses the focus. tipWindowMessage :: Window a -> String -> IO () tipWindowMessage parent message - = do tipWindowCreate parent message 100 - return () + = tipWindowCreate parent message 100 >> return () -- | Opens a non-modal tip window with a text. The window is closed automatically -- when the mouse leaves the specified area, or when the user clicks the window, @@ -147,9 +147,9 @@ processResult fd r) where - formatWildCards wildcards + formatWildCards wildcards' = concat (intersperse "|" - [desc ++ "|" ++ concat (intersperse ";" patterns) | (desc,patterns) <- wildcards]) + [desc ++ "|" ++ concat (intersperse ";" patterns) | (desc,patterns) <- wildcards']) -- | Show a font selection dialog with a given initial font. Returns 'Nothing' when cancel was pressed.
src/haskell/Graphics/UI/WXCore/DragAndDrop.hs view
@@ -1,11 +1,12 @@ ----------------------------------------------------------------------------------------- -{-| Module : DragAndDrop - Copyright : (c) shelarcy 2007 - License : wxWidgets +{-| +Module : DragAndDrop +Copyright : (c) shelarcy 2007 +License : wxWidgets - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Drag & Drop events. -} @@ -23,9 +24,7 @@ ) where import Graphics.UI.WXCore.Defines -import Graphics.UI.WXCore.Events import Graphics.UI.WXCore.Image -import Graphics.UI.WXCore.WxcDefs import Graphics.UI.WXCore.WxcObject import Graphics.UI.WXCore.WxcTypes import Graphics.UI.WXCore.WxcClassTypes @@ -33,8 +32,6 @@ import Graphics.UI.WXCore.WxcClassesMZ import Foreign.Ptr -import Foreign.C.String -import Foreign.Marshal.Array {-------------------------------------------------------------------------------- @@ -43,52 +40,52 @@ -- | Set a drop target window and 'DataObject' that is associated with drop event. dropTarget :: Window a -> DataObject b -> IO (WXCDropTarget ()) dropTarget window wxdata = do - drop <- wxcDropTargetCreate nullPtr - dropTargetSetDataObject drop wxdata - windowSetDropTarget window drop - return drop + drop' <- wxcDropTargetCreate nullPtr + dropTargetSetDataObject drop' wxdata + windowSetDropTarget window drop' + return drop' -- | Create 'DropSource'. Then 'dragAndDrop' replace target\'s 'DataObject' by this 'DataObject'. dropSource :: DataObject a -> Window b -> IO (DropSource ()) -dropSource wxdata win = - withObjectPtr nullIcon $ \icon -> - withObjectPtr nullIcon $ \icon -> - withObjectPtr nullIcon $ \icon -> - dropSourceCreate wxdata win icon icon icon +dropSource wxdata win' = + withObjectPtr nullIcon $ \iconCopy -> + withObjectPtr nullIcon $ \iconMove -> + withObjectPtr nullIcon $ \iconNone -> + dropSourceCreate wxdata win' iconCopy iconMove iconNone -- | On Windows or Mac OS X platform, you must choose this function or 'dropSourceWithCursorByString', -- if you want to use Custom Cursor for Drag & Drop event. 'dropSourceWithIcon' doesn't work these -- platform, and this function doesn't work other platforms. dropSourceWithCursor :: DataObject a -> Window b -> Cursor c -> Cursor c -> Cursor c -> IO (DropSource ()) -dropSourceWithCursor wxdata win copy move none = +dropSourceWithCursor wxdata win' copy move none = withObjectPtr copy $ \dndCopy -> withObjectPtr move $ \dndMove -> withObjectPtr none $ \dndNone -> - dropSourceCreate wxdata win dndCopy dndMove dndNone + dropSourceCreate wxdata win' dndCopy dndMove dndNone dropSourceWithIcon :: DataObject a -> Window b -> Icon c -> Icon c -> Icon c -> IO (DropSource ()) -dropSourceWithIcon wxdata win copy move none = +dropSourceWithIcon wxdata win' copy move none = withObjectPtr copy $ \dndCopy -> withObjectPtr move $ \dndMove -> withObjectPtr none $ \dndNone -> - dropSourceCreate wxdata win dndCopy dndMove dndNone + dropSourceCreate wxdata win' dndCopy dndMove dndNone dropSourceWithCursorByString :: DataObject a -> Window b -> String -> String -> String -> IO (DropSource ()) -dropSourceWithCursorByString wxdata win copy move none = +dropSourceWithCursorByString wxdata win' copy move none = case wxToolkit of WxMSW -> do dndCopy <- cursorCreateFromFile copy dndMove <- cursorCreateFromFile move dndNone <- cursorCreateFromFile none - dropSourceWithCursor wxdata win dndCopy dndMove dndNone + dropSourceWithCursor wxdata win' dndCopy dndMove dndNone WxMac -> do dndCopy <- cursorCreateFromFile copy dndMove <- cursorCreateFromFile move dndNone <- cursorCreateFromFile none - dropSourceWithCursor wxdata win dndCopy dndMove dndNone + dropSourceWithCursor wxdata win' dndCopy dndMove dndNone _ -> do dndCopy <- iconCreateFromFile copy sizeNull dndMove <- iconCreateFromFile move sizeNull dndNone <- iconCreateFromFile none sizeNull - dropSourceWithIcon wxdata win dndCopy dndMove dndNone + dropSourceWithIcon wxdata win' dndCopy dndMove dndNone
src/haskell/Graphics/UI/WXCore/Draw.hs view
@@ -1,11 +1,12 @@ ----------------------------------------------------------------------------------------- -{-| Module : Draw - Copyright : (c) Daan Leijen 2003 - License : wxWindows +{-| +Module : Draw +Copyright : (c) Daan Leijen 2003 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Drawing. -} @@ -52,7 +53,6 @@ import Graphics.UI.WXCore.Types import Graphics.UI.WXCore.Defines -import Foreign.Marshal.Array import Foreign.Storable import Foreign.Marshal.Alloc @@ -106,12 +106,14 @@ dcWithPenStyle dc penTransparent $ dcDrawRectangle dc r) +{- -- | Fill a rectangle with a certain color. dcFillRect :: DC a -> Rect -> Color -> IO () dcFillRect dc r color = dcWithBrushStyle dc (brushSolid color) $ dcWithPenStyle dc penTransparent $ dcDrawRectangle dc r +-} {-------------------------------------------------------------------------------- Windows @@ -443,30 +445,45 @@ penCreateFromStyle :: PenStyle -> IO (Pen (),IO ()) penCreateFromStyle penStyle = case penStyle of - PenStyle PenTransparent color width cap join + PenStyle PenTransparent _color _width _cap _join -> do pen <- penCreateFromStock 5 {- transparent -} return (pen,return ()) + PenStyle (PenDash DashShort) color 1 CapRound JoinRound | color == black -> do pen <- penCreateFromStock 6 {- black dashed -} return (pen,return ()) + PenStyle PenSolid color 1 CapRound JoinRound -> case lookup color stockPens of Just idx -> do pen <- penCreateFromStock idx return (pen,return ()) Nothing -> colorPen color 1 wxPENSTYLE_SOLID - PenStyle PenSolid color width cap join + + PenStyle PenSolid color width _cap _join -> colorPen color width wxPENSTYLE_SOLID - PenStyle (PenDash dash) color width cap join + + PenStyle (PenDash dash) color width _cap _join -> case dash of - DashDot -> colorPen color width wxPENSTYLE_DOT - DashLong -> colorPen color width wxPENSTYLE_LONG_DASH - DashShort-> colorPen color width wxPENSTYLE_SHORT_DASH + DashDot -> colorPen color width wxPENSTYLE_DOT + DashLong -> colorPen color width wxPENSTYLE_LONG_DASH + DashShort -> colorPen color width wxPENSTYLE_SHORT_DASH DashDotShort -> colorPen color width wxPENSTYLE_DOT_DASH - PenStyle (PenStipple bitmap) color width cap join + + PenStyle (PenStipple bitmap) _color width _cap _join -> do pen <- penCreateFromBitmap bitmap width setCap pen setJoin pen return (pen,penDelete pen) + + PenStyle (PenHatch hatch) color width _cap _join + -> case hatch of + HatchBDiagonal -> colorPen color width wxPENSTYLE_BDIAGONAL_HATCH + HatchCrossDiag -> colorPen color width wxPENSTYLE_CROSSDIAG_HATCH + HatchFDiagonal -> colorPen color width wxPENSTYLE_FDIAGONAL_HATCH + HatchCross -> colorPen color width wxPENSTYLE_CROSS_HATCH + HatchHorizontal -> colorPen color width wxPENSTYLE_HORIZONTAL_HATCH + HatchVertical -> colorPen color width wxPENSTYLE_VERTICAL_HATCH + where colorPen color width style = do pen <- penCreateFromColour color width style @@ -615,7 +632,7 @@ BrushStyle (BrushHatch HatchCross) color -> colorBrush color wxBRUSHSTYLE_CROSS_HATCH BrushStyle (BrushHatch HatchHorizontal) color -> colorBrush color wxBRUSHSTYLE_HORIZONTAL_HATCH BrushStyle (BrushHatch HatchVertical) color -> colorBrush color wxBRUSHSTYLE_VERTICAL_HATCH - BrushStyle (BrushStipple bitmap) color -> do brush <- brushCreateFromBitmap bitmap + BrushStyle (BrushStipple bitmap) _color -> do brush <- brushCreateFromBitmap bitmap return (brush, brushDelete brush) where colorBrush color style @@ -704,8 +721,8 @@ -- | Draw connected lines. drawLines :: DC a -> [Point] -> IO () -drawLines dc [] = return () -drawLines dc ps +drawLines _dc [] = return () +drawLines dc ps = withArray xs $ \pxs -> withArray ys $ \pys -> dcDrawLines dc n pxs pys (pt 0 0) @@ -717,8 +734,8 @@ -- | Draw a polygon. The polygon is filled with the odd-even rule. drawPolygon :: DC a -> [Point] -> IO () -drawPolygon dc [] = return () -drawPolygon dc ps +drawPolygon _dc [] = return () +drawPolygon dc ps = withArray xs $ \pxs -> withArray ys $ \pys -> dcDrawPolygon dc n pxs pys (pt 0 0) wxODDEVEN_RULE @@ -730,8 +747,8 @@ -- | Gets the dimensions of the string using the currently selected font. getTextExtent :: DC a -> String -> IO Size getTextExtent dc txt - = do (sz,_,_) <- getFullTextExtent dc txt - return sz + = do (sz',_,_) <- getFullTextExtent dc txt + return sz' -- | Gets the dimensions of the string using the currently selected font. -- Takes text string to measure, and returns the size, /descent/ and /external leading/. @@ -772,7 +789,7 @@ -- memory 'DC'. dcBufferWithRef :: WindowDC a -> Maybe (Var (Bitmap ())) -> Rect -> (DC () -> IO ()) -> IO () dcBufferWithRef dc mbVar viewArea draw - = dcBufferWithRefEx dc (\dc -> dcClearRect dc viewArea) mbVar viewArea draw + = dcBufferWithRefEx dc (\dc' -> dcClearRect dc' viewArea) mbVar viewArea draw -- | Optimized double buffering. Takes a /clear/ routine as its first argument. @@ -792,7 +809,7 @@ dcBufferedAux (withGC gcdcCreate) (withGC gcdcCreateFromMemory) where withGC create dc_ draw = do dc <- create dc_ - draw dc + _ <- draw dc gcdcDelete dc dcBufferedAux :: (WindowDC a -> f -> IO ()) -> (MemoryDC c -> f -> IO ()) @@ -841,7 +858,7 @@ doneBitmap bitmap = case mbVar of Nothing -> when (bitmap/=objectNull) (bitmapDelete bitmap) - Just v -> return () + Just _v -> return () drawUnbuffered @@ -866,6 +883,6 @@ withMemoryDC memdc draw ) -- blit the memdc into the owner dc. - dcBlit dc view memdc (rectTopLeft view) wxCOPY False + _ <- dcBlit dc view memdc (rectTopLeft view) wxCOPY False return ()
src/haskell/Graphics/UI/WXCore/Events.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------------------- -{-| Module : Events - Copyright : (c) Daan Leijen 2003 - License : wxWindows +{-| +Module : Events +Copyright : (c) Daan Leijen 2003 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Dynamically set (and get) Haskell event handlers for basic wxWidgets events. Note that one should always call 'skipCurrentEvent' when an event is not @@ -213,6 +214,7 @@ , EventAuiNotebook(..) , noWindowSelection , auiNotebookOnAuiNotebookEvent + , auiNotebookOnAuiNotebookEventEx , auiNotebookGetOnAuiNotebookEvent -- * Current event @@ -256,7 +258,7 @@ , unsafeWindowGetHandlerState ) where -import Data.List( intersperse, findIndex ) +import Data.List( intersperse ) import System.Environment( getProgName, getArgs ) import Foreign.StablePtr import Foreign.Ptr @@ -289,7 +291,7 @@ -- | Set an event handler for a push button. buttonOnCommand :: Button a -> IO () -> IO () buttonOnCommand button eventHandler - = windowOnEvent button [wxEVT_COMMAND_BUTTON_CLICKED] eventHandler (\evt -> eventHandler) + = windowOnEvent button [wxEVT_COMMAND_BUTTON_CLICKED] eventHandler (\_evt -> eventHandler) -- | Get the current button event handler on a window. @@ -301,7 +303,7 @@ -- | Set an event handler for "updated text", works for example on a 'TextCtrl' and 'ComboBox'. controlOnText :: Control a -> IO () -> IO () controlOnText control eventHandler - = windowOnEvent control [wxEVT_COMMAND_TEXT_UPDATED] eventHandler (\evt -> eventHandler) + = windowOnEvent control [wxEVT_COMMAND_TEXT_UPDATED] eventHandler (\_evt -> eventHandler) -- | Get the current event handler for updated text. controlGetOnText :: Control a -> IO (IO ()) @@ -312,7 +314,7 @@ -- | Set an event handler for an enter command in a text control. textCtrlOnTextEnter :: TextCtrl a -> IO () -> IO () textCtrlOnTextEnter textCtrl eventHandler - = windowOnEvent textCtrl [wxEVT_COMMAND_TEXT_ENTER] eventHandler (\evt -> eventHandler) + = windowOnEvent textCtrl [wxEVT_COMMAND_TEXT_ENTER] eventHandler (\_evt -> eventHandler) -- | Get the current text enter event handler. textCtrlGetOnTextEnter :: TextCtrl a -> IO (IO ()) @@ -324,7 +326,7 @@ -- allowed text in a text control. textCtrlOnTextMaxLen :: IO () -> TextCtrl a -> IO () textCtrlOnTextMaxLen eventHandler textCtrl - = windowOnEvent textCtrl [wxEVT_COMMAND_TEXT_MAXLEN] eventHandler (\evt -> eventHandler) + = windowOnEvent textCtrl [wxEVT_COMMAND_TEXT_MAXLEN] eventHandler (\_evt -> eventHandler) -- | Get the current maximal text event handler. textCtrlGetOnTextMaxLen :: TextCtrl a -> IO (IO ()) @@ -335,7 +337,7 @@ -- | Set an event handler for an enter command in a combo box. comboBoxOnTextEnter :: ComboBox a -> IO () -> IO () comboBoxOnTextEnter comboBox eventHandler - = windowOnEvent comboBox [wxEVT_COMMAND_TEXT_ENTER] eventHandler (\evt -> eventHandler) + = windowOnEvent comboBox [wxEVT_COMMAND_TEXT_ENTER] eventHandler (\_evt -> eventHandler) -- | Get the current text enter event handler. comboBoxGetOnTextEnter :: ComboBox a -> IO (IO ()) @@ -346,7 +348,7 @@ -- | Set an event handler for when a combo box item is selected. comboBoxOnCommand :: ComboBox a -> IO () -> IO () comboBoxOnCommand comboBox eventHandler - = windowOnEvent comboBox [wxEVT_COMMAND_COMBOBOX_SELECTED] eventHandler (\evt -> eventHandler) + = windowOnEvent comboBox [wxEVT_COMMAND_COMBOBOX_SELECTED] eventHandler (\_evt -> eventHandler) -- | Get the current combo box event handler for selections comboBoxGetOnCommand :: ComboBox a -> IO (IO ()) @@ -356,7 +358,7 @@ -- | Set an event handler for when a listbox item is (de)selected. listBoxOnCommand :: ListBox a -> IO () -> IO () listBoxOnCommand listBox eventHandler - = windowOnEvent listBox [wxEVT_COMMAND_LISTBOX_SELECTED] eventHandler (\evt -> eventHandler) + = windowOnEvent listBox [wxEVT_COMMAND_LISTBOX_SELECTED] eventHandler (\_evt -> eventHandler) -- | Get the current listbox event handler for selections. listBoxGetOnCommand :: ListBox a -> IO (IO ()) @@ -383,7 +385,7 @@ -- | Set an event handler for when a choice item is (de)selected. choiceOnCommand :: Choice a -> IO () -> IO () choiceOnCommand choice eventHandler - = windowOnEvent choice [wxEVT_COMMAND_CHOICE_SELECTED] eventHandler (\evt -> eventHandler) + = windowOnEvent choice [wxEVT_COMMAND_CHOICE_SELECTED] eventHandler (\_evt -> eventHandler) -- | Get the current choice command event handler. choiceGetOnCommand :: Choice a -> IO (IO ()) @@ -394,7 +396,7 @@ -- | Set an event handler for when a radiobox item is selected. radioBoxOnCommand :: RadioBox a -> IO () -> IO () radioBoxOnCommand radioBox eventHandler - = windowOnEvent radioBox [wxEVT_COMMAND_RADIOBOX_SELECTED] eventHandler (\evt -> eventHandler) + = windowOnEvent radioBox [wxEVT_COMMAND_RADIOBOX_SELECTED] eventHandler (\_evt -> eventHandler) -- | Get the current radio box command handler. radioBoxGetOnCommand :: RadioBox a -> IO (IO ()) @@ -405,7 +407,7 @@ -- | Set an event handler for when a slider item changes. sliderOnCommand :: Slider a -> IO () -> IO () sliderOnCommand slider eventHandler - = windowOnEvent slider [wxEVT_COMMAND_SLIDER_UPDATED] eventHandler (\evt -> eventHandler) + = windowOnEvent slider [wxEVT_COMMAND_SLIDER_UPDATED] eventHandler (\_evt -> eventHandler) -- | Get the current slider command event handler. sliderGetOnCommand :: Slider a -> IO (IO ()) @@ -417,7 +419,7 @@ -- | Set an event handler for when a checkbox clicked. checkBoxOnCommand :: CheckBox a -> (IO ()) -> IO () checkBoxOnCommand checkBox eventHandler - = windowOnEvent checkBox [wxEVT_COMMAND_CHECKBOX_CLICKED] eventHandler (\evt -> eventHandler) + = windowOnEvent checkBox [wxEVT_COMMAND_CHECKBOX_CLICKED] eventHandler (\_evt -> eventHandler) -- | Get the current check box event handler. checkBoxGetOnCommand :: CheckBox a -> IO (IO ()) @@ -427,7 +429,7 @@ -- | Set an event handler for when a spinCtrl clicked. spinCtrlOnCommand :: SpinCtrl a -> (IO ()) -> IO () spinCtrlOnCommand spinCtrl eventHandler - = windowOnEvent spinCtrl [wxEVT_COMMAND_SPINCTRL_UPDATED] eventHandler (\evt -> eventHandler) + = windowOnEvent spinCtrl [wxEVT_COMMAND_SPINCTRL_UPDATED] eventHandler (\_evt -> eventHandler) -- | Get the current check box event handler. spinCtrlGetOnCommand :: SpinCtrl a -> IO (IO ()) @@ -437,7 +439,7 @@ -- | Set an event handler for a push button. toggleButtonOnCommand :: ToggleButton a -> IO () -> IO () toggleButtonOnCommand button eventHandler - = windowOnEvent button [wxEVT_COMMAND_TOGGLEBUTTON_CLICKED] eventHandler (\evt -> eventHandler) + = windowOnEvent button [wxEVT_COMMAND_TOGGLEBUTTON_CLICKED] eventHandler (\_evt -> eventHandler) -- | Get the current button event handler on a window. toggleButtonGetOnCommand :: Window a -> IO (IO ()) @@ -636,7 +638,7 @@ stcGetOnSTCEvent :: StyledTextCtrl a -> IO (EventSTC -> IO ()) stcGetOnSTCEvent window - = unsafeWindowGetHandlerState window (head $ map fst stcEvents) (\ev -> skipCurrentEvent) + = unsafeWindowGetHandlerState window (head $ map fst stcEvents) (\_ev -> skipCurrentEvent) {----------------------------------------------------------------------------------------- Printing @@ -670,10 +672,10 @@ epage<- wxcPrintEventGetEndPage ev let cancel = wxcPrintEventSetContinue ev False return (PrintBeginDoc cancel page epage)) - ,(wxEVT_PRINT_PREPARE, \ev -> return PrintPrepare) - ,(wxEVT_PRINT_END_DOC, \ev -> return PrintEndDoc) - ,(wxEVT_PRINT_BEGIN, \ev -> return PrintBegin) - ,(wxEVT_PRINT_END, \ev -> return PrintEnd) + ,(wxEVT_PRINT_PREPARE, \_ev -> return PrintPrepare) + ,(wxEVT_PRINT_END_DOC, \_ev -> return PrintEndDoc) + ,(wxEVT_PRINT_BEGIN, \_ev -> return PrintBegin) + ,(wxEVT_PRINT_END, \_ev -> return PrintEnd) ] -- | Set an event handler for printing. @@ -691,7 +693,7 @@ printOutGetOnPrint :: WXCPrintout a -> IO (EventPrint -> IO ()) printOutGetOnPrint printOut = do evtHandler <- wxcPrintoutGetEvtHandler printOut - unsafeGetHandlerState evtHandler idAny wxEVT_PRINT_PAGE (\ev -> skipCurrentEvent) + unsafeGetHandlerState evtHandler idAny wxEVT_PRINT_PAGE (\_ev -> skipCurrentEvent) {----------------------------------------------------------------------------------------- @@ -717,27 +719,27 @@ scrollOrientation :: EventScroll -> Orientation scrollOrientation scroll = case scroll of - ScrollTop orient pos -> orient - ScrollBottom orient pos -> orient - ScrollLineUp orient pos -> orient - ScrollLineDown orient pos -> orient - ScrollPageUp orient pos -> orient - ScrollPageDown orient pos -> orient - ScrollTrack orient pos -> orient - ScrollRelease orient pos -> orient + ScrollTop orient _pos -> orient + ScrollBottom orient _pos -> orient + ScrollLineUp orient _pos -> orient + ScrollLineDown orient _pos -> orient + ScrollPageUp orient _pos -> orient + ScrollPageDown orient _pos -> orient + ScrollTrack orient _pos -> orient + ScrollRelease orient _pos -> orient -- | Get the position of the scroll bar. scrollPos :: EventScroll -> Int scrollPos scroll = case scroll of - ScrollTop orient pos -> pos - ScrollBottom orient pos -> pos - ScrollLineUp orient pos -> pos - ScrollLineDown orient pos -> pos - ScrollPageUp orient pos -> pos - ScrollPageDown orient pos -> pos - ScrollTrack orient pos -> pos - ScrollRelease orient pos -> pos + ScrollTop _orient pos -> pos + ScrollBottom _orient pos -> pos + ScrollLineUp _orient pos -> pos + ScrollLineDown _orient pos -> pos + ScrollPageUp _orient pos -> pos + ScrollPageDown _orient pos -> pos + ScrollTrack _orient pos -> pos + ScrollRelease _orient pos -> pos @@ -776,12 +778,12 @@ -- | Get the current scroll event handler of a window. windowGetOnScroll :: Window a -> IO (EventScroll -> IO ()) windowGetOnScroll window - = unsafeWindowGetHandlerState window wxEVT_SCROLLWIN_TOP (\scroll -> skipCurrentEvent) + = unsafeWindowGetHandlerState window wxEVT_SCROLLWIN_TOP (\_scroll -> skipCurrentEvent) {-------------------------------------------------------------------------- - Html event + HTML event --------------------------------------------------------------------------} --- | Html window events +-- | HTML window events data EventHtml = HtmlCellClicked String EventMouse Point -- ^ A /cell/ is clicked. Contains the cell /id/ attribute value, the mouse event and the logical coordinates. @@ -792,16 +794,16 @@ | HtmlSetTitle String -- ^ Called when a @<title>@ tag is parsed. | HtmlUnknown - -- ^ Unrecognised html event + -- ^ Unrecognised HTML event instance Show EventHtml where show ev = case ev of - HtmlCellClicked id mouse pnt -> "Html Cell " ++ show id ++ " clicked: " ++ show mouse - HtmlLinkClicked href target id mouse p -> "Html Link " ++ show id ++ " clicked: " ++ href - HtmlCellHover id -> "Html Cell " ++ show id ++ " hover" - HtmlSetTitle title -> "Html event title: " ++ title - HtmlUnknown -> "Html event unknown" + HtmlCellClicked id' mouse _pnt -> "HTML Cell " ++ show id' ++ " clicked: " ++ show mouse + HtmlLinkClicked href _target id' _mouse _p -> "HTML Link " ++ show id' ++ " clicked: " ++ href + HtmlCellHover id' -> "HTML Cell " ++ show id' ++ " hover" + HtmlSetTitle title -> "HTML event title: " ++ title + HtmlUnknown -> "HTML event unknown" fromHtmlEvent :: WXCHtmlEvent a -> IO EventHtml fromHtmlEvent event @@ -815,31 +817,31 @@ ,(wxEVT_HTML_LINK_CLICKED, htmlLink) ,(wxEVT_HTML_SET_TITLE, htmlTitle)] - htmlTitle event - = do title <- commandEventGetString event + htmlTitle event' + = do title <- commandEventGetString event' return (HtmlSetTitle title) - htmlHover event - = do id <- wxcHtmlEventGetHtmlCellId event - return (HtmlCellHover id) + htmlHover event' + = do id' <- wxcHtmlEventGetHtmlCellId event' + return (HtmlCellHover id') - htmlClicked event - = do id <- wxcHtmlEventGetHtmlCellId event - mouseEv <- wxcHtmlEventGetMouseEvent event + htmlClicked event' + = do id' <- wxcHtmlEventGetHtmlCellId event' + mouseEv <- wxcHtmlEventGetMouseEvent event' mouse <- fromMouseEvent mouseEv - pnt <- wxcHtmlEventGetLogicalPosition event - return (HtmlCellClicked id mouse pnt) + pnt <- wxcHtmlEventGetLogicalPosition event' + return (HtmlCellClicked id' mouse pnt) - htmlLink event - = do id <- wxcHtmlEventGetHtmlCellId event - mouseEv <- wxcHtmlEventGetMouseEvent event + htmlLink event' + = do id' <- wxcHtmlEventGetHtmlCellId event' + mouseEv <- wxcHtmlEventGetMouseEvent event' mouse <- fromMouseEvent mouseEv - href <- wxcHtmlEventGetHref event - target <- wxcHtmlEventGetTarget event - pnt <- wxcHtmlEventGetLogicalPosition event - return (HtmlLinkClicked href target id mouse pnt) + href <- wxcHtmlEventGetHref event' + target <- wxcHtmlEventGetTarget event' + pnt <- wxcHtmlEventGetLogicalPosition event' + return (HtmlLinkClicked href target id' mouse pnt) --- | Set a html event handler for a html window. The first argument determines whether +-- | Set a html event handler for a HTML window. The first argument determines whether -- hover events ('HtmlCellHover') are handled or not. htmlWindowOnHtmlEvent :: WXCHtmlWindow a -> Bool -> (EventHtml -> IO ()) -> IO () htmlWindowOnHtmlEvent window allowHover handler @@ -853,10 +855,10 @@ = do eventHtml <- fromHtmlEvent (objectCast event) handler eventHtml --- | Get the current html event handler of a html window. +-- | Get the current HTML event handler of a HTML window. htmlWindowGetOnHtmlEvent :: WXCHtmlWindow a -> IO (EventHtml -> IO ()) htmlWindowGetOnHtmlEvent window - = unsafeWindowGetHandlerState window wxEVT_HTML_CELL_CLICKED (\ev -> skipCurrentEvent) + = unsafeWindowGetHandlerState window wxEVT_HTML_CELL_CLICKED (\_ev -> skipCurrentEvent) @@ -866,27 +868,27 @@ -----------------------------------------------------------------------------------------} -- | Adds a close handler to the currently installed close handlers. windowAddOnClose :: Window a -> IO () -> IO () -windowAddOnClose window new +windowAddOnClose window new' = do prev <- windowGetOnClose window - windowOnClose window (do{ new; prev }) + windowOnClose window (do { new'; prev }) -- | Set an event handler that is called when the user tries to close a frame or dialog. -- Don't forget to call the previous handler or 'frameDestroy' explicitly or otherwise the -- frame won't be closed. windowOnClose :: Window a -> IO () -> IO () windowOnClose window eventHandler - = windowOnEvent window [wxEVT_CLOSE_WINDOW] eventHandler (\ev -> eventHandler) + = windowOnEvent window [wxEVT_CLOSE_WINDOW] eventHandler (\_ev -> eventHandler) -- | Get the current close event handler. windowGetOnClose :: Window a -> IO (IO ()) windowGetOnClose window - = unsafeWindowGetHandlerState window wxEVT_CLOSE_WINDOW (do windowDestroy window; return ()) + = unsafeWindowGetHandlerState window wxEVT_CLOSE_WINDOW (windowDestroy window >> return ()) -- | Set an event handler that is called when the window is destroyed. --- /Note: does not seem to work on windows/. +-- /Note: does not seem to work on Windows/. windowOnDestroy :: Window a -> IO () -> IO () windowOnDestroy window eventHandler - = windowOnEvent window [wxEVT_DESTROY] eventHandler (\ev -> eventHandler) + = windowOnEvent window [wxEVT_DESTROY] eventHandler (\_ev -> eventHandler) -- | Get the current destroy event handler. windowGetOnDestroy :: Window a -> IO (IO ()) @@ -900,15 +902,15 @@ -- > windowOnDelete window (do{ new; prev }) windowAddOnDelete :: Window a -> IO () -> IO () -windowAddOnDelete window new +windowAddOnDelete window new' = do prev <- windowGetOnDelete window - windowOnDelete window (do{ new; prev }) + windowOnDelete window (do { new'; prev }) -- | Set an event handler that is called when the window is deleted. -- Use with care as the window itself is in a deletion state. windowOnDelete :: Window a -> IO () -> IO () windowOnDelete window eventHandler - = windowOnEventEx window [wxEVT_DELETE] eventHandler onDelete (\ev -> return ()) + = windowOnEventEx window [wxEVT_DELETE] eventHandler onDelete (\_ev -> return ()) where onDelete ownerDeleted | ownerDeleted = eventHandler @@ -923,7 +925,7 @@ -- | Set an event handler that is called when the window is created. windowOnCreate :: Window a -> IO () -> IO () windowOnCreate window eventHandler - = windowOnEvent window [wxEVT_CREATE] eventHandler (\ev -> eventHandler) + = windowOnEvent window [wxEVT_CREATE] eventHandler (\_ev -> eventHandler) -- | Get the current create event handler. windowGetOnCreate :: Window a -> IO (IO ()) @@ -933,7 +935,7 @@ -- | Set an event handler that is called when the window is resized. windowOnSize :: Window a -> IO () -> IO () windowOnSize window eventHandler - = windowOnEvent window [wxEVT_SIZE] eventHandler (\ev -> eventHandler) + = windowOnEvent window [wxEVT_SIZE] eventHandler (\_ev -> eventHandler) -- | Get the current resize event handler. windowGetOnSize :: Window a -> IO (IO ()) @@ -953,7 +955,7 @@ -- | Get the current activate event handler. windowGetOnActivate :: Window a -> IO (Bool -> IO ()) windowGetOnActivate window - = unsafeWindowGetHandlerState window wxEVT_ACTIVATE (\active -> return ()) + = unsafeWindowGetHandlerState window wxEVT_ACTIVATE (\_active -> return ()) -- | Set an event handler that is called when the window gets or loses the focus. -- The event parameter is 'True' when the window gets the focus. @@ -962,22 +964,22 @@ = do windowOnEvent window [wxEVT_SET_FOCUS] eventHandler getFocusHandler windowOnEvent window [wxEVT_KILL_FOCUS] eventHandler killFocusHandler where - getFocusHandler event + getFocusHandler _event = eventHandler True - killFocusHandler event + killFocusHandler _event = eventHandler False -- | Get the current focus event handler. windowGetOnFocus :: Window a -> IO (Bool -> IO ()) windowGetOnFocus window - = unsafeWindowGetHandlerState window wxEVT_SET_FOCUS (\getfocus -> return ()) + = unsafeWindowGetHandlerState window wxEVT_SET_FOCUS (\_getfocus -> return ()) --- | A context menu event is generated when the user righ-clicks in a window +-- | A context menu event is generated when the user right-clicks in a window -- or presses shift-F10. windowOnContextMenu :: Window a -> IO () -> IO () windowOnContextMenu window eventHandler - = windowOnEvent window [wxEVT_CONTEXT_MENU] eventHandler (\ev -> eventHandler) + = windowOnEvent window [wxEVT_CONTEXT_MENU] eventHandler (\_ev -> eventHandler) -- | Get the current context menu event handler. windowGetOnContextMenu :: Window a -> IO (IO ()) @@ -987,13 +989,13 @@ -- | A menu event is generated when the user selects a menu item. -- You should install this handler on the window that owns the menubar or a popup menu. evtHandlerOnMenuCommand :: EvtHandler a -> Id -> IO () -> IO () -evtHandlerOnMenuCommand window id eventHandler - = evtHandlerOnEvent window id id [wxEVT_COMMAND_MENU_SELECTED] eventHandler (\_ -> return ()) (\ev -> eventHandler) +evtHandlerOnMenuCommand window id' eventHandler + = evtHandlerOnEvent window id' id' [wxEVT_COMMAND_MENU_SELECTED] eventHandler (\_ -> return ()) (\_ev -> eventHandler) -- | Get the current event handler for a certain menu. evtHandlerGetOnMenuCommand :: EvtHandler a -> Id -> IO (IO ()) -evtHandlerGetOnMenuCommand window id - = unsafeGetHandlerState window id wxEVT_COMMAND_MENU_SELECTED skipCurrentEvent +evtHandlerGetOnMenuCommand window id' + = unsafeGetHandlerState window id' wxEVT_COMMAND_MENU_SELECTED skipCurrentEvent -- | An idle event is generated in idle time. The handler should return whether more @@ -1018,7 +1020,7 @@ -- /Broken!/ (use 'timerOnCommand' instead). windowOnTimer :: Window a -> IO () -> IO () windowOnTimer window eventHandler - = windowOnEvent window [wxEVT_TIMER] eventHandler (\ev -> eventHandler) + = windowOnEvent window [wxEVT_TIMER] eventHandler (\_ev -> eventHandler) -- | Get the current timer handler. windowGetOnTimer :: Window a -> IO (IO ()) @@ -1042,23 +1044,23 @@ = do obj <- eventGetEventObject event if (obj==objectNull) then return () - else do let window = objectCast obj - region <- windowGetUpdateRects window - view <- windowGetViewRect window - withPaintDC window (\paintDC -> - do isScrolled <- objectIsScrolledWindow window - when (isScrolled) (scrolledWindowPrepareDC (objectCast window) paintDC) + else do let window' = objectCast obj + region <- windowGetUpdateRects window' + view <- windowGetViewRect window' + withPaintDC window' (\paintDC -> + do isScrolled <- objectIsScrolledWindow window' + when (isScrolled) (scrolledWindowPrepareDC (objectCast window') paintDC) paintHandler paintDC view region) -- | Get the current /raw/ paint event handler. windowGetOnPaintRaw :: Window a -> IO (PaintDC () -> Rect -> [Rect] -> IO ()) windowGetOnPaintRaw window - = unsafeWindowGetHandlerState window wxEVT_PAINT (\dc rect region -> return ()) + = unsafeWindowGetHandlerState window wxEVT_PAINT (\_dc _rect _region -> return ()) -- | Get the current paint event handler. windowGetOnPaintGc :: Window a -> IO (GCDC () -> Rect -> IO ()) windowGetOnPaintGc window - = unsafeWindowGetHandlerState window wxEVT_PAINT (\dc view -> return ()) + = unsafeWindowGetHandlerState window wxEVT_PAINT (\_dc _view -> return ()) -- | Set an event handler for paint events. The implementation uses an @@ -1074,7 +1076,7 @@ = do v <- varCreate objectNull windowOnEventEx window [wxEVT_PAINT] paintHandler (destroy v) (onPaint v) where - destroy v ownerDeleted + destroy v _ownerDeleted = do bitmap <- varSwap v objectNull when (not (objectIsNull bitmap)) (bitmapDelete bitmap) @@ -1082,11 +1084,11 @@ = do obj <- eventGetEventObject event if (obj==objectNull) then return () - else do let window = objectCast obj - view <- windowGetViewRect window + else do let window' = objectCast obj + view <- windowGetViewRect window' withPaintDC window (\paintDC -> - do isScrolled <- objectIsScrolledWindow window - when (isScrolled) (scrolledWindowPrepareDC (objectCast window) paintDC) + do isScrolled <- objectIsScrolledWindow window' + when (isScrolled) (scrolledWindowPrepareDC (objectCast window') paintDC) -- Note: wxMSW 2.4 does not clear the properly scrolled view rectangle. let clear dc | wxToolkit == WxMSW = dcClearRect dc view | otherwise = dcClear dc @@ -1110,7 +1112,7 @@ = do v <- varCreate objectNull windowOnEventEx window [wxEVT_PAINT] paintHandler (destroy v) (onPaint v) where - destroy v ownerDeleted + destroy v _ownerDeleted = do bitmap <- varSwap v objectNull when (not (objectIsNull bitmap)) (bitmapDelete bitmap) @@ -1118,11 +1120,11 @@ = do obj <- eventGetEventObject event if (obj==objectNull) then return () - else do let window = objectCast obj - view <- windowGetViewRect window + else do let window' = objectCast obj + view <- windowGetViewRect window' withPaintDC window (\paintDC -> - do isScrolled <- objectIsScrolledWindow window - when (isScrolled) (scrolledWindowPrepareDC (objectCast window) paintDC) + do isScrolled <- objectIsScrolledWindow window' + when (isScrolled) (scrolledWindowPrepareDC (objectCast window') paintDC) -- Note: wxMSW 2.4 does not clear the properly scrolled view rectangle. let clear dc | wxToolkit == WxMSW = dcClearRect dc view | otherwise = dcClear dc @@ -1132,7 +1134,7 @@ -- | Get the current paint event handler. windowGetOnPaint :: Window a -> IO (DC () -> Rect -> IO ()) windowGetOnPaint window - = unsafeWindowGetHandlerState window wxEVT_PAINT (\dc view -> return ()) + = unsafeWindowGetHandlerState window wxEVT_PAINT (\_dc _view -> return ()) -- Get the logical /dirty/ rectangles as a list of 'Rect'. @@ -1166,7 +1168,7 @@ evtHandlerOnEndProcess evtHandler handler = evtHandlerOnEvent evtHandler (-1) (-1) [wxEVT_END_PROCESS] handler onDelete onEndProcess where - onDelete ownerDeleted + onDelete _ownerDeleted = return () onEndProcess event @@ -1179,7 +1181,7 @@ -- | Retrieve the current end process handler. evtHandlerGetOnEndProcess :: EvtHandler a -> IO (Int -> Int -> IO ()) evtHandlerGetOnEndProcess evtHandler - = unsafeGetHandlerState evtHandler (-1) wxEVT_END_PROCESS (\pid code -> return ()) + = unsafeGetHandlerState evtHandler (-1) wxEVT_END_PROCESS (\_pid _code -> return ()) -- | The status of a stream (see 'StreamBase') @@ -1201,7 +1203,7 @@ -- | Install an event handler on an input stream. The handler is called -- whenever input is read (or when an error occurred). The third parameter --- gives the size of the input batches. The orignal input stream should no longer be referenced after this call! +-- gives the size of the input batches. The original input stream should no longer be referenced after this call! evtHandlerOnInput :: EvtHandler b -> (String -> StreamStatus -> IO ()) -> InputStream a -> Int -> IO () evtHandlerOnInput evtHandler handler stream bufferLen = do sink <- inputSinkCreate stream evtHandler bufferLen @@ -1212,10 +1214,10 @@ -- use the 'evtHandlerOnInput' whenever retrieval of the handler is not necessary. evtHandlerOnInputSink :: EvtHandler b -> (String -> StreamStatus -> IO ()) -> InputSink a -> IO () evtHandlerOnInputSink evtHandler handler sink - = do id <- inputSinkGetId sink - evtHandlerOnEvent evtHandler id id [wxEVT_INPUT_SINK] handler onDelete onInput + = do id' <- inputSinkGetId sink + evtHandlerOnEvent evtHandler id' id' [wxEVT_INPUT_SINK] handler onDelete onInput where - onDelete ownerDeleted + onDelete _ownerDeleted = return () onInput event @@ -1228,7 +1230,7 @@ -- | Retrieve the current input stream handler. evtHandlerGetOnInputSink :: EvtHandler b -> IO (String -> StreamStatus -> IO ()) evtHandlerGetOnInputSink evtHandler - = unsafeGetHandlerState evtHandler (-1) wxEVT_INPUT_SINK (\input status -> return ()) + = unsafeGetHandlerState evtHandler (-1) wxEVT_INPUT_SINK (\_input _status -> return ()) -- | Read the input from an 'InputSinkEvent'. inputSinkEventLastString :: InputSinkEvent a -> IO String @@ -1292,12 +1294,12 @@ -- | Test if no shift, alt, or control key was pressed. isNoShiftAltControlDown :: Modifiers -> Bool -isNoShiftAltControlDown (Modifiers shift control alt meta) = not (shift || control || alt) +isNoShiftAltControlDown (Modifiers shift control alt _meta) = not (shift || control || alt) -- | Tranform modifiers into an accelerator modifiers code. modifiersToAccelFlags :: Modifiers -> Int -modifiersToAccelFlags mod - = mask (altDown mod) 0x01 + mask (controlDown mod) 0x02 + mask (shiftDown mod) 0x04 +modifiersToAccelFlags mod' + = mask (altDown mod') 0x01 + mask (controlDown mod') 0x02 + mask (shiftDown mod') 0x04 where mask test flag = if test then flag else 0 @@ -1337,101 +1339,101 @@ (Point x y) = mousePos mouse action = case mouse of - MouseMotion p m -> "Motion" - MouseEnter p m -> "Enter" - MouseLeave p m -> "Leave" - MouseLeftDown p m -> "Left down" - MouseLeftUp p m -> "Left up" - MouseLeftDClick p m -> "Left double click" - MouseLeftDrag p m -> "Left drag" - MouseRightDown p m -> "Right down" - MouseRightUp p m -> "Right up" - MouseRightDClick p m -> "Right double click" - MouseRightDrag p m -> "Right drag" - MouseMiddleDown p m -> "Middle down" - MouseMiddleUp p m -> "Middle up" - MouseMiddleDClick p m -> "Middle double click" - MouseMiddleDrag p m -> "Middle drag" - MouseWheel down p m -> "Wheel " ++ (if down then "down" else "up") + MouseMotion _p _m -> "Motion" + MouseEnter _p _m -> "Enter" + MouseLeave _p _m -> "Leave" + MouseLeftDown _p _m -> "Left down" + MouseLeftUp _p _m -> "Left up" + MouseLeftDClick _p _m -> "Left double click" + MouseLeftDrag _p _m -> "Left drag" + MouseRightDown _p _m -> "Right down" + MouseRightUp _p _m -> "Right up" + MouseRightDClick _p _m -> "Right double click" + MouseRightDrag _p _m -> "Right drag" + MouseMiddleDown _p _m -> "Middle down" + MouseMiddleUp _p _m -> "Middle up" + MouseMiddleDClick _p _m -> "Middle double click" + MouseMiddleDrag _p _m -> "Middle drag" + MouseWheel down _p _m -> "Wheel " ++ (if down then "down" else "up") -- | Extract the position from a 'MouseEvent'. mousePos :: EventMouse -> Point mousePos mouseEvent = case mouseEvent of - MouseMotion p m -> p - MouseEnter p m -> p - MouseLeave p m -> p - MouseLeftDown p m -> p - MouseLeftUp p m -> p - MouseLeftDClick p m -> p - MouseLeftDrag p m -> p - MouseRightDown p m -> p - MouseRightUp p m -> p - MouseRightDClick p m -> p - MouseRightDrag p m -> p - MouseMiddleDown p m -> p - MouseMiddleUp p m -> p - MouseMiddleDClick p m -> p - MouseMiddleDrag p m -> p - MouseWheel _ p m -> p + MouseMotion p _m -> p + MouseEnter p _m -> p + MouseLeave p _m -> p + MouseLeftDown p _m -> p + MouseLeftUp p _m -> p + MouseLeftDClick p _m -> p + MouseLeftDrag p _m -> p + MouseRightDown p _m -> p + MouseRightUp p _m -> p + MouseRightDClick p _m -> p + MouseRightDrag p _m -> p + MouseMiddleDown p _m -> p + MouseMiddleUp p _m -> p + MouseMiddleDClick p _m -> p + MouseMiddleDrag p _m -> p + MouseWheel _ p _m -> p -- | Extract the modifiers from a 'MouseEvent'. mouseModifiers :: EventMouse -> Modifiers mouseModifiers mouseEvent = case mouseEvent of - MouseMotion p m -> m - MouseEnter p m -> m - MouseLeave p m -> m - MouseLeftDown p m -> m - MouseLeftUp p m -> m - MouseLeftDClick p m -> m - MouseLeftDrag p m -> m - MouseRightDown p m -> m - MouseRightUp p m -> m - MouseRightDClick p m -> m - MouseRightDrag p m -> m - MouseMiddleDown p m -> m - MouseMiddleUp p m -> m - MouseMiddleDClick p m -> m - MouseMiddleDrag p m -> m - MouseWheel _ p m -> m + MouseMotion _p m -> m + MouseEnter _p m -> m + MouseLeave _p m -> m + MouseLeftDown _p m -> m + MouseLeftUp _p m -> m + MouseLeftDClick _p m -> m + MouseLeftDrag _p m -> m + MouseRightDown _p m -> m + MouseRightUp _p m -> m + MouseRightDClick _p m -> m + MouseRightDrag _p m -> m + MouseMiddleDown _p m -> m + MouseMiddleUp _p m -> m + MouseMiddleDClick _p m -> m + MouseMiddleDrag _p m -> m + MouseWheel _ _p m -> m fromMouseEvent :: MouseEvent a -> IO EventMouse fromMouseEvent event = do x <- mouseEventGetX event y <- mouseEventGetY event obj <- eventGetEventObject event - point <- windowCalcUnscrolledPosition (objectCast obj) (Point x y) + point' <- windowCalcUnscrolledPosition (objectCast obj) (Point x y) - altDown <- mouseEventAltDown event - controlDown <- mouseEventControlDown event - shiftDown <- mouseEventShiftDown event - metaDown <- mouseEventMetaDown event - let modifiers = Modifiers altDown shiftDown controlDown metaDown + altDown' <- mouseEventAltDown event + controlDown' <- mouseEventControlDown event + shiftDown' <- mouseEventShiftDown event + metaDown' <- mouseEventMetaDown event + let modifiers = Modifiers altDown' shiftDown' controlDown' metaDown' dragging <- mouseEventDragging event if (dragging) then do leftDown <- mouseEventLeftIsDown event if (leftDown) - then return (MouseLeftDrag point modifiers) + then return (MouseLeftDrag point' modifiers) else do middleDown <- mouseEventMiddleIsDown event if (middleDown) - then return (MouseMiddleDrag point modifiers) + then return (MouseMiddleDrag point' modifiers) else do rightDown <- mouseEventRightIsDown event if (rightDown) - then return (MouseRightDrag point modifiers) - else return (MouseMotion point modifiers) + then return (MouseRightDrag point' modifiers) + else return (MouseMotion point' modifiers) else do tp <- eventGetEventType event case lookup tp mouseEventTypes of - Just mouse -> return (mouse point modifiers) + Just mouse -> return (mouse point' modifiers) Nothing -> if (tp==wxEVT_MOUSEWHEEL) then do rot <- mouseEventGetWheelRotation event delta <- mouseEventGetWheelDelta event if (abs rot >= delta) - then return (MouseWheel (rot<0) point modifiers) - else return (MouseMotion point modifiers) - else return (MouseMotion point modifiers) + then return (MouseWheel (rot<0) point' modifiers) + else return (MouseMotion point' modifiers) + else return (MouseMotion point' modifiers) mouseEventTypes :: [(Int,Point -> Modifiers -> EventMouse)] mouseEventTypes @@ -1465,7 +1467,7 @@ -- | Get the current mouse event handler of a window. windowGetOnMouse :: Window a -> IO (EventMouse -> IO ()) windowGetOnMouse window - = unsafeWindowGetHandlerState window wxEVT_ENTER_WINDOW (\ev -> skipCurrentEvent) + = unsafeWindowGetHandlerState window wxEVT_ENTER_WINDOW (\_ev -> skipCurrentEvent) {----------------------------------------------------------------------------------------- @@ -1484,7 +1486,7 @@ -- | Get the current key down handler of a window. windowGetOnKeyDown :: Window a -> IO (EventKey -> IO ()) windowGetOnKeyDown window - = unsafeWindowGetHandlerState window wxEVT_KEY_DOWN (\eventKey -> skipCurrentEvent) + = unsafeWindowGetHandlerState window wxEVT_KEY_DOWN (\_eventKey -> skipCurrentEvent) -- | Set an event handler for translated key presses. @@ -1499,7 +1501,7 @@ -- | Get the current translated key handler of a window. windowGetOnKeyChar :: Window a -> IO (EventKey -> IO ()) windowGetOnKeyChar window - = unsafeWindowGetHandlerState window wxEVT_CHAR (\eventKey -> skipCurrentEvent) + = unsafeWindowGetHandlerState window wxEVT_CHAR (\_eventKey -> skipCurrentEvent) -- | Set an event handler for (untranslated) key releases. @@ -1514,28 +1516,28 @@ -- | Get the current key release handler of a window. windowGetOnKeyUp :: Window a -> IO (EventKey -> IO ()) windowGetOnKeyUp window - = unsafeWindowGetHandlerState window wxEVT_KEY_UP (\keyInfo -> skipCurrentEvent) + = unsafeWindowGetHandlerState window wxEVT_KEY_UP (\_keyInfo -> skipCurrentEvent) eventKeyFromEvent :: KeyEvent a -> IO EventKey eventKeyFromEvent event = do x <- keyEventGetX event y <- keyEventGetY event - obj <- eventGetEventObject event - point <- if objectIsNull obj + obj <- eventGetEventObject event + point' <- if objectIsNull obj then return (Point x y) else windowCalcUnscrolledPosition (objectCast obj) (Point x y) - altDown <- keyEventAltDown event - controlDown <- keyEventControlDown event - shiftDown <- keyEventShiftDown event - metaDown <- keyEventMetaDown event - let modifiers = Modifiers altDown shiftDown controlDown metaDown + altDown' <- keyEventAltDown event + controlDown' <- keyEventControlDown event + shiftDown' <- keyEventShiftDown event + metaDown' <- keyEventMetaDown event + let modifiers = Modifiers altDown' shiftDown' controlDown' metaDown' keyCode <- keyEventGetKeyCode event let key = keyCodeToKey keyCode - return (EventKey key modifiers point) + return (EventKey key modifiers point') @@ -1545,15 +1547,15 @@ -- | Extract the key from a keyboard event. keyKey :: EventKey -> Key -keyKey (EventKey key mods pos) = key +keyKey (EventKey key _mods _pos) = key -- | Extract the modifiers from a keyboard event. keyModifiers :: EventKey -> Modifiers -keyModifiers (EventKey key mods pos) = mods +keyModifiers (EventKey _key mods _pos) = mods -- | Extract the position from a keyboard event. keyPos :: EventKey -> Point -keyPos (EventKey key mods pos) = pos +keyPos (EventKey _key _mods pos) = pos -- | A low-level virtual key code. @@ -1764,7 +1766,7 @@ -- Use a big-endian patricia tree to efficiently map key codes to Haskell keys. -- Since it is a static map, we could maybe use one of Knuth's optimally balanced -- trees.... --- keyCodeMap :: IntMap.IntMap Key +keyCodeMap :: IntMap.IntMap Key keyCodeMap = IntMap.fromList [(wxK_BACK , KeyBack) @@ -2005,45 +2007,54 @@ -- | Set an event handler that is called when the drop target can be filled with data. -- This function require to use 'dropTargetGetData' in your event handler to fill data. dropTargetOnData :: DropTarget a -> (Point -> DragResult -> IO DragResult) -> IO () -dropTargetOnData drop event = do +dropTargetOnData drop' event = do funPtr <- dragThreeFuncHandler event - wxcDropTargetSetOnData (objectCast drop) (toCFunPtr funPtr) + wxcDropTargetSetOnData (objectCast drop') (toCFunPtr funPtr) --- | Set an event handler for an drop command in a drop target. +-- | Set an event handler for an drop' command in a drop' target. dropTargetOnDrop :: DropTarget a -> (Point -> IO Bool) -> IO () -dropTargetOnDrop drop event = do +dropTargetOnDrop drop' event = do funPtr <- dragTwoFuncHandler event - wxcDropTargetSetOnDrop (objectCast drop) (toCFunPtr funPtr) + wxcDropTargetSetOnDrop (objectCast drop') (toCFunPtr funPtr) --- | Set an event handler for an enter command in a drop target. +-- | Set an event handler for an enter command in a drop' target. dropTargetOnEnter :: DropTarget a -> (Point -> DragResult -> IO DragResult) -> IO () -dropTargetOnEnter drop event = do +dropTargetOnEnter drop' event = do funPtr <- dragThreeFuncHandler event - wxcDropTargetSetOnEnter (objectCast drop) (toCFunPtr funPtr) + wxcDropTargetSetOnEnter (objectCast drop') (toCFunPtr funPtr) --- | Set an event handler for a drag over command in a drop target. +-- | Set an event handler for a drag over command in a drop' target. dropTargetOnDragOver :: DropTarget a -> (Point -> DragResult -> IO DragResult) -> IO () -dropTargetOnDragOver drop event = do +dropTargetOnDragOver drop' event = do funPtr <- dragThreeFuncHandler event - wxcDropTargetSetOnDragOver (objectCast drop) (toCFunPtr funPtr) + wxcDropTargetSetOnDragOver (objectCast drop') (toCFunPtr funPtr) --- | Set an event handler for a leave command in a drop target. +-- | Set an event handler for a leave command in a drop' target. dropTargetOnLeave :: DropTarget a -> (IO ()) -> IO () -dropTargetOnLeave drop event = do +dropTargetOnLeave drop' event = do funPtr <- dragZeroFuncHandler event - wxcDropTargetSetOnLeave (objectCast drop) (toCFunPtr funPtr) + wxcDropTargetSetOnLeave (objectCast drop') (toCFunPtr funPtr) +dragZeroFuncHandler :: IO () -> IO (FunPtr (Ptr obj -> IO ())) dragZeroFuncHandler event = - dragZeroFunc $ \obj -> do + dragZeroFunc $ \_obj -> do event +dragTwoFuncHandler :: Num a + => (Point2 a -> IO Bool) + -> IO (FunPtr (Ptr obj -> CInt -> CInt -> IO CInt)) dragTwoFuncHandler event = - dragTwoFunc $ \obj x y -> do - result <- event (point (fromIntegral x) (fromIntegral y)) + dragTwoFunc $ \_obj x y -> do + result <- event (point (fromIntegral x) (fromIntegral y)) return $ fromBool result +dragThreeFuncHandler :: Num a + => (Point2 a + -> DragResult + -> IO DragResult) + -> IO (FunPtr (Ptr obj -> CInt -> CInt -> CInt -> IO CInt)) dragThreeFuncHandler event = - dragThreeFunc $ \obj x y pre -> do + dragThreeFunc $ \_obj x y pre -> do result <- event (point (fromIntegral x) (fromIntegral y)) (toDragResult $ fromIntegral pre) return $ fromIntegral $ fromDragResult result @@ -2065,8 +2076,13 @@ dropTargetSetDataObject textDrop textData windowSetDropTarget window textDrop +dropTextHandler :: Num a + =>(Point2 a -> String -> IO ()) + -> IO (FunPtr + (Ptr obj -> CInt -> CInt -> Ptr CWchar -> IO ()) + ) dropTextHandler event = - wrapTextDropHandler $ \obj x y cstr -> do + wrapTextDropHandler $ \_obj x y cstr -> do str <- peekCWString cstr event (point (fromIntegral x) (fromIntegral y)) str @@ -2077,8 +2093,13 @@ fileDrop <- wxcFileDropTargetCreate nullPtr (toCFunPtr funPtr) windowSetDropTarget window fileDrop +dropFileHandler :: Num a + => (Point2 a -> [String] -> IO ()) + -> IO (FunPtr + (Ptr obj -> CInt -> CInt -> Ptr (Ptr CWchar) -> CInt -> IO ()) + ) dropFileHandler event = - wrapFileDropHandler $ \obj x y carr size -> do + wrapFileDropHandler $ \_obj x y carr size -> do arr <- peekArray (fromIntegral size) carr files <- mapM peekCWString arr event (point (fromIntegral x) (fromIntegral y)) files @@ -2146,13 +2167,13 @@ ] where gridMouse make makeMouse gridEvent row col - = do pt <- gridEventGetPosition gridEvent - altDown <- gridEventAltDown gridEvent - controlDown <- gridEventControlDown gridEvent - shiftDown <- gridEventShiftDown gridEvent - metaDown <- gridEventMetaDown gridEvent - let modifiers = Modifiers altDown shiftDown controlDown metaDown - return (make row col (makeMouse pt modifiers)) + = do pt' <- gridEventGetPosition gridEvent + altDown' <- gridEventAltDown gridEvent + controlDown' <- gridEventControlDown gridEvent + shiftDown' <- gridEventShiftDown gridEvent + metaDown' <- gridEventMetaDown gridEvent + let modifiers = Modifiers altDown' shiftDown' controlDown' metaDown' + return (make row col (makeMouse pt' modifiers)) gridVeto make gridEvent row col = return (make row col (notifyEventVeto gridEvent)) @@ -2178,7 +2199,7 @@ -- | Get the current grid event handler of a window. gridGetOnGridEvent :: Grid a -> IO (EventGrid -> IO ()) gridGetOnGridEvent grid - = unsafeWindowGetHandlerState grid wxEVT_GRID_CELL_CHANGED (\event -> skipCurrentEvent) + = unsafeWindowGetHandlerState grid wxEVT_GRID_CELL_CHANGED (\_event -> skipCurrentEvent) {----------------------------------------------------------------------------------------- @@ -2246,8 +2267,8 @@ return (TreeEndLabelEdit item lab can (notifyEventVeto treeEvent)) fromDragEvent make treeEvent item - = do pt <- treeEventGetPoint treeEvent - return (make item pt) + = do pt' <- treeEventGetPoint treeEvent + return (make item pt') fromChangeEvent make treeEvent item = do olditem <- treeEventGetOldItem treeEvent @@ -2261,7 +2282,7 @@ = do f <- make treeEvent item return (f (notifyEventVeto treeEvent)) - fromItemEvent make treeEvent item + fromItemEvent make _treeEvent item = return (make item) @@ -2278,7 +2299,7 @@ -- | Get the current tree event handler of a window. treeCtrlGetOnTreeEvent :: TreeCtrl a -> IO (EventTree -> IO ()) treeCtrlGetOnTreeEvent treeCtrl - = unsafeWindowGetHandlerState treeCtrl wxEVT_COMMAND_TREE_ITEM_ACTIVATED (\event -> skipCurrentEvent) + = unsafeWindowGetHandlerState treeCtrl wxEVT_COMMAND_TREE_ITEM_ACTIVATED (\_event -> skipCurrentEvent) {----------------------------------------------------------------------------------------- @@ -2339,13 +2360,13 @@ ,(wxEVT_COMMAND_LIST_COL_RIGHT_CLICK, withColumn ListColRightClick) ,(wxEVT_COMMAND_LIST_CACHE_HINT, withCache ListCacheHint ) ,(wxEVT_COMMAND_LIST_KEY_DOWN, withKeyCode ListKeyDown ) - ,(wxEVT_COMMAND_LIST_DELETE_ALL_ITEMS, \event -> return ListDeleteAllItems ) + ,(wxEVT_COMMAND_LIST_DELETE_ALL_ITEMS, \_event -> return ListDeleteAllItems ) ] where withPoint make listEvent = do f <- make listEvent - pt <- listEventGetPoint listEvent - return (f pt) + pt' <- listEventGetPoint listEvent + return (f pt') withCancel make listEvent = do f <- make listEvent @@ -2389,7 +2410,7 @@ -- | Get the current list event handler of a window. listCtrlGetOnListEvent :: ListCtrl a -> IO (EventList -> IO ()) listCtrlGetOnListEvent listCtrl - = unsafeWindowGetHandlerState listCtrl wxEVT_COMMAND_LIST_ITEM_ACTIVATED (\event -> skipCurrentEvent) + = unsafeWindowGetHandlerState listCtrl wxEVT_COMMAND_LIST_ITEM_ACTIVATED (\_event -> skipCurrentEvent) ------------------------------------------------------------------------------------------ @@ -2442,8 +2463,8 @@ -- | Get the current event handler for a taskbar icon. evtHandlerGetOnTaskBarIconEvent :: EvtHandler a -> Id -> EventTaskBarIcon -> IO (IO ()) -evtHandlerGetOnTaskBarIconEvent window id evt - = unsafeGetHandlerState window id +evtHandlerGetOnTaskBarIconEvent window id' evt + = unsafeGetHandlerState window id' (fromMaybe wxEVT_TASKBAR_MOVE $ lookup evt $ uncurry (flip zip) . unzip $ taskBarIconEvents) skipCurrentEvent @@ -2507,7 +2528,7 @@ wizardGetOnWizEvent :: Wizard a -> IO (EventWizard -> IO ()) wizardGetOnWizEvent wiz -- not sure about the wxEVT_WIZARD_PAGE_CHANGED - = unsafeWindowGetHandlerState wiz wxEVT_WIZARD_PAGE_CHANGED (\event -> skipCurrentEvent) + = unsafeWindowGetHandlerState wiz wxEVT_WIZARD_PAGE_CHANGED (\_event -> skipCurrentEvent) {----------------------------------------------------------------------------------------- @@ -2552,7 +2573,7 @@ propertyGridGetOnPropertyGridEvent :: PropertyGrid a -> IO (EventPropertyGrid -> IO ()) propertyGridGetOnPropertyGridEvent propertyGrid -- I'm not sure what expEVT_PG_HIGHLIGHTED needs to be here for, just followed pattern with `listCtrlGetOnListEvent' - = unsafeWindowGetHandlerState propertyGrid wxEVT_PG_HIGHLIGHTED (\event -> skipCurrentEvent) + = unsafeWindowGetHandlerState propertyGrid wxEVT_PG_HIGHLIGHTED (\_event -> skipCurrentEvent) {----------------------------------------------------------------------------------------- AuiNotebook events @@ -2612,20 +2633,24 @@ ,(wxEVT_AUINOTEBOOK_TAB_RIGHT_UP, auiWithSelection nb AuiNotebookTabRightUp)] -auiWithSelection nb eventAN auiNEvent = do - selection <- bookCtrlEventGetSelection auiNEvent - oldSelection <- bookCtrlEventGetOldSelection auiNEvent - eventObj <- eventGetEventObject auiNEvent - winSel <- fromSelId nb eventObj selection auiNEvent - winOldSel <- fromSelId nb eventObj oldSelection auiNEvent +auiWithSelection :: AuiNotebook a1 + -> (WindowSelection -> WindowSelection -> r) + -> BookCtrlEvent a + -> IO r +auiWithSelection nb' eventAN auiNEvent = do + selection <- bookCtrlEventGetSelection auiNEvent + oldSelection <- bookCtrlEventGetOldSelection auiNEvent + eventObj <- eventGetEventObject auiNEvent + winSel <- fromSelId nb' eventObj selection auiNEvent + winOldSel <- fromSelId nb' eventObj oldSelection auiNEvent return $ eventAN winSel winOldSel where - fromSelId nb eventObj selId ev = do - pageCount <- auiNotebookGetPageCount nb + fromSelId nb'' _eventObj selId _ev = do + pageCount <- auiNotebookGetPageCount nb'' if selId < pageCount && selId /= wxNOT_FOUND then do - pg <- auiNotebookGetPage nb selId - id <- windowGetId pg - return $ WindowSelection selId $ Just $ PageWindow (WindowId id) pg + pg <- auiNotebookGetPage nb'' selId + id' <- windowGetId pg + return $ WindowSelection selId $ Just $ PageWindow (WindowId id') pg else return noWindowSelection fromAuiNotebookEvent :: Object a -> String -> AuiNotebookEvent q -> IO EventAuiNotebook @@ -2638,6 +2663,7 @@ do par <- windowGetParent $ objectCast eventObj let t = (auiTabCtrlEvents . objectCast) par lookupEvent eventType t AuiTabCtrlUnknown + _ -> error $ "Graphics.UI.WXCore.Events.fromAuiNotebookEvent: Unexpected cName: " ++ cName --lookup an event in the given evtTable, if not found use defaul where lookupEvent eventType evtTable defaul = case lookup eventType evtTable of @@ -2651,7 +2677,7 @@ -- | use when you want to handle just wxAuiNotebook auiNotebookOnAuiNotebookEvent :: String -> EventId -> AuiNotebook a -> (EventAuiNotebook -> IO ()) -> IO () -auiNotebookOnAuiNotebookEvent s eventId notebook eventHandler +auiNotebookOnAuiNotebookEvent _s eventId notebook eventHandler = windowOnEvent notebook [eventId] handler (const handler) where handler = withCurrentEvent (\event -> do eventObj <- eventGetEventObject (objectCast event) @@ -2663,9 +2689,10 @@ _ -> skipCurrentEvent ) + -- | use when you want to handle both wxAuiNotebook and wxAuiTabCtrl auiNotebookOnAuiNotebookEventEx :: String -> EventId -> AuiNotebook a -> (EventAuiNotebook -> IO ()) -> IO () -auiNotebookOnAuiNotebookEventEx s eventId notebook eventHandler +auiNotebookOnAuiNotebookEventEx _s eventId notebook eventHandler = windowOnEvent notebook [eventId] handler (const handler) where handler = withCurrentEvent (\event -> do eventObj <- eventGetEventObject (objectCast event) @@ -2703,7 +2730,7 @@ -- objects. timerOnCommand :: TimerEx a -> IO () -> IO () timerOnCommand timer io - = do closure <- createClosure io (\ownerDeleted -> return ()) (\ev -> io) + = do closure <- createClosure io (\_ownerDeleted -> return ()) (\_ev -> io) timerExConnect timer closure -- | Get the current timer event handler. @@ -2729,11 +2756,12 @@ -- calls to this method chains the different idle event handlers. appRegisterIdle :: Int -> IO (IO ()) appRegisterIdle interval - = do varUpdate appIdleIntervals (interval:) + = do _ <- varUpdate appIdleIntervals (interval:) appUpdateIdleInterval return (appUnregisterIdle interval) -- Update the idle interval to the minimal one. +appUpdateIdleInterval :: IO () appUpdateIdleInterval = do ivals <- varGet appIdleIntervals let ival = if null ivals then 0 else minimum ivals -- zero is off. @@ -2745,12 +2773,12 @@ -- Unregister an idle handler appUnregisterIdle :: Int -> IO () appUnregisterIdle ival - = do varUpdate appIdleIntervals (remove ival) + = do _ <- varUpdate appIdleIntervals (remove ival) appUpdateIdleInterval where - remove ival [] = [] -- very wrong! - remove ival (i:is) | ival == i = is - | otherwise = i : remove ival is + remove _ival' [] = [] + remove ival' (i:is) | ival' == i = is + | otherwise = i : remove ival' is {----------------------------------------------------------------------------------------- @@ -2799,7 +2827,7 @@ -- | Get the current calendar event handler of a window. calendarCtrlGetOnCalEvent :: CalendarCtrl a -> IO (EventCalendar -> IO ()) calendarCtrlGetOnCalEvent calCtrl - = unsafeWindowGetHandlerState calCtrl wxEVT_CALENDAR_SEL_CHANGED (\event -> skipCurrentEvent) + = unsafeWindowGetHandlerState calCtrl wxEVT_CALENDAR_SEL_CHANGED (\_event -> skipCurrentEvent) ------------------------------------------------------------------------------------------ @@ -2809,8 +2837,8 @@ -- Note: the closure is deleted when initialization is complete, and than the Haskell init function -- is started. appOnInit :: IO () -> IO () -appOnInit init - = do closure <- createClosure (return () :: IO ()) onDelete (\ev -> return ()) -- run init on destroy ! +appOnInit initHandler + = do closure <- createClosure (return () :: IO ()) onDelete (\_ev -> return ()) -- run initHandler on destroy ! progName <- getProgName args <- getArgs argv <- mapM newCWString (progName:args) @@ -2818,8 +2846,8 @@ withArray (argv ++ [nullPtr]) $ \cargv -> wxcAppInitializeC closure argc cargv mapM_ free argv where - onDelete ownerDeleted - = init + onDelete _ownerDeleted + = initHandler @@ -2899,21 +2927,21 @@ -- | Set a generic event handler on a certain window. windowOnEvent :: Window a -> [EventId] -> handler -> (Event () -> IO ()) -> IO () windowOnEvent window eventIds state eventHandler - = windowOnEventEx window eventIds state (\ownerDelete -> return ()) eventHandler + = windowOnEventEx window eventIds state (\_ownerDelete -> return ()) eventHandler -- | Set a generic event handler on a certain window. Takes also a computation -- that is run when the event handler is destroyed -- the argument is 'True' if the -- owner is deleted, and 'False' if the event handler is disconnected for example. windowOnEventEx :: Window a -> [EventId] -> handler -> (Bool -> IO ()) -> (Event () -> IO ()) -> IO () windowOnEventEx window eventIds state destroy eventHandler - = do let id = idAny -- id <- windowGetId window - evtHandlerOnEvent window id id eventIds state destroy eventHandler + = do let id' = idAny -- id' <- windowGetId window + evtHandlerOnEvent window id' id' eventIds state destroy eventHandler -- | Retrieve the event handler state for a certain event on a window. unsafeWindowGetHandlerState :: Window a -> EventId -> b -> IO b unsafeWindowGetHandlerState window eventId def - = do id <- windowGetId window - unsafeGetHandlerState window id eventId def + = do id' <- windowGetId window + unsafeGetHandlerState window id' eventId def ------------------------------------------------------------------------------------------ -- The current event @@ -2954,12 +2982,12 @@ ------------------------------------------------------------------------------------------ -- Generic event connection ------------------------------------------------------------------------------------------ --- | Retrievs the state associated with a certain event handler. If +-- | Retrieves the state associated with a certain event handler. If -- no event handler is defined for this kind of event or 'Id', the -- default value is returned. unsafeGetHandlerState :: EvtHandler a -> Id -> EventId -> b -> IO b -unsafeGetHandlerState object id eventId def - = do closure <- evtHandlerGetClosure object id eventId +unsafeGetHandlerState object id' eventId def + = do closure <- evtHandlerGetClosure object id' eventId unsafeClosureGetState closure def -- | Type synonym to make the type signatures shorter for the documentation :-) @@ -3059,7 +3087,7 @@ when (funptr/=ptrNull) (freeHaskellFunPtr (castPtrToFunPtr funptr)) else handler event - swapMVar currentEvent prev + _ <- swapMVar currentEvent prev return ()
src/haskell/Graphics/UI/WXCore/Frame.hs view
@@ -1,11 +1,12 @@ ----------------------------------------------------------------------------------------- -{-| Module : Frame - Copyright : (c) Daan Leijen 2003 - License : wxWindows +{-| +Module : Frame +Copyright : (c) Daan Leijen 2003 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Frame utility functions. -} @@ -37,7 +38,6 @@ import Graphics.UI.WXCore.WxcDefs import Graphics.UI.WXCore.WxcClassInfo import Graphics.UI.WXCore.WxcClasses -import Graphics.UI.WXCore.WxcClassTypes import Graphics.UI.WXCore.Types @@ -131,7 +131,7 @@ if count <= 0 then return [] else withArray (replicate count ptrNull) $ \ptrs -> - do windowGetChildren w ptrs count + do _ <- windowGetChildren w ptrs count ps <- peekArray count ptrs return (map objectFromPtr ps)
src/haskell/Graphics/UI/WXCore/Image.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE FlexibleContexts #-} -------------------------------------------------------------------------------- -{-| Module : Image - Copyright : (c) Daan Leijen 2003 - License : wxWindows +{-| +Module : Image +Copyright : (c) Daan Leijen 2003 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable -} -------------------------------------------------------------------------------- module Graphics.UI.WXCore.Image @@ -57,14 +58,11 @@ import Data.Char( toLower ) import Data.Array.IArray ( IArray, listArray, bounds, elems ) import Foreign.Marshal.Array -import Foreign.C.String -import Foreign.Storable import Graphics.UI.WXCore.WxcTypes import Graphics.UI.WXCore.WxcDefs import Graphics.UI.WXCore.WxcClasses import Graphics.UI.WXCore.Types -import Graphics.UI.WXCore.Defines {----------------------------------------------------------------------------------------- @@ -82,7 +80,7 @@ = do image <- imageCreateFromFile fname imageRescale image desiredSize bitmap <- imageConvertToBitmap image - imageListAddBitmap images bitmap nullBitmap + _ <- imageListAddBitmap images bitmap nullBitmap bitmapDelete bitmap imageDelete image return () @@ -209,7 +207,7 @@ "pnm" -> wxBITMAP_TYPE_PNM "pict" -> wxBITMAP_TYPE_PICT "icon" -> wxBITMAP_TYPE_ICON - other -> wxBITMAP_TYPE_ANY + _other -> wxBITMAP_TYPE_ANY {----------------------------------------------------------------------------------------- Direct image manipulation @@ -225,17 +223,17 @@ -- | Delete a pixel buffer. pixelBufferDelete :: PixelBuffer -> IO () -pixelBufferDelete (PixelBuffer owned size buffer) +pixelBufferDelete (PixelBuffer owned _size buffer) = when (owned && not (ptrIsNull buffer)) (wxcFree buffer) -- | The size of a pixel buffer pixelBufferGetSize :: PixelBuffer -> Size -pixelBufferGetSize (PixelBuffer owned size buffer) +pixelBufferGetSize (PixelBuffer _owned size _buffer) = size -- | Get all the pixels of a pixel buffer as a single list. pixelBufferGetPixels :: PixelBuffer -> IO [Color] -pixelBufferGetPixels (PixelBuffer owned (Size w h) buffer) +pixelBufferGetPixels (PixelBuffer _owned (Size w h) buffer) = do let count = w*h rgbs <- peekArray (3*count) buffer return (convert rgbs) @@ -243,10 +241,13 @@ convert :: [Word8] -> [Color] convert (r:g:b:xs) = colorRGB r g b : convert xs convert [] = [] + convert _ = + error $ "Graphics.UI.WXCore.Image.pixelBufferGetPixels: " ++ + "Unexpected number of entries in pixelbuffer" -- | Set all the pixels of a pixel buffer. pixelBufferSetPixels :: PixelBuffer -> [Color] -> IO () -pixelBufferSetPixels (PixelBuffer owned (Size w h) buffer) colors +pixelBufferSetPixels (PixelBuffer _owned (Size w h) buffer) colors = do let count = w*h pokeArray buffer (convert (take count colors)) where @@ -257,12 +258,12 @@ -- | Initialize the pixel buffer with a grey color. The second argument -- specifies the /greyness/ as a number between 0.0 (black) and 1.0 (white). pixelBufferInit :: PixelBuffer -> Color -> IO () -pixelBufferInit (PixelBuffer owned size buffer) color +pixelBufferInit (PixelBuffer _owned size buffer) color = wxcInitPixelsRGB buffer size (intFromColor color) -- | Set the color of a pixel. pixelBufferSetPixel :: PixelBuffer -> Point -> Color -> IO () -pixelBufferSetPixel (PixelBuffer owned size buffer) point color +pixelBufferSetPixel (PixelBuffer _owned size buffer) poynt color = {- do let idx = 3*(y*w + x) r = colorRed color @@ -272,12 +273,12 @@ pokeByteOff buffer (idx+1) g pokeByteOff buffer (idx+2) b -} - wxcSetPixelRGB buffer (sizeW size) point (intFromColor color) + wxcSetPixelRGB buffer (sizeW size) poynt (intFromColor color) -- | Get the color of a pixel pixelBufferGetPixel :: PixelBuffer -> Point -> IO Color -pixelBufferGetPixel (PixelBuffer owned size buffer) point +pixelBufferGetPixel (PixelBuffer _owned size buffer) poynt = {- do let idx = 3*(y*w + x) r <- peekByteOff buffer idx @@ -285,14 +286,14 @@ b <- peekByteOff buffer (idx+2) return (colorRGB r g b) -} - do rgb <- wxcGetPixelRGB buffer (sizeW size) point - return (colorFromInt rgb) + do colr <- wxcGetPixelRGB buffer (sizeW size) poynt + return (colorFromInt colr) -- | Create an image from a pixel buffer. Note: the image will -- delete the pixelbuffer. imageCreateFromPixelBuffer :: PixelBuffer -> IO (Image ()) -imageCreateFromPixelBuffer (PixelBuffer owned size buffer) +imageCreateFromPixelBuffer (PixelBuffer _owned size buffer) = imageCreateFromDataEx size buffer False -- | Do something with the pixels of an image @@ -338,8 +339,8 @@ = do h <- imageGetHeight image w <- imageGetWidth image ps <- imageGetPixels image - let bounds = (pointZero, point (w-1) (h-1)) - return (listArray bounds ps) + let bounds' = (pointZero, point (w-1) (h-1)) + return (listArray bounds' ps) -- | Create an image from a pixel array imageCreateFromPixelArray :: (IArray a Color) => a Point Color -> IO (Image ())
src/haskell/Graphics/UI/WXCore/Layout.hs view
@@ -1,13 +1,14 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------------------- -{-| Module : Layout - Copyright : (c) Daan Leijen & Wijnand van Suijlen 2003 - License : wxWindows +{-| +Module : Layout +Copyright : (c) Daan Leijen & Wijnand van Suijlen 2003 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Combinators to specify layout. (These combinators use wxWidgets 'Sizer' objects). @@ -159,7 +160,7 @@ -- ** Vertical floating alignment , vfloatTop, vfloatCentre, vfloatCenter, vfloatBottom -- ** Alignment - , centre + , center, centre , alignTopLeft, alignTop, alignTopRight , alignLeft, alignCentre, alignCenter, alignRight , alignBottomLeft, alignBottom, alignBottomRight @@ -176,7 +177,6 @@ import Graphics.UI.WXCore.WxcClassInfo import Graphics.UI.WXCore.Types import Graphics.UI.WXCore.Frame -import Graphics.UI.WXCore.Defines {----------------------------------------------------------------------------------------- Classes @@ -238,8 +238,8 @@ -- | Layout elements in a horizontal direction with a certain amount of space between the elements. row :: Int -> [Layout] -> Layout -row w row - = grid w 0 [row] +row w row' + = grid w 0 [row'] -- | Layout elements in a vertical direction with a certain amount of space between the elements. column :: Int -> [Layout] -> Layout @@ -445,26 +445,26 @@ -- | (primitive) Set the minimal size of a widget. minsize :: Size -> Layout -> Layout -minsize sz layout - = updateOptions layout (\options -> options{ minSize = Just sz }) +minsize sz' layout + = updateOptions layout (\options' -> options'{ minSize = Just sz' }) -- | (primitive) Never resize the layout, but align it in the assigned area -- (default, except for containers like 'grid' and 'boxed' where it depends on the child layouts). rigid :: Layout -> Layout rigid layout - = updateOptions layout (\options -> options{ fillMode = FillNone }) + = updateOptions layout (\options' -> options'{ fillMode = FillNone }) -- | (primitive) Expand the layout to fill the assigned area but maintain the original proportions -- of the layout. Note that the layout can still be aligned in a horizontal or vertical direction. shaped :: Layout -> Layout shaped layout - = updateOptions layout (\options -> options{ fillMode = FillShaped }) + = updateOptions layout (\options' -> options'{ fillMode = FillShaped }) -- | (primitive) Expand the layout to fill the assigned area entirely, even when the original proportions can not -- be maintained. Note that alignment will have no effect on such layout. See also 'fill'. expand :: Layout -> Layout expand layout - = updateOptions layout (\options -> options{ fillMode = Fill }) + = updateOptions layout (\options' -> options'{ fillMode = Fill }) -- | (primitive) The layout is not stretchable. In a 'grid', the row and column that contain this layout will @@ -473,70 +473,70 @@ -- (default, except for containers like 'grid' and 'boxed' where it depends on the child layouts). static :: Layout -> Layout static layout - = updateOptions layout (\options -> options{ stretchV = False, stretchH = False }) + = updateOptions layout (\options' -> options'{ stretchV = False, stretchH = False }) -- | (primitive) The layout is stretchable and can be assigned a larger area in both the horizontal and vertical -- direction. See also combinators like 'fill' and 'floatCentre'. stretch :: Layout -> Layout stretch layout - = updateOptions layout (\options -> options{ stretchV = True, stretchH = True }) + = updateOptions layout (\options' -> options'{ stretchV = True, stretchH = True }) -- | (primitive) The layout is stretchable in the vertical direction. See also combinators like 'vfill' and 'vfloatCentre'. vstretch :: Layout -> Layout vstretch layout - = updateOptions layout (\options -> options{ stretchV = True, stretchH = False }) + = updateOptions layout (\options' -> options'{ stretchV = True, stretchH = False }) -- | (primitive) The layout is stretchable in the horizontal direction. See also combinators like 'hfill' and 'hfloatCentre'. hstretch :: Layout -> Layout hstretch layout - = updateOptions layout (\options -> options{ stretchH = True, stretchV = False }) + = updateOptions layout (\options' -> options'{ stretchH = True, stretchV = False }) -- | Add a margin of a certain width around the entire layout. margin :: Int -> Layout -> Layout margin i layout - = updateOptions layout (\options -> options{ margins = [MarginLeft,MarginRight,MarginTop,MarginBottom], marginW = i }) + = updateOptions layout (\options' -> options'{ margins = [MarginLeft,MarginRight,MarginTop,MarginBottom], marginW = i }) -- | (primitive) Set the width of the margin (default is 10 pixels). marginWidth :: Int -> Layout -> Layout marginWidth w layout - = updateOptions layout (\options -> options{ marginW = w }) + = updateOptions layout (\options' -> options'{ marginW = w }) -- | (primitive) Remove the margin of a layout (default). marginNone :: Layout -> Layout marginNone layout - = updateOptions layout (\options -> options{ margins = [] }) + = updateOptions layout (\options' -> options'{ margins = [] }) -- | (primitive) Add a margin to the left. marginLeft :: Layout -> Layout marginLeft layout - = updateOptions layout (\options -> options{ margins = MarginLeft:margins options }) + = updateOptions layout (\options' -> options'{ margins = MarginLeft:margins options' }) -- | (primitive) Add a right margin. marginRight :: Layout -> Layout marginRight layout - = updateOptions layout (\options -> options{ margins = MarginRight:margins options }) + = updateOptions layout (\options' -> options'{ margins = MarginRight:margins options' }) -- | (primitive) Add a margin to the top. marginTop :: Layout -> Layout marginTop layout - = updateOptions layout (\options -> options{ margins = MarginTop:margins options }) + = updateOptions layout (\options' -> options'{ margins = MarginTop:margins options' }) -- | (primitive) Add a margin to the bottom. marginBottom :: Layout -> Layout marginBottom layout - = updateOptions layout (\options -> options{ margins = MarginBottom:margins options }) + = updateOptions layout (\options' -> options'{ margins = MarginBottom:margins options' }) -- | (primitive) Align horizontally to the left when the layout is assigned to a larger area (default). halignLeft :: Layout -> Layout halignLeft layout - = updateOptions layout (\options -> options{ alignH = AlignLeft }) + = updateOptions layout (\options' -> options'{ alignH = AlignLeft }) -- | (primitive) Align horizontally to the right when the layout is assigned to a larger area. halignRight :: Layout -> Layout halignRight layout - = updateOptions layout (\options -> options{ alignH = AlignRight }) + = updateOptions layout (\options' -> options'{ alignH = AlignRight }) -- | (primitive) Center horizontally when assigned to a larger area. halignCenter :: Layout -> Layout @@ -546,17 +546,17 @@ -- | (primitive) Center horizontally when assigned to a larger area. halignCentre :: Layout -> Layout halignCentre layout - = updateOptions layout (\options -> options{ alignH = AlignHCentre }) + = updateOptions layout (\options' -> options'{ alignH = AlignHCentre }) -- | (primitive) Align vertically to the top when the layout is assigned to a larger area (default). valignTop :: Layout -> Layout valignTop layout - = updateOptions layout (\options -> options{ alignV = AlignTop }) + = updateOptions layout (\options' -> options'{ alignV = AlignTop }) -- | (primitive) Align vertically to the bottom when the layout is assigned to a larger area. valignBottom :: Layout -> Layout valignBottom layout - = updateOptions layout (\options -> options{ alignV = AlignBottom }) + = updateOptions layout (\options' -> options'{ alignV = AlignBottom }) -- | (primitive) Center vertically when the layout is assigned to a larger area. valignCenter :: Layout -> Layout @@ -566,7 +566,7 @@ -- | (primitive) Center vertically when the layout is assigned to a larger area. valignCentre :: Layout -> Layout valignCentre layout - = updateOptions layout (\options -> options{ alignV = AlignVCentre }) + = updateOptions layout (\options' -> options'{ alignV = AlignVCentre }) -- | Adjust the minimal size of a control dynamically when the content changes. @@ -575,7 +575,7 @@ -- 'StaticText', 'label's, and 'button's. dynamic :: Layout -> Layout dynamic layout - = updateOptions layout (\options -> options{ adjustMinSize = True }) + = updateOptions layout (\options' -> options'{ adjustMinSize = True }) updateOptions :: Layout -> (LayoutOptions -> LayoutOptions) -> Layout updateOptions layout f @@ -588,22 +588,22 @@ -- Just like a 'grid', the horizontal or vertical stretch of the child layout determines -- the stretch and expansion mode of the box. boxed :: String -> Layout -> Layout -boxed txt content +boxed txt' content' = TextBox optionsDefault{ stretchV = hasvstretch, stretchH = hashstretch , fillMode = hasfill, adjustMinSize = True } - txt (extramargin content) + txt' (extramargin content') where - hasvstretch = stretchV (options content) - hashstretch = stretchH (options content) + hasvstretch = stretchV (options content') + hashstretch = stretchH (options content') hasfill = if (hasvstretch || hashstretch) then Fill else FillNone - extramargin | null (margins (options content)) = marginWidth 5 . marginTop + extramargin | null (margins (options content')) = marginWidth 5 . marginTop | otherwise = id -- | (primitive) Create a static label label (= 'StaticText'). label :: String -> Layout -label txt - = Label optionsDefault txt +label txt' + = Label optionsDefault txt' -- | (primitive) The expression (@grid w h rows@) creates a grid of @rows@. The @w@ argument -- is the extra horizontal space between elements and @h@ the extra vertical space between elements. @@ -614,11 +614,11 @@ -- When any column or row in a grid can stretch, the grid itself will also stretch in that direction -- and the grid will 'expand' to fill the assigned area by default (instead of being 'static'). grid :: Int -> Int -> [[Layout]] -> Layout -grid w h rows - = Grid optionsDefault{ stretchV = hasvstretch, stretchH = hashstretch, fillMode = hasfill } (sz w h) rows +grid w h rows' + = Grid optionsDefault{ stretchV = hasvstretch, stretchH = hashstretch, fillMode = hasfill } (sz w h) rows' where - hasvstretch = any (all (stretchV.options)) rows - hashstretch = any (all (stretchH.options)) (transpose rows) + hasvstretch = any (all (stretchV.options)) rows' + hashstretch = any (all (stretchH.options)) (transpose rows') hasfill = if (hasvstretch || hashstretch) then Fill else FillNone -- | (primitive) Add a container widget (for example, a 'Panel'). @@ -688,12 +688,12 @@ -- Just like a 'grid', the horizontal or vertical stretch of the child layout determines -- the stretch and expansion mode of the notebook. tabs :: Notebook a -> [TabPage] -> Layout -tabs notebook pages +tabs notebook pages' = XNotebook optionsDefault{ stretchV = hasvstretch, stretchH = hashstretch, fillMode = hasfill } - (downcastNotebook notebook) pages + (downcastNotebook notebook) pages' where - hasvstretch = all stretchV [options layout | (_,_,layout) <- pages] - hashstretch = all stretchH [options layout | (_,_,layout) <- pages] + hasvstretch = all stretchV [options layout | (_,_,layout) <- pages'] + hashstretch = all stretchH [options layout | (_,_,layout) <- pages'] hasfill = if (hasvstretch || hashstretch) then Fill else FillNone -- | Add a horizontal sash bar between two windows. The two integer @@ -711,8 +711,8 @@ = split False split :: Bool -> SplitterWindow a -> Int -> Int -> Layout -> Layout -> Layout -split splitHorizontal splitter sashWidth paneWidth pane1 pane2 - = Splitter optionsDefault (downcastSplitterWindow splitter) pane1 pane2 splitHorizontal sashWidth paneWidth +split splitHorizontal' splitter' sashWidth' paneWidth' pane1' pane2' + = Splitter optionsDefault (downcastSplitterWindow splitter') pane1' pane2' splitHorizontal' sashWidth' paneWidth' optionsDefault :: LayoutOptions @@ -775,7 +775,7 @@ -- also shrink a window so that it always minimally sized). windowReLayout :: Window a -> IO () windowReLayout w - = do windowLayout w + = do _ <- windowLayout w old <- windowGetClientSize w szr <- windowGetSizer w when (not (objectIsNull szr)) (sizerSetSizeHints szr w) @@ -788,7 +788,7 @@ -- acceptable size ('windowFit'). windowReLayoutMinimal :: Window a -> IO () windowReLayoutMinimal w - = do windowLayout w + = do _ <- windowLayout w szr <- windowGetSizer w when (not (objectIsNull szr)) (sizerSetSizeHints szr w) windowFit w @@ -796,10 +796,10 @@ -- | Set the layout of a window (automatically calls 'sizerFromLayout'). windowSetLayout :: Window a -> Layout -> IO () windowSetLayout window layout - = do sizer <- sizerFromLayout window layout + = do sizer' <- sizerFromLayout window layout windowSetAutoLayout window True - windowSetSizer window sizer - sizerSetSizeHints sizer window + windowSetSizer window sizer' + sizerSetSizeHints sizer' window return () -- | Create a 'Sizer' from a 'Layout' and a parent window. @@ -808,169 +808,170 @@ = insert objectNull (grid 0 0 [[stretch layout]]) where insert :: Sizer () -> Layout -> IO (Sizer ()) - insert container (Spacer options sz) - = do sizerAddWithOptions 0 (sizerAdd container sz) (\sz -> return ()) options - return container + insert container' (Spacer options' sz') + = do sizerAddWithOptions 0 (sizerAdd container' sz') (\_sz -> return ()) options' + return container' - insert container (Widget options win) - = do sizerAddWindowWithOptions container win options - return container + insert container' (Widget options' win') + = do sizerAddWindowWithOptions container' win' options' + return container' - insert container (Grid goptions gap rows) - = do g <- flexGridSizerCreate (length rows) (maximum (map length rows)) (sizeH gap) (sizeW gap) - mapM_ (stretchRow g) (zip [0..] (map (all (stretchV.options)) rows)) - mapM_ (stretchCol g) (zip [0..] (map (all (stretchH.options)) (transpose rows))) - mapM_ (insert (downcastSizer g)) (concat rows) - when (container /= objectNull) - (sizerAddSizerWithOptions container g goptions) + insert container' (Grid goptions gap' rows') + = do g <- flexGridSizerCreate (length rows') (maximum (map length rows')) (sizeH gap') (sizeW gap') + mapM_ (stretchRow g) (zip [0..] (map (all (stretchV.options)) rows')) + mapM_ (stretchCol g) (zip [0..] (map (all (stretchH.options)) (transpose rows'))) + mapM_ (insert (downcastSizer g)) (concat rows') + when (container' /= objectNull) + (sizerAddSizerWithOptions container' g goptions) return (downcastSizer g) - insert container (Label options txt) - = do t <- staticTextCreate parent idAny txt rectNull 0 - sizerAddWindowWithOptions container t options - return container + insert container' (Label options' txt') + = do t <- staticTextCreate parent idAny txt' rectNull 0 + sizerAddWindowWithOptions container' t options' + return container' - insert container (TextBox options txt layout) - = do box <- staticBoxCreate parent idAny txt rectNull (wxCLIP_CHILDREN .+. wxNO_FULL_REPAINT_ON_RESIZE) - sizer <- staticBoxSizerCreate box wxVERTICAL - insert (downcastSizer sizer) layout - when (container /= objectNull) - (sizerAddSizerWithOptions container sizer options) + insert container' (TextBox options' txt' layout') + = do box <- staticBoxCreate parent idAny txt' rectNull (wxCLIP_CHILDREN .+. wxNO_FULL_REPAINT_ON_RESIZE) + sizer' <- staticBoxSizerCreate box wxVERTICAL + _ <- insert (downcastSizer sizer') layout' + when (container' /= objectNull) + (sizerAddSizerWithOptions container' sizer' options') windowLower box - return (downcastSizer sizer) + return (downcastSizer sizer') - insert container (Line options (Size w h)) + insert container' (Line options' (Size w h)) = do l <- staticLineCreate parent idAny (rectNull{ rectWidth = w, rectHeight = h }) (if (w >= h) then wxHORIZONTAL else wxVERTICAL) - sizerAddWindowWithOptions container l options - return container + sizerAddWindowWithOptions container' l options' + return container' - insert container (XSizer options sizer) - = do sizerAddSizerWithOptions container sizer options - return container + insert container' (XSizer options' sizer') + = do sizerAddSizerWithOptions container' sizer' options' + return container' - insert container (WidgetContainer options win layout) - = do windowSetLayout win layout -- recursively set the layout in the window itself - sizerAddWindowWithOptions container win options - return container + insert container' (WidgetContainer options' win' layout') + = do windowSetLayout win' layout' -- recursively set the layout' in the window itself + sizerAddWindowWithOptions container' win' options' + return container' - insert container (Splitter options splitter pane1 pane2 splitHorizontal sashWidth paneWidth) - = do splitterWindowSetMinimumPaneSize splitter 20 - -- splitterWindowSetSashSize is obsolete - -- splitterWindowSetSashSize splitter sashWidth - sizerAddWindowWithOptions container splitter options - if splitHorizontal - then splitterWindowSplitHorizontally splitter win1 win2 paneWidth - else splitterWindowSplitVertically splitter win1 win2 paneWidth - paneSetLayout pane1 - paneSetLayout pane2 + insert container' (Splitter options' splitter' pane1' pane2' splitHorizontal' _sashWidth paneWidth') + = do splitterWindowSetMinimumPaneSize splitter' 20 + sizerAddWindowWithOptions container' splitter' options' + _ <- if splitHorizontal' + then splitterWindowSplitHorizontally splitter' win1 win2 paneWidth' + else splitterWindowSplitVertically splitter' win1 win2 paneWidth' + paneSetLayout pane1' + paneSetLayout pane2' - return container + return container' where - win1 = getWinFromLayout pane1 - win2 = getWinFromLayout pane2 + win1 = getWinFromLayout pane1' + win2 = getWinFromLayout pane2' - getWinFromLayout layout - = case layout of - Widget _ win -> downcastWindow win - WidgetContainer _ win _ -> downcastWindow win - Splitter _ splitter _ _ _ _ _ -> downcastWindow splitter - other -> error "Layout: hsplit/vsplit need widgets or containers as arguments" + getWinFromLayout layout' + = case layout' of + Widget _ win' -> downcastWindow win' + WidgetContainer _ win' _ -> downcastWindow win' + Splitter _ splitter'' _ _ _ _ _ -> downcastWindow splitter'' + _other -> error "Layout: hsplit/vsplit need widgets or containers as arguments" - paneSetLayout layout - = case layout of - Widget _ win -> return () - WidgetContainer options win layout -> windowSetLayout win layout - Splitter options splitter pane1 pane2 splitHorizontal sashWidth paneWidth - -> do splitterWindowSetMinimumPaneSize splitter 20 - -- splitterWindowSetSashSize is obsolete - -- splitterWindowSetSashSize splitter sashWidth - -- sizerAddWindowWithOptions container splitter options - let win1 = getWinFromLayout pane1 - win2 = getWinFromLayout pane2 - if splitHorizontal - then splitterWindowSplitHorizontally splitter win1 win2 paneWidth - else splitterWindowSplitVertically splitter win1 win2 paneWidth - paneSetLayout pane1 - paneSetLayout pane2 - return () - other -> error "Layout: hsplit/vsplit need widgets or containers as arguments" + paneSetLayout layout' + = case layout' of + Widget _ _win + -> return () + + WidgetContainer _options win' layout'' + -> windowSetLayout win' layout'' + + Splitter _options splitter'' pane1'' pane2'' splitHorizontal'' _sashWidth paneWidth'' + -> do splitterWindowSetMinimumPaneSize splitter'' 20 + -- sizerAddWindowWithOptions container' splitter'' options' + let win1' = getWinFromLayout pane1'' + win2' = getWinFromLayout pane2'' + _ <- if splitHorizontal'' + then splitterWindowSplitHorizontally splitter'' win1' win2' paneWidth'' + else splitterWindowSplitVertically splitter'' win1' win2' paneWidth'' + paneSetLayout pane1'' + paneSetLayout pane2'' + return () + _other + -> error "Layout: hsplit/vsplit need widgets or containers as arguments" - insert container (XNotebook options nbook pages) - = do pages' <- addImages objectNull pages - mapM_ addPage pages' - sizerAddWindowWithOptions container nbook options - return container + insert container' (XNotebook options' nbook' pages') + = do pages'' <- addImages objectNull pages' + mapM_ addPage pages'' + sizerAddWindowWithOptions container' nbook' options' + return container' where - addPage (title,idx,WidgetContainer options win layout) + addPage (title,idx,WidgetContainer _options win' layout') = do pagetitle <- if (null title) - then windowGetLabel win + then windowGetLabel win' else return title - notebookAddPage nbook win pagetitle False idx - windowSetLayout win layout -- recursively set layout + _ <- notebookAddPage nbook' win' pagetitle False idx + windowSetLayout win' layout' -- recursively set layout' - addPage (title,idx,other) + addPage (_title, _idx, _other) = error "Graphics.UI.WXCore.sizerFromLayout: notebook page needs to be a 'container' layout!" addImages il [] = if (objectIsNull il) then return [] - else do notebookAssignImageList nbook il + else do notebookAssignImageList nbook' il return [] - addImages il ((title,bm,layout):xs) | objectIsNull bm + addImages il ((title, bm, layout'):xs) | objectIsNull bm = do xs' <- addImages il xs - return ((title,-1,layout):xs') + return ((title,-1,layout'):xs') - addImages il ((title,bm,layout):xs) + addImages il ((title, bm, layout'):xs) = do il' <- addImage il bm i <- imageListGetImageCount il' xs' <- addImages il' xs - return ((title,i,layout):xs') + return ((title,i,layout'):xs') addImage il bm = if (objectIsNull il) - then do w <- bitmapGetWidth bm - h <- bitmapGetHeight bm - il <- imageListCreate (sz w h) False 1 - imageListAddBitmap il bm objectNull - return il - else do imageListAddBitmap il bm objectNull - return il + then do w <- bitmapGetWidth bm + h <- bitmapGetHeight bm + il' <- imageListCreate (sz w h) False 1 + _ <- imageListAddBitmap il' bm objectNull + return il' + else imageListAddBitmap il bm objectNull >> + return il - stretchRow g (i,stretch) - = when stretch (flexGridSizerAddGrowableRow g i) + stretchRow g (i,stretch') + = when stretch' (flexGridSizerAddGrowableRow g i) - stretchCol g (i,stretch) - = when stretch (flexGridSizerAddGrowableCol g i) + stretchCol g (i,stretch') + = when stretch' (flexGridSizerAddGrowableCol g i) sizerAddWindowWithOptions :: Sizer a -> Window b -> LayoutOptions -> IO () - sizerAddWindowWithOptions container window options - = sizerAddWithOptions (flagsAdjustMinSize window options) - (sizerAddWindow container window) (sizerSetItemMinSizeWindow container window) options + sizerAddWindowWithOptions container' window options' + = sizerAddWithOptions (flagsAdjustMinSize window options') + (sizerAddWindow container' window) (sizerSetItemMinSizeWindow container' window) options' sizerAddSizerWithOptions :: Sizer a -> Sizer b -> LayoutOptions -> IO () - sizerAddSizerWithOptions container sizer options - = sizerAddWithOptions 0 (sizerAddSizer container sizer) (sizerSetItemMinSizeSizer container sizer) options + sizerAddSizerWithOptions container' sizer' options' + = sizerAddWithOptions 0 (sizerAddSizer container' sizer') (sizerSetItemMinSizeSizer container' sizer') options' sizerAddWithOptions :: Int -> (Int -> Int -> Int -> Ptr p -> IO ()) -> (Size -> IO ()) -> LayoutOptions -> IO () - sizerAddWithOptions miscflags addSizer setMinSize options - = do addSizer 1 (flags options .+. miscflags) (marginW options) ptrNull - case minSize options of + sizerAddWithOptions miscflags addSizer setMinSize options' + = do addSizer 1 (flags options' .+. miscflags) (marginW options') ptrNull + case minSize options' of Nothing -> return () - Just sz -> setMinSize sz + Just sz' -> setMinSize sz' - flags options - = flagsFillMode (fillMode options) .+. flagsMargins (margins options) - .+. flagsHAlign (alignH options) .+. flagsVAlign (alignV options) + flags options' + = flagsFillMode (fillMode options') .+. flagsMargins (margins options') + .+. flagsHAlign (alignH options') .+. flagsVAlign (alignV options') - flagsFillMode fillMode - = case fillMode of + flagsFillMode fillMode' + = case fillMode' of FillNone -> 0 FillShaped -> wxSHAPED Fill -> wxEXPAND @@ -987,18 +988,18 @@ AlignBottom -> wxALIGN_BOTTOM AlignVCentre -> wxALIGN_CENTRE_VERTICAL - flagsMargins margins - = bits (map flagsMargin margins) + flagsMargins margins' + = bits (map flagsMargin margins') - flagsMargin margin - = case margin of + flagsMargin margin' + = case margin' of MarginTop -> wxTOP MarginLeft -> wxLEFT MarginBottom -> wxBOTTOM MarginRight -> wxRIGHT -- wxADJUST_MINSIZE is deprecated - flagsAdjustMinSize window options = 0 + flagsAdjustMinSize _window _options = 0 {- = if (adjustMinSize options) then wxADJUST_MINSIZE
src/haskell/Graphics/UI/WXCore/OpenGL.hs view
@@ -1,11 +1,12 @@ -------------------------------------------------------------------------------- -{-| Module : OpenGL - Copyright : (c) Daan Leijen 2003 - License : wxWindows +{-| +Module : OpenGL +Copyright : (c) Daan Leijen 2003 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Convenience wrappers for the openGL canvas window ('GLCanvas'). -} @@ -21,14 +22,10 @@ import Graphics.UI.WXCore.WxcTypes -import Graphics.UI.WXCore.WxcDefs import Graphics.UI.WXCore.WxcClasses import Graphics.UI.WXCore.Types import Foreign -import Foreign.Ptr -import Foreign.C.String -import Foreign.Marshal.Array @@ -49,10 +46,10 @@ | GL_MIN_ALPHA Int -- ^ Use alpha buffer with at least /argument/ bits | GL_DEPTH_SIZE Int -- ^ Bits for Z-buffer (0,16,32) | GL_STENCIL_SIZE Int -- ^ Bits for stencil buffer - | GL_MIN_ACCUM_RED Int -- ^ Use red accum buffer with at least /argument/ bits - | GL_MIN_ACCUM_GREEN Int -- ^ Use green buffer with at least /argument/ bits - | GL_MIN_ACCUM_BLUE Int -- ^ Use blue buffer with at least /argument/ bits - | GL_MIN_ACCUM_ALPHA Int -- ^ Use blue buffer with at least /argument/ bits + | GL_MIN_ACCUM_RED Int -- ^ Use red accumulation buffer with at least /argument/ bits + | GL_MIN_ACCUM_GREEN Int -- ^ Use green accumulation buffer with at least /argument/ bits + | GL_MIN_ACCUM_BLUE Int -- ^ Use blue accumulation buffer with at least /argument/ bits + | GL_MIN_ACCUM_ALPHA Int -- ^ Use alpha accumulation buffer with at least /argument/ bits | GL_SAMPLE_BUFFERS Int -- ^ 1 for multisampling support (antialiasing) | GL_SAMPLES Int -- ^ 4 for 2x2 antialiasing supersampling on most graphics cards | GL_CORE_PROFILE -- ^ request an OpenGL core profile. This will result in also requesting OpenGL at least version 3.0, since wx 3.1 @@ -63,11 +60,12 @@ encodeAttributes attributes = concatMap encodeAttribute attributes +encodeAttribute :: GLAttribute -> [Int] encodeAttribute attr = case attr of GL_RGBA -> [1] GL_BUFFER_SIZE n -> [2,n] - GL_LEVEL n -> [3,case n of { GT -> 1; LT -> (-1); other -> 0 }] + GL_LEVEL n -> [3, case n of { GT -> 1; LT -> (-1); _other -> 0 }] GL_DOUBLEBUFFER -> [4] GL_STEREO -> [5] GL_AUX_BUFFERS n -> [6,n] @@ -94,6 +92,6 @@ -- | Create an openGL window. Use 'nullPalette' to use the default palette. glCanvasCreateEx :: Window a -> Id -> Rect -> Style -> String -> [GLAttribute] -> Palette b -> IO (GLCanvas ()) -glCanvasCreateEx parent id rect style title attributes palette +glCanvasCreateEx parent id' rect' style title attributes palette = withArray0 (toCInt 0) (map toCInt (encodeAttributes attributes)) $ \pattrs -> - glCanvasCreate parent id pattrs rect style title palette + glCanvasCreate parent id' pattrs rect' style title palette
src/haskell/Graphics/UI/WXCore/Print.hs view
@@ -1,13 +1,14 @@ ----------------------------------------------------------------------------------------- -{-| Module : Print - Copyright : (c) Daan Leijen 2003 - License : wxWindows +{-| +Module : Print +Copyright : (c) Daan Leijen 2003 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable -Printer abstraction layer. See @samples/wx/Print.hs@ for a demo. +Printer abstraction layer. See @samples\/wx\/Print.hs@ for a demo. The application should create a 'pageSetupDialog' to hold the printer settings of the user. @@ -54,7 +55,6 @@ , pageSetupDialogGetFrame ) where -import Graphics.UI.WXCore.WxcDefs import Graphics.UI.WXCore.WxcClasses import Graphics.UI.WXCore.WxcClassInfo import Graphics.UI.WXCore.Types @@ -85,10 +85,10 @@ onPrint isPreview pageInfo printOut pageRangeFunction printFunction ev = case ev of PrintPrepare -> - do{ printOutInitPageRange printOut pageInfo pageRangeFunction - ; return () - } - PrintPage cancel dc n -> + printOutInitPageRange printOut pageInfo pageRangeFunction >> + return () + + PrintPage _cancel dc n -> do{ printInfo <- printOutGetPrintInfo printOut ; let io info size = printFunction pageInfo info size dc n ; if isPreview @@ -147,7 +147,7 @@ -- | Get the zoom factor from the preview getPreviewZoom :: PageInfo -> PrintInfo -> DC a -> IO (Double,Double) -getPreviewZoom pageInfo printInfo dc +getPreviewZoom _pageInfo printInfo dc = do size <- dcGetSize dc let (printW,printH) = pixelToMM (printerPPI printInfo) (printPageSize printInfo) (screenW,screenH) = pixelToMM (screenPPI printInfo) size @@ -202,18 +202,18 @@ -> PageFunction -> PrintFunction -> IO () -printDialog pageSetupDialog title pageRangeFunction printFunction = - do{ pageSetupData <- pageSetupDialogGetPageSetupData pageSetupDialog +printDialog pageSetupDialog' title pageRangeFunction printFunction = + do{ pageSetupData <- pageSetupDialogGetPageSetupData pageSetupDialog' ; printData <- pageSetupDialogDataGetPrintData pageSetupData ; printDialogData <- printDialogDataCreateFromData printData ; printDialogDataSetAllPages printDialogData True ; printer <- printerCreate printDialogData ; printout <- wxcPrintoutCreate title ; pageInfo <- pageSetupDataGetPageInfo pageSetupData - ; printOutInitPageRange printout pageInfo pageRangeFunction + ; _ <- printOutInitPageRange printout pageInfo pageRangeFunction ; printOutOnPrint printout (onPrint False pageInfo printout pageRangeFunction printFunction) - ; frame <- pageSetupDialogGetFrame pageSetupDialog - ; printerPrint printer frame printout True {- show printer setup? -} + ; frame <- pageSetupDialogGetFrame pageSetupDialog' + ; _ <- printerPrint printer frame printout True {- show printer setup? -} ; objectDelete printDialogData ; objectDelete printout ; objectDelete printer @@ -225,24 +225,24 @@ -> PageFunction -> PrintFunction -> IO () -printPreview pageSetupDialog title pageRangeFunction printFunction = - do{ pageSetupData <- pageSetupDialogGetPageSetupData pageSetupDialog +printPreview pageSetupDialog' title pageRangeFunction printFunction = + do{ pageSetupData <- pageSetupDialogGetPageSetupData pageSetupDialog' ; pageInfo <- pageSetupDataGetPageInfo pageSetupData ; printout1 <- wxcPrintoutCreate "Print to preview" ; printout2 <- wxcPrintoutCreate "Print to printer" ; startPage <- printOutInitPageRange printout1 pageInfo pageRangeFunction - ; printOutInitPageRange printout2 pageInfo pageRangeFunction + ; _ <- printOutInitPageRange printout2 pageInfo pageRangeFunction ; printOutOnPrint printout1 (onPrint True pageInfo printout1 pageRangeFunction printFunction) ; printOutOnPrint printout2 (onPrint False pageInfo printout2 pageRangeFunction printFunction) ; printData <- pageSetupDialogDataGetPrintData pageSetupData ; printDialogData <- printDialogDataCreateFromData printData ; printDialogDataSetAllPages printDialogData True ; preview <- printPreviewCreateFromDialogData printout1 printout2 printDialogData - ; printPreviewSetCurrentPage preview startPage - ; frame <- pageSetupDialogGetFrame pageSetupDialog + ; _ <- printPreviewSetCurrentPage preview startPage + ; frame <- pageSetupDialogGetFrame pageSetupDialog' ; previewFrame <- previewFrameCreate preview frame title rectNull frameDefaultStyle title ; previewFrameInitialize previewFrame - ; windowShow previewFrame + ; _ <- windowShow previewFrame ; windowRaise previewFrame } @@ -264,8 +264,8 @@ -- | Get the parent frame of a 'PageSetupDialog'. pageSetupDialogGetFrame :: PageSetupDialog a -> IO (Frame ()) -pageSetupDialogGetFrame pageSetupDialog - = do p <- windowGetParent pageSetupDialog +pageSetupDialogGetFrame pageSetupDialog' + = do p <- windowGetParent pageSetupDialog' case (safeCast p classFrame) of Just frame -> return frame Nothing -> do w <- wxcAppGetTopWindow @@ -291,17 +291,16 @@ newInfo = pageInfo{ pageArea = rectBetween p0 p1 } pageSetupDataSetPageInfo pageSetupData newInfo else return () - pageSetupDialog <- pageSetupDialogCreate f pageSetupData + pageSetupDialog' <- pageSetupDialogCreate f pageSetupData prev <- windowGetOnClose f - windowOnClose f (do{ objectDelete pageSetupDialog; prev }) + windowOnClose f (do{ objectDelete pageSetupDialog'; prev }) objectDelete pageSetupData - return pageSetupDialog + return pageSetupDialog' -- | Show the page setup dialog pageSetupShowModal :: PageSetupDialog a -> IO () pageSetupShowModal p - = do dialogShowModal p - return () + = dialogShowModal p >> return () {-------------------------------------------------------------------------- PageInfo and PrintInfo
src/haskell/Graphics/UI/WXCore/Process.hs view
@@ -1,11 +1,12 @@ ----------------------------------------------------------------------------------------- -{-| Module : Process - Copyright : (c) Daan Leijen 2003 - License : wxWindows +{-| +Module : Process +Copyright : (c) Daan Leijen 2003 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Process and stream wrappers. -} @@ -33,15 +34,12 @@ ) where import System.IO.Unsafe( unsafeInterleaveIO ) -import Graphics.UI.WXCore.WxcTypes( ptrCast ) import Graphics.UI.WXCore.WxcDefs import Graphics.UI.WXCore.WxcClasses import Graphics.UI.WXCore.Types import Graphics.UI.WXCore.Events import Foreign -import Foreign.Ptr -import Foreign.Storable import Foreign.C.String import Foreign.C.Types @@ -75,11 +73,11 @@ -- has been read, otherwise, either the maximum has been reached, or no more -- input was available. inputStreamGetLineNoWait :: InputStream a -> Int -> IO String -inputStreamGetLineNoWait inputStream max - = read "" 0 +inputStreamGetLineNoWait inputStream maxChars + = readInputStream "" 0 where - read acc n - = if n >= max + readInputStream acc n + = if n >= maxChars then return (reverse acc) else do mbc <- inputStreamGetCharNoWait inputStream case mbc of @@ -87,25 +85,25 @@ Just '\n' -> return (reverse ('\n':acc)) Just '\r' -> do mbc2 <- inputStreamGetCharNoWait inputStream case mbc2 of - Just c2 | c2 /= '\n' -> do inputStreamUngetch inputStream c2 - return () + Just c2 | c2 /= '\n' -> inputStreamUngetch inputStream c2 >> + return () _ -> return () return (reverse ('\n':acc)) - Just c -> read (c:acc) (n+1) + Just c -> readInputStream (c:acc) (n+1) -- | @inputStreamGetStringNoWait stream n@ reads a line of at most @n@ characters from the -- input stream in a non-blocking way. inputStreamGetStringNoWait :: InputStream a -> Int -> IO String -inputStreamGetStringNoWait input max - = read "" 0 +inputStreamGetStringNoWait input maxChars + = readInputStream "" 0 where - read acc n - = if ( n >= max ) + readInputStream acc n + = if ( n >= maxChars ) then return (reverse acc) else do mbc <- inputStreamGetCharNoWait input case mbc of Nothing -> return (reverse acc) - Just c -> read (c:acc) (n+1) + Just c -> readInputStream (c:acc) (n+1) -- | Read a single character from the input, returning @Nothing@ if no input @@ -125,22 +123,22 @@ -- has been read, otherwise, either the maximum has been reached, or no more -- input was available. inputStreamGetLine :: InputStream a -> Int -> IO String -inputStreamGetLine inputStream max - = read "" 0 +inputStreamGetLine inputStream maxChars + = readInputStream "" 0 where - read acc n - = if n >= max + readInputStream acc n + = if n >= maxChars then return (reverse acc) else do c <- inputStreamGetChar inputStream case c of '\n' -> return (reverse ('\n':acc)) '\r' -> do mbc2 <- inputStreamGetCharNoWait inputStream case mbc2 of - Just c2 | c2 /= '\n' -> do inputStreamUngetch inputStream c2 - return () + Just c2 | c2 /= '\n' -> inputStreamUngetch inputStream c2 >> + return () _ -> return () return (reverse ('\n':acc)) - _ -> read (c:acc) (n+1) + _ -> readInputStream (c:acc) (n+1) -- | Read a single character from the input. (equals 'inputStreamGetC') inputStreamGetChar :: InputStream a -> IO Char @@ -206,7 +204,7 @@ -- process object is returned in @process@ and the process identifier in @pid@. -- -- Note: The method uses idle event timers to process the output channels. On --- many platforms this is uch more thrustworthy and robust than the 'processExecAsync' that +-- many platforms this is much more trustworthy and robust than the 'processExecAsync' that -- uses threads (which can cause all kinds of portability problems). processExecAsyncTimed :: Window a -> String -> Bool -> OnEndProcess -> OnReceive -> OnReceive -> IO (String -> IO StreamStatus, Process (), Int) @@ -215,7 +213,7 @@ processRedirect process pid <- wxcAppExecuteProcess cmd wxEXEC_ASYNC process if (pid == 0) - then return (\s -> return StreamEof, objectNull, pid) + then return (\_s -> return StreamEof, objectNull, pid) else do v <- varCreate (Just process) windowOnIdle parent (handleAnyInput v) unregister <- appRegisterIdle 100 -- 10 times a second @@ -243,26 +241,26 @@ return available handleAllInput :: InputStream a -> OnReceive -> IO () - handleAllInput input onOutput - = do available <- handleInput input onOutput + handleAllInput input onOutput' + = do available <- handleInput input onOutput' if (available) - then handleAllInput input onOutput + then handleAllInput input onOutput' else return () handleInput :: InputStream a -> OnReceive -> IO Bool - handleInput input onOutput + handleInput input onOutput' = do txt <- inputStreamGetLineNoWait input maxLine status <- streamBaseStatus input if null txt then case status of StreamOk -> return False - _ -> do onOutput "" status + _ -> do onOutput' "" status return False - else do onOutput txt status + else do onOutput' txt status return True handleTerminate :: Var (Maybe (Process a)) -> IO () -> Int -> Int -> IO () - handleTerminate v unregister pid exitCode + handleTerminate v unregister _pid exitCode = do unregister withProcess v () $ \process -> do varSet v Nothing @@ -298,7 +296,7 @@ processRedirect process pid <- wxcAppExecuteProcess command wxEXEC_ASYNC process if (pid == 0) - then return (\s -> return (), objectNull, pid) + then return (\_s -> return (), objectNull, pid) else do inputPipe <- processGetInputStream process outputPipe <- processGetOutputStream process errorPipe <- processGetErrorStream process @@ -308,7 +306,7 @@ let send txt = outputStreamPutString outputPipe txt return (send, process, pid) where - handleOnEndProcess ourPid process inputPipe outputPipe errorPipe pid exitcode + handleOnEndProcess ourPid process _inputPipe _outputPipe _errorPipe pid exitcode | ourPid == pid = do onEndProcess exitcode processDelete process - | otherwise = return ()+ | otherwise = return ()
src/haskell/Graphics/UI/WXCore/Types.hs view
@@ -1,12 +1,13 @@-{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances #-} +{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------------------- -{-| Module : Types - Copyright : (c) Daan Leijen 2003 - License : wxWindows +{-| +Module : Types +Copyright : (c) Daan Leijen 2003 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Basic types and operations. -} @@ -79,16 +80,13 @@ ) where -import Data.List( (\\) ) import Graphics.UI.WXCore.WxcTypes import Graphics.UI.WXCore.WxcDefs import Graphics.UI.WXCore.WxcClasses( wxcSystemSettingsGetColour ) import System.IO.Unsafe( unsafePerformIO ) -- utility -import Data.Array import Data.Bits -import Data.Word import Control.Concurrent.STM import qualified Control.Exception as CE import qualified Control.Monad as M @@ -159,7 +157,7 @@ -- | Ignore the result of an 'IO' action. unitIO :: IO a -> IO () unitIO io - = do io; return () + = io >> return () -- | Perform an action when a test succeeds. when :: Bool -> IO () -> IO () @@ -190,14 +188,14 @@ finalize :: IO b -- ^ computation to run last (release resource) -> IO a -- ^ computation to run first -> IO a -finalize last first - = finally first last +finalize lastComputation firstComputation + = finally firstComputation lastComputation {-------------------------------------------------------------------------------- Variables --------------------------------------------------------------------------------} --- | A mutable variable. Use this instead of 'MVar's or 'IORef's to accomodate for +-- | A mutable variable. Use this instead of 'MVar's or 'IORef's to accommodate for -- future expansions with possible concurrency. type Var a = TVar a @@ -248,6 +246,7 @@ pointScale :: (Num a) => Point2 a -> a -> Point2 a pointScale (Point x y) v = Point (v*x) (v*y) +{- Moved to WxcTypes.hs at 2015-09-01 instance (Num a, Ord a) => Ord (Point2 a) where compare (Point x1 y1) (Point x2 y2) @@ -255,7 +254,6 @@ EQ -> compare x1 x2 neq -> neq - instance Ix (Point2 Int) where range (Point x1 y1,Point x2 y2) = [Point x y | y <- [y1..y2], x <- [x1..x2]] @@ -268,24 +266,27 @@ h = abs (y2 - y1) + 1 in w*h - index bnd@(Point x1 y1, Point x2 y2) p@(Point x y) + index bnd@(Point x1 y1, Point x2 _y2) p@(Point x y) = if inRange bnd p then let w = abs (x2 - x1) + 1 in (y-y1)*w + x else error ("Point index out of bounds: " ++ show p ++ " not in " ++ show bnd) +-} {----------------------------------------------------------------------------------------- Size -----------------------------------------------------------------------------------------} +{- -- | Return the width. (see also 'sizeW'). sizeWidth :: (Num a) => Size2D a -> a -sizeWidth (Size w h) +sizeWidth (Size w _h) = w -- | Return the height. (see also 'sizeH'). sizeHeight :: (Num a) => Size2D a -> a -sizeHeight (Size w h) +sizeHeight (Size _w h) = h +-} -- | Returns 'True' if the first size totally encloses the second argument. sizeEncloses :: (Num a, Ord a) => Size2D a -> Size2D a -> Bool @@ -352,7 +353,7 @@ = Point (l + div w 2) (t + div h 2) rectCentralRect :: Rect2D Int -> Size -> Rect2D Int -rectCentralRect r@(Rect l t rw rh) (Size w h) +rectCentralRect r@(Rect _l _t _rw _rh) (Size w h) = let c = rectCentralPoint r in Rect (pointX c - (w - div w 2)) (pointY c - (h - div h 2)) w h @@ -361,7 +362,7 @@ = Point (l + w/2) (t + h/2) rectCentralRectDouble :: (Fractional a) => Rect2D a -> Size2D a -> Rect2D a -rectCentralRectDouble r@(Rect l t rw rh) (Size w h) +rectCentralRectDouble r@(Rect _l _t _rw _rh) (Size w h) = let c = rectCentralPointDouble r in Rect (pointX c - (w - w/2)) (pointY c - (h - h/2)) w h @@ -420,21 +421,21 @@ red, green, blue :: Color cyan, magenta, yellow :: Color -black = colorRGB 0x00 0x00 0x00 -darkgrey = colorRGB 0x2F 0x2F 0x2F -dimgrey = colorRGB 0x54 0x54 0x54 -mediumgrey= colorRGB 0x64 0x64 0x64 -grey = colorRGB 0x80 0x80 0x80 -lightgrey = colorRGB 0xC0 0xC0 0xC0 -white = colorRGB 0xFF 0xFF 0xFF +black = colorRGB 0x00 0x00 (0x00 :: Int) +darkgrey = colorRGB 0x2F 0x2F (0x2F :: Int) +dimgrey = colorRGB 0x54 0x54 (0x54 :: Int) +mediumgrey= colorRGB 0x64 0x64 (0x64 :: Int) +grey = colorRGB 0x80 0x80 (0x80 :: Int) +lightgrey = colorRGB 0xC0 0xC0 (0xC0 :: Int) +white = colorRGB 0xFF 0xFF (0xFF :: Int) -red = colorRGB 0xFF 0x00 0x00 -green = colorRGB 0x00 0xFF 0x00 -blue = colorRGB 0x00 0x00 0xFF +red = colorRGB 0xFF 0x00 (0x00 :: Int) +green = colorRGB 0x00 0xFF (0x00 :: Int) +blue = colorRGB 0x00 0x00 (0xFF :: Int) -yellow = colorRGB 0xFF 0xFF 0x00 -magenta = colorRGB 0xFF 0x00 0xFF -cyan = colorRGB 0x00 0xFF 0xFF +yellow = colorRGB 0xFF 0xFF (0x00 :: Int) +magenta = colorRGB 0xFF 0x00 (0xFF :: Int) +cyan = colorRGB 0x00 0xFF (0xFF :: Int) {-------------------------------------------------------------------------- @@ -475,7 +476,7 @@ | ColorBtnHilight -- ^ Same as BTNHIGHLIGHT. instance Enum SystemColor where - toEnum i + toEnum _i = error "Graphics.UI.WXCore.Types.SytemColor.toEnum: can not convert integers to system colors." fromEnum systemColor
src/haskell/Graphics/UI/WXCore/WxcClassInfo.hs view
@@ -1,11 +1,12 @@ -------------------------------------------------------------------------------- -{-| Module : WxcClassInfo - Copyright : Copyright (c) Daan Leijen 2003, 2004 - License : wxWidgets +{-| +Module : WxcClassInfo +Copyright : Copyright (c) Daan Leijen 2003, 2004 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Haskell class info definitions for the wxWidgets C library (@wxc.dll@). @@ -846,10 +847,10 @@ -- | Test if an object is of a certain kind. (Returns also 'True' when the object is null.) {-# NOINLINE instanceOf #-} instanceOf :: WxObject b -> ClassType a -> Bool -instanceOf obj (ClassType classInfo) +instanceOf obj (ClassType classInfo') = if (objectIsNull obj) then True - else unsafePerformIO (objectIsKindOf obj classInfo) + else unsafePerformIO (objectIsKindOf obj classInfo') -- | Test if an object is of a certain kind, based on a full wxWidgets class name. (Use with care). {-# NOINLINE instanceOfName #-} @@ -858,10 +859,10 @@ = if (objectIsNull obj) then True else unsafePerformIO ( - do classInfo <- classInfoFindClass className - if (objectIsNull classInfo) + do classInfo' <- classInfoFindClass className + if (objectIsNull classInfo') then return False - else objectIsKindOf obj classInfo) + else objectIsKindOf obj classInfo') -- | A safe object cast. Returns 'Nothing' if the object is of the wrong type. Note that a null object can always be cast. safeCast :: WxObject b -> ClassType (WxObject a) -> Maybe (WxObject a)
src/haskell/Graphics/UI/WXCore/WxcClassTypes.hs view
@@ -1,11 +1,12 @@ -------------------------------------------------------------------------------- -{-| Module : WxcClassTypes - Copyright : Copyright (c) Daan Leijen 2003, 2004 - License : wxWidgets +{-| +Module : WxcClassTypes +Copyright : Copyright (c) Daan Leijen 2003, 2004 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Haskell class definitions for the wxWidgets C library (@wxc.dll@). @@ -14,7 +15,7 @@ From the files: - * @C:\Users\-\AppData\Roaming\cabal\x86_64-windows-ghc-7.10.2\wxc-0.92.0.0-8uA6VUEbMCv4OmPqbZ6Pgr\include\wxc.h@ + * @wxc.h@ And contains 571 class definitions. -}
src/haskell/Graphics/UI/WXCore/WxcClasses.hs view
@@ -1,11 +1,12 @@ -------------------------------------------------------------------------------- -{-| Module : WxcClasses - Copyright : Copyright (c) Daan Leijen 2003, 2004 - License : wxWidgets +{-| +Module : WxcClasses +Copyright : Copyright (c) Daan Leijen 2003, 2004 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Haskell class definitions for the wxWidgets C library (@wxc.dll@). @@ -14,7 +15,7 @@ From the files: - * @C:\Users\-\AppData\Roaming\cabal\x86_64-windows-ghc-7.10.2\wxc-0.92.0.0-8uA6VUEbMCv4OmPqbZ6Pgr\include\wxc.h@ + * @wxc.h@ And contains 4324 methods for 277 classes. -}
src/haskell/Graphics/UI/WXCore/WxcClassesAL.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -{-| Module : WxcClassesAL - Copyright : Copyright (c) Daan Leijen 2003, 2004 - License : wxWidgets +{-| +Module : WxcClassesAL +Copyright : Copyright (c) Daan Leijen 2003, 2004 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Haskell class definitions for the wxWidgets C library (@wxc.dll@). @@ -15,7 +16,7 @@ From the files: - * @C:\Users\-\AppData\Roaming\cabal\x86_64-windows-ghc-7.10.2\wxc-0.92.0.0-8uA6VUEbMCv4OmPqbZ6Pgr\include\wxc.h@ + * @wxc.h@ And contains 1987 methods for 147 classes. -} @@ -2160,11 +2161,11 @@ ,logWindowGetFrame ) where +import Prelude hiding (id, last, length, lines, max, min, show) import qualified Data.ByteString as B (ByteString, useAsCStringLen) import qualified Data.ByteString.Lazy as LB (ByteString, length, unpack) import System.IO.Unsafe( unsafePerformIO ) -import Foreign.C.Types(CInt(..), CWchar(..), CChar(..), CDouble(..)) -import Graphics.UI.WXCore.WxcTypes +import Graphics.UI.WXCore.WxcTypes hiding (rect, rgb, rgba, sz) import Graphics.UI.WXCore.WxcClassTypes -- | usage: (@acceleratorEntryCreate flags keyCode cmd@).
src/haskell/Graphics/UI/WXCore/WxcClassesMZ.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -{-| Module : WxcClassesMZ - Copyright : Copyright (c) Daan Leijen 2003, 2004 - License : wxWidgets +{-| +Module : WxcClassesMZ +Copyright : Copyright (c) Daan Leijen 2003, 2004 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Haskell class definitions for the wxWidgets C library (@wxc.dll@). @@ -15,7 +16,7 @@ From the files: - * @C:\Users\-\AppData\Roaming\cabal\x86_64-windows-ghc-7.10.2\wxc-0.92.0.0-8uA6VUEbMCv4OmPqbZ6Pgr\include\wxc.h@ + * @wxc.h@ And contains 2337 methods for 130 classes. -} @@ -2495,11 +2496,11 @@ ,xmlResourceUnload ) where +import Prelude hiding (id, last, length, lines, max, min, show) import qualified Data.ByteString as B (ByteString, useAsCStringLen) import qualified Data.ByteString.Lazy as LB (ByteString, length, unpack) import System.IO.Unsafe( unsafePerformIO ) -import Foreign.C.Types(CInt(..), CWchar(..), CChar(..), CDouble(..)) -import Graphics.UI.WXCore.WxcTypes +import Graphics.UI.WXCore.WxcTypes hiding (rect, rgb, rgba, sz) import Graphics.UI.WXCore.WxcClassTypes -- | usage: (@managedPtrCreateFromBitmap obj@).
src/haskell/Graphics/UI/WXCore/WxcDefs.hs view
@@ -1,11 +1,12 @@ -------------------------------------------------------------------------------- -{-| Module : WxcDefs - Copyright : Copyright (c) Daan Leijen 2003, 2004 - License : wxWidgets +{-| +Module : WxcDefs +Copyright : Copyright (c) Daan Leijen 2003, 2004 +License : wxWidgets - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Haskell constant definitions for the wxWidgets C library (@wxc.dll@). @@ -3704,6 +3705,7 @@ wxAUI_TBTOOL_TEXT_BOTTOM = 3 -- end enum wxAuiToolBarToolTextOrientation +{- -- enum for wxBookCtrlHitTest wxBK_HITTEST_NOWHERE :: Int wxBK_HITTEST_NOWHERE = 1 @@ -3731,6 +3733,7 @@ wxBK_ALIGN_MASK :: Int wxBK_ALIGN_MASK = 240 -- end wxBookCtrl flags +-} -- enum wxSizerFlagBits @@ -3767,7 +3770,7 @@ wxTILE = wxSHAPED .|. wxFIXED_MINSIZE -- a mask to extract stretch from the combination of flags -wxSTRETCH_MASK = 0x7000 -- sans wxTILE +-- wxSTRETCH_MASK = 0x7000 -- sans wxTILE -- End enum wxStretch @@ -3808,7 +3811,7 @@ wxBORDER :: Int wxBORDER = 33554432 --- | This is different from wxBORDER_NONE as by default the controls do +-- | This is different from wxBORDER_NONE, as by default the controls do -- have border wxBORDER_DEFAULT :: Int wxBORDER_DEFAULT = 0 @@ -11093,6 +11096,7 @@ wxSTC_CMD_WORDRIGHTENDEXTEND :: Int wxSTC_CMD_WORDRIGHTENDEXTEND = 2442 +{- wxSPLASH_CENTRE_ON_PARENT :: Int wxSPLASH_CENTRE_ON_PARENT = 1 @@ -11107,3 +11111,4 @@ wxSPLASH_NO_TIMEOUT :: Int wxSPLASH_NO_TIMEOUT = 0 +-}
src/haskell/Graphics/UI/WXCore/WxcObject.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} ----------------------------------------------------------------------------------------- -{-| Module : WxcObject - Copyright : (c) Daan Leijen 2003, 2004 - License : wxWindows +{-| +Module : WxcObject +Copyright : (c) Daan Leijen 2003, 2004 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Basic object type. -} @@ -21,13 +22,8 @@ , ManagedPtr, TManagedPtr, CManagedPtr ) where -import Control.Exception import System.IO.Unsafe( unsafePerformIO ) -import Foreign.C import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal.Alloc -import Foreign.Marshal.Array {- note: for GHC 6.10.2 or higher, recommends to use "import Foreign.Concurrent" See http://www.haskell.org/pipermail/cvs-ghc/2009-January/047120.html -} @@ -123,8 +119,8 @@ objectIsManaged :: Object a -> Bool objectIsManaged obj = case obj of - Managed fp -> True - _ -> False + Managed _fp -> True + _ -> False -- | Test for null object. objectIsNull :: Object a -> Bool @@ -154,14 +150,14 @@ objectFinalize :: Object a -> IO () objectFinalize obj = case obj of - Object p -> return () + Object _p -> return () Managed fp -> withForeignPtr fp $ wxManagedPtr_Finalize -- | Remove the finalizer on a managed object. (No effect on unmanaged objects.) objectNoFinalize :: Object a -> IO () objectNoFinalize obj = case obj of - Object p -> return () + Object _p -> return () Managed fp -> withForeignPtr fp $ wxManagedPtr_NoFinalize
src/haskell/Graphics/UI/WXCore/WxcTypes.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE CPP, ForeignFunctionInterface, DeriveDataTypeable #-} +{-# LANGUAGE CPP, ForeignFunctionInterface, DeriveDataTypeable, FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------------------- -{-| Module : WxcTypes - Copyright : (c) Daan Leijen 2003, 2004 - License : wxWindows +{-| +Module : WxcTypes +Copyright : (c) Daan Leijen 2003, 2004 +License : wxWindows - Maintainer : wxhaskell-devel@lists.sourceforge.net - Stability : provisional - Portability : portable +Maintainer : wxhaskell-devel@lists.sourceforge.net +Stability : provisional +Portability : portable Basic types and marshalling code for the wxWidgets C library. -} @@ -118,8 +119,10 @@ , Ptr(..), ptrNull, ptrIsNull, ptrCast, ForeignPtr, FunPtr, toCFunPtr ) where +#include "wxc_def.h" + import Control.Exception -import System.IO.Unsafe( unsafePerformIO ) +import Data.Ix import Foreign.C import Foreign.Ptr import Foreign.Storable @@ -130,10 +133,7 @@ {- note: for GHC 6.10.2 or higher, recommends to use "import Foreign.Concurrent" See http://www.haskell.org/pipermail/cvs-ghc/2009-January/047120.html -} import Foreign.ForeignPtr hiding (newForeignPtr,addForeignPtrFinalizer) -import Foreign.Concurrent -import Data.Array.MArray (MArray) -import Data.Array.Unboxed (IArray, UArray) import Data.Bits( shiftL, shiftR, (.&.), (.|.) ) import qualified Data.ByteString as B @@ -225,6 +225,33 @@ } deriving (Eq,Show,Read,Typeable) +-- Moved from Types.hs at 2015-09-01 +instance (Num a, Ord a) => Ord (Point2 a) where + compare (Point x1 y1) (Point x2 y2) + = case compare y1 y2 of + EQ -> compare x1 x2 + neq -> neq + +-- Moved from Types.hs at 2015-09-01 +instance Ix (Point2 Int) where + range (Point x1 y1,Point x2 y2) + = [Point x y | y <- [y1..y2], x <- [x1..x2]] + + inRange (Point x1 y1, Point x2 y2) (Point x y) + = (x >= x1 && x <= x2 && y >= y1 && y <= y2) + + rangeSize (Point x1 y1, Point x2 y2) + = let w = abs (x2 - x1) + 1 + h = abs (y2 - y1) + 1 + in w*h + + index bnd@(Point x1 y1, Point x2 _y2) p@(Point x y) + = if inRange bnd p + then let w = abs (x2 - x1) + 1 + in (y-y1)*w + x + else error ("Point index out of bounds: " ++ show p ++ " not in " ++ show bnd) + + -- | Construct a point. point :: (Num a) => a -> a -> Point2 a point x y = Point x y @@ -267,8 +294,8 @@ return (fromCPoint x y) toCIntPointX, toCIntPointY :: Point2 Int -> CInt -toCIntPointX (Point x y) = toCInt x -toCIntPointY (Point x y) = toCInt y +toCIntPointX (Point x _y) = toCInt x +toCIntPointY (Point _x y) = toCInt y fromCPoint :: CInt -> CInt -> Point2 Int fromCPoint x y @@ -288,8 +315,8 @@ return (fromCPointDouble x y) toCDoublePointX, toCDoublePointY :: Point2 Double -> CDouble -toCDoublePointX (Point x y) = toCDouble x -toCDoublePointY (Point x y) = toCDouble y +toCDoublePointX (Point x _y) = toCDouble x +toCDoublePointY (Point _x y) = toCDouble y fromCPointDouble :: CDouble -> CDouble -> Point2 Double fromCPointDouble x y @@ -304,10 +331,10 @@ withWxPointResult :: IO (Ptr (TWxPoint a)) -> IO (Point2 Int) withWxPointResult io - = do pt <- io - x <- wxPoint_GetX pt - y <- wxPoint_GetY pt - wxPoint_Delete pt + = do poynt <- io + x <- wxPoint_GetX poynt + y <- wxPoint_GetY poynt + wxPoint_Delete poynt return (fromCPoint x y) foreign import ccall wxPoint_Delete :: Ptr (TWxPoint a) -> IO () @@ -328,10 +355,12 @@ } deriving (Eq,Show,Typeable) +{- -- | Construct a size from a width and height. size :: (Num a) => a -> a -> Size2D a size w h = Size w h +-} -- | Short function to construct a size sz :: (Num a) => a -> a -> Size2D a @@ -375,8 +404,8 @@ = Size (fromCInt w) (fromCInt h) toCIntSizeW, toCIntSizeH :: Size -> CInt -toCIntSizeW (Size w h) = toCInt w -toCIntSizeH (Size w h) = toCInt h +toCIntSizeW (Size w _h) = toCInt w +toCIntSizeH (Size _w h) = toCInt h withCSizeDouble :: Size2D Double -> (CDouble -> CDouble -> IO a) -> IO a withCSizeDouble (Size w h) f @@ -396,8 +425,8 @@ = Size (fromCDouble w) (fromCDouble h) toCDoubleSizeW, toCDoubleSizeH :: Size2D Double -> CDouble -toCDoubleSizeW (Size w h) = toCDouble w -toCDoubleSizeH (Size w h) = toCDouble h +toCDoubleSizeW (Size w _h) = toCDouble w +toCDoubleSizeH (Size _w h) = toCDouble h {- -- | A @wxSize@ object. @@ -408,10 +437,10 @@ withWxSizeResult :: IO (Ptr (TWxSize a)) -> IO Size withWxSizeResult io - = do sz <- io - w <- wxSize_GetWidth sz - h <- wxSize_GetHeight sz - wxSize_Delete sz + = do size <- io + w <- wxSize_GetWidth size + h <- wxSize_GetHeight size + wxSize_Delete size return (fromCSize w h) foreign import ccall wxSize_Delete :: Ptr (TWxSize a) -> IO () @@ -475,8 +504,8 @@ return (fromCVector x y) toCIntVectorX, toCIntVectorY :: Vector -> CInt -toCIntVectorX (Vector x y) = toCInt x -toCIntVectorY (Vector x y) = toCInt y +toCIntVectorX (Vector x _y) = toCInt x +toCIntVectorY (Vector _x y) = toCInt y fromCVector :: CInt -> CInt -> Vector fromCVector x y @@ -496,8 +525,8 @@ return (fromCVectorDouble x y) toCDoubleVectorX, toCDoubleVectorY :: Vector2 Double -> CDouble -toCDoubleVectorX (Vector x y) = toCDouble x -toCDoubleVectorY (Vector x y) = toCDouble y +toCDoubleVectorX (Vector x _y) = toCDouble x +toCDoubleVectorY (Vector _x y) = toCDouble y fromCVectorDouble :: CDouble -> CDouble -> Vector2 Double fromCVectorDouble x y @@ -506,10 +535,10 @@ withWxVectorResult :: IO (Ptr (TWxPoint a)) -> IO Vector withWxVectorResult io - = do pt <- io - x <- wxPoint_GetX pt - y <- wxPoint_GetY pt - wxPoint_Delete pt + = do poynt <- io + x <- wxPoint_GetX poynt + y <- wxPoint_GetY poynt + wxPoint_Delete poynt return (fromCVector x y) @@ -531,14 +560,14 @@ rectTopLeft, rectTopRight, rectBottomLeft, rectBottomRight :: (Num a) => Rect2D a -> Point2 a -rectTopLeft (Rect l t w h) = Point l t -rectTopRight (Rect l t w h) = Point (l+w) t -rectBottomLeft (Rect l t w h) = Point l (t+h) -rectBottomRight (Rect l t w h) = Point (l+w) (t+h) +rectTopLeft (Rect l t _w _h) = Point l t +rectTopRight (Rect l t w _h) = Point (l + w) t +rectBottomLeft (Rect l t _w h) = Point l (t + h) +rectBottomRight (Rect l t w h) = Point (l + w) (t + h) rectBottom, rectRight :: (Num a) => Rect2D a -> a -rectBottom (Rect x y w h) = y + h -rectRight (Rect x y w h) = x + w +rectBottom (Rect _x y _w h) = y + h +rectRight (Rect x _y w _h) = x + w -- | Create a rectangle at a certain (upper-left) point with a certain size. rect :: (Num a) => Point2 a -> Size2D a -> Rect2D a @@ -563,7 +592,7 @@ -- | Get the size of a rectangle. rectSize :: (Num a) => Rect2D a -> Size2D a -rectSize (Rect l t w h) +rectSize (Rect _l _t w h) = Size w h -- | Create a rectangle of a certain size with the upper-left corner at ('pt' 0 0). @@ -572,7 +601,7 @@ = Rect 0 0 w h rectIsEmpty :: (Num a, Eq a) => Rect2D a -> Bool -rectIsEmpty (Rect l t w h) +rectIsEmpty (Rect _l _t w h) = (w==0 && h==0) @@ -600,10 +629,10 @@ = Rect (fromCInt x) (fromCInt y) (fromCInt w) (fromCInt h) toCIntRectX, toCIntRectY, toCIntRectW, toCIntRectH :: Rect -> CInt -toCIntRectX (Rect x y w h) = toCInt x -toCIntRectY (Rect x y w h) = toCInt y -toCIntRectW (Rect x y w h) = toCInt w -toCIntRectH (Rect x y w h) = toCInt h +toCIntRectX (Rect x _y _w _h) = toCInt x +toCIntRectY (Rect _x y _w _h) = toCInt y +toCIntRectW (Rect _x _y w _h) = toCInt w +toCIntRectH (Rect _x _y _w h) = toCInt h withCRectDouble :: Rect2D Double -> (CDouble -> CDouble -> CDouble -> CDouble -> IO a) -> IO a withCRectDouble (Rect x0 y0 x1 y1) f @@ -627,10 +656,10 @@ = Rect (fromCDouble x) (fromCDouble y) (fromCDouble w) (fromCDouble h) toCDoubleRectX, toCDoubleRectY, toCDoubleRectW, toCDoubleRectH :: Rect2D Double -> CDouble -toCDoubleRectX (Rect x y w h) = toCDouble x -toCDoubleRectY (Rect x y w h) = toCDouble y -toCDoubleRectW (Rect x y w h) = toCDouble w -toCDoubleRectH (Rect x y w h) = toCDouble h +toCDoubleRectX (Rect x _y _w _h) = toCDouble x +toCDoubleRectY (Rect _x y _w _h) = toCDouble y +toCDoubleRectW (Rect _x _y w _h) = toCDouble w +toCDoubleRectH (Rect _x _y _w h) = toCDouble h -- marshalling 2 {- @@ -640,9 +669,11 @@ data CWxRectObject a = CWxRectObject -} +{- withWxRectRef :: String -> Rect -> (Ptr (TWxRect r) -> IO a) -> IO a withWxRectRef msg r f = withWxRectPtr r $ \p -> withValidPtr msg p f +-} withWxRectPtr :: Rect -> (Ptr (TWxRect r) -> IO a) -> IO a withWxRectPtr r f @@ -741,7 +772,7 @@ if (len<=0) then return "" else withCString (replicate (fromCInt len) ' ') $ \cstr -> - do f cstr + do _ <- f cstr peekCStringLen (cstr,fromCInt len) withWStringResult :: (Ptr CWchar -> IO CInt) -> IO String @@ -750,7 +781,7 @@ if (len<=0) then return "" else withCWString (replicate (fromCInt len) ' ') $ \cstr -> - do f cstr + do _ <- f cstr peekCWString cstr {----------------------------------------------------------------------------------------- @@ -764,7 +795,7 @@ if (len<=0) then return $ BC.pack "" else withCString (replicate (fromCInt len) ' ') $ \cstr -> - do f cstr + do _ <- f cstr B.packCStringLen (cstr,fromCInt len) withLazyByteStringResult :: (Ptr CChar -> IO CInt) -> IO LB.ByteString @@ -782,7 +813,7 @@ if (len <= 0) then return [] else allocaArray len $ \carr -> - do f carr + do _ <- f carr arr <- peekArray len carr mapM peekCString arr @@ -794,7 +825,7 @@ if (len <= 0) then return [] else allocaArray len $ \carr -> - do f carr + do _ <- f carr arr <- peekArray len carr mapM peekCWString arr @@ -806,7 +837,7 @@ if (len <= 0) then return [] else allocaArray len $ \carr -> - do f carr + do _ <- f carr xs <- peekArray len carr return (map fromCInt xs) @@ -817,7 +848,7 @@ if (len <= 0) then return [] else allocaArray len $ \carr -> - do f carr + do _ <- f carr xs <- peekArray len carr return (map fromCIntPtr xs) @@ -828,7 +859,7 @@ if (len <= 0) then return [] else allocaArray len $ \carr -> - do f carr + do _ <- f carr ps <- peekArray len carr return (map objectFromPtr ps) @@ -840,11 +871,11 @@ where len = length xs - withCStrings [] cxs f - = f (reverse cxs) - withCStrings (x:xs) cxs f - = withCString x $ \cx -> - withCStrings xs (cx:cxs) f + withCStrings [] cxs f' + = f' (reverse cxs) + withCStrings (x':xs') cxs f' + = withCString x' $ \cx -> + withCStrings xs' (cx:cxs) f' -- FIXME: factorise with withArrayString withArrayWString :: [String] -> (CInt -> Ptr CWString -> IO a) -> IO a @@ -855,11 +886,11 @@ where len = length xs - withCWStrings [] cxs f - = f (reverse cxs) - withCWStrings (x:xs) cxs f - = withCWString x $ \cx -> - withCWStrings xs (cx:cxs) f + withCWStrings [] cxs f' + = f' (reverse cxs) + withCWStrings (x':xs') cxs f' + = withCWString x' $ \cx -> + withCWStrings xs' (cx:cxs) f' withArrayInt :: [Int] -> (CInt -> Ptr CInt -> IO a) -> IO a @@ -945,6 +976,7 @@ {----------------------------------------------------------------------------------------- Marshalling of classes that are managed -----------------------------------------------------------------------------------------} +{- -- | A @Managed a@ is a pointer to an object of type @a@, just like 'Object'. However, -- managed objects are automatically deleted when garbage collected. This is used for -- certain classes that are not managed by the wxWidgets library, like 'Bitmap's @@ -987,6 +1019,7 @@ managedCast :: Managed a -> Managed b managedCast fptr = castForeignPtr fptr +-} {----------------------------------------------------------------------------------------- @@ -1251,14 +1284,14 @@ s <- if (len<=0) then return "" else withCWString (replicate (fromCInt len) ' ') $ \cstr -> - do wxString_GetString wxs cstr + do _ <- wxString_GetString wxs cstr peekCWStringLen (cstr, fromCInt len) wxString_Delete wxs return s foreign import ccall wxString_Create :: Ptr CWchar -> IO (Ptr (TWxString a)) -foreign import ccall wxString_CreateLen :: Ptr CWchar -> CInt -> IO (Ptr (TWxString a)) +-- foreign import ccall wxString_CreateLen :: Ptr CWchar -> CInt -> IO (Ptr (TWxString a)) foreign import ccall wxString_Delete :: Ptr (TWxString a) -> IO () foreign import ccall wxString_GetString :: Ptr (TWxString a) -> Ptr CWchar -> IO CInt foreign import ccall wxString_Length :: Ptr (TWxString a) -> IO CInt @@ -1286,10 +1319,10 @@ instance Show Color where showsPrec d c - = showParen (d > 0) (showString "rgba(" . shows (colorRed c) . - showChar ',' . shows (colorGreen c) . - showChar ',' . shows (colorBlue c) . - showChar ',' . shows (colorAlpha c) . + = showParen (d > 0) (showString "rgba(" . shows (colorRed c :: Int) . + showChar ',' . shows (colorGreen c :: Int) . + showChar ',' . shows (colorBlue c :: Int) . + showChar ',' . shows (colorAlpha c :: Int) . showChar ')' ) -- | Create a color from a red\/green\/blue triple. @@ -1312,25 +1345,25 @@ -- | Return an 'Int' where the three least significant bytes contain -- the red, green, and blue component of a color. intFromColor :: Color -> Int -intFromColor rgb - = let r = colorRed rgb - g = colorGreen rgb - b = colorBlue rgb - in (shiftL (fromIntegral r) 16 .|. shiftL (fromIntegral g) 8 .|. b) +intFromColor colr + = let r = colorRed colr + g = colorGreen colr + b = colorBlue colr + in (shiftL r 16 .|. shiftL g 8 .|. b) -- | Set the color according to an rgb integer. (see 'rgbIntFromColor'). colorFromInt :: Int -> Color -colorFromInt rgb - = let r = (shiftR rgb 16) .&. 0xFF - g = (shiftR rgb 8) .&. 0xFF - b = rgb .&. 0xFF +colorFromInt colr + = let r = (shiftR colr 16) .&. 0xFF + g = (shiftR colr 8) .&. 0xFF + b = colr .&. 0xFF in colorRGB r g b -- | Return an 'Num' class's numeric representation where the three -- least significant the red, green, and blue component of a color. fromColor :: (Num a) => Color -> a -fromColor (Color rgb) - = fromIntegral rgb +fromColor (Color colr) + = fromIntegral colr -- | Set the color according to 'Integral' class's numeric representation. -- (see 'rgbaIntFromColor'). @@ -1341,19 +1374,19 @@ -- marshalling 1 -- | Returns a red color component colorRed :: (Num a) => Color -> a -colorRed (Color rgba) = fromIntegral ((shiftR rgba 24) .&. 0xFF) +colorRed (Color colr) = fromIntegral ((shiftR colr 24) .&. 0xFF) -- | Returns a green color component colorGreen :: (Num a) => Color -> a -colorGreen (Color rgba) = fromIntegral ((shiftR rgba 16) .&. 0xFF) +colorGreen (Color colr) = fromIntegral ((shiftR colr 16) .&. 0xFF) -- | Returns a blue color component colorBlue :: (Num a) => Color -> a -colorBlue (Color rgba) = fromIntegral ((shiftR rgba 8) .&. 0xFF) +colorBlue (Color colr) = fromIntegral ((shiftR colr 8) .&. 0xFF) -- | Returns a alpha channel component colorAlpha :: (Num a) => Color -> a -colorAlpha (Color rgba) = fromIntegral (rgba .&. 0xFF) +colorAlpha (Color colr) = fromIntegral (colr .&. 0xFF) -- | This is an illegal color, corresponding to @nullColour@. @@ -1389,8 +1422,8 @@ color <- do ok <- colourIsOk pcolour if (ok==0) then return colorNull - else do rgba <- colourGetUnsignedInt pcolour - return (toColor rgba) + else do colr <- colourGetUnsignedInt pcolour + return (toColor colr) colourSafeDelete pcolour return color @@ -1423,13 +1456,13 @@ do ok <- colourIsOk pcolour if (ok==0) then return colorNull - else do rgba <- colourGetUnsignedInt pcolour - return (toColor rgba) + else do colr <- colourGetUnsignedInt pcolour + return (toColor colr) foreign import ccall "wxColour_CreateEmpty" colourCreate :: IO (Ptr (TColour a)) -foreign import ccall "wxColour_CreateFromInt" colourCreateFromInt :: CInt -> IO (Ptr (TColour a)) -foreign import ccall "wxColour_GetInt" colourGetInt :: Ptr (TColour a) -> IO CInt +-- foreign import ccall "wxColour_CreateFromInt" colourCreateFromInt :: CInt -> IO (Ptr (TColour a)) +-- foreign import ccall "wxColour_GetInt" colourGetInt :: Ptr (TColour a) -> IO CInt foreign import ccall "wxColour_CreateFromUnsignedInt" colourCreateFromUnsignedInt :: Word -> IO (Ptr (TColour a)) foreign import ccall "wxColour_GetUnsignedInt" colourGetUnsignedInt :: Ptr (TColour a) -> IO Word foreign import ccall "wxColour_SafeDelete" colourSafeDelete :: Ptr (TColour a) -> IO ()
wxcore.cabal view
@@ -1,5 +1,5 @@ name: wxcore -version: 0.92.0.0 +version: 0.92.1.0 license: OtherLicense license-file: LICENSE author: Daan Leijen @@ -16,7 +16,7 @@ LICENSE file, but note that this is essentially LGPL with an exception allowing binary distribution of proprietary software. This is the same license as wxWidgets itself uses. -homepage: http://haskell.org/haskellwiki/WxHaskell +homepage: https://wiki.haskell.org/WxHaskell cabal-version: >= 1.2 build-type: Custom @@ -86,3 +86,5 @@ array >= 0.1 && < 0.3, base >= 3 && < 4, containers >= 0.1 && < 0.3 + + ghc-options: -Wall