{-# LANGUAGE CPP, ForeignFunctionInterface, ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies #-} module Graphics.UI.FLTK.Widget (Attr(..), Prop(..), set, get, Value_FC(..), Widget, Widget_C(..), changed, label, When, when, tooltip, labelSize, redraw, redrawLabel, wNever, wChanged, wRelease, wReleaseAllways, wEnter, wEnterAllways, wEnterChanged, wNotChanged, Act, destroy, wait, Color, black, red, green, yellow, blue, magenta, cyan, white, rgb, color, labelColor, selectionColor, CFlag(..), Align, align, coords, aBottom, aCenter, aClip, aInside, aLeft, aRight, aTextOverImage, aTop, aWrap ) where import Foreign.C.String import Foreign import Foreign.StablePtr infixr 5 := -- | An attribute is just a getter and a setter function. data Attr c a = Attr (c -> IO a) (c -> a -> IO ()) -- | Properties are the heart of the system. data Prop c = forall a. Attr c a := a | forall a. Attr c a ::= IO a | forall a. Attr c a :=> (a -> a) | forall a. Attr c a ::=> (a -> IO a) -- | Set a number of properties for some object. set :: c -> [Prop c] -> IO () set c = mapM_ app where app (Attr _ s := v) = s c v app (Attr g s ::= m) = m >>= s c app (Attr g s :=> f) = g c >>= \v -> s c (f v) app (Attr g s ::=> m)= g c >>= m >>= s c -- | Get an Attr of an object. get :: c -> Attr c a -> IO a get c (Attr g _) = g c -- Function classes -- | Function class to get and set the value of a widget. class Value_FC c v | c -> v where value :: Attr c v -- Widgets -- | Type for widgets newtype Widget = Widget (Ptr Widget) -- | Class for widgets class Widget_C a where _widget :: a -> Ptr Widget action :: Attr a (Act a) action = Attr actionG actionS instance Widget_C Widget where _widget (Widget p) = p foreign import ccall "fl_Widget_redraw" _redraw :: Ptr Widget -> IO () foreign import ccall "fl_Widget_redraw_label" _redrawLabel :: Ptr Widget -> IO () -- | Redraw a widget. redraw :: Widget_C w => w -> IO () redraw = _redraw._widget -- | Redraw a widget label redrawLabel :: Widget_C w => w -> IO () redrawLabel = _redrawLabel._widget foreign import ccall "fl_Widget_changed_AG" fl_Widget_changed_AG :: Ptr Widget -> IO Bool foreign import ccall "fl_Widget_changed_AS" fl_Widget_changed_AS :: Ptr Widget -> Bool -> IO () -- | Has the widget changed? changed :: Widget_C c => Attr c Bool changed = Attr (fl_Widget_changed_AG._widget) (\c v -> fl_Widget_changed_AS (_widget c) v) foreign import ccall "fl_Widget_label_AG" fl_Widget_label_AG :: Ptr Widget -> IO CString foreign import ccall "fl_Widget_label_AS" fl_Widget_label_AS :: Ptr Widget -> CString -> IO () -- | The label of the widget. label :: Widget_C c => Attr c String label = Attr (\w -> fl_Widget_label_AG (_widget w) >>= peekCString) (\c v -> newCString v >>= fl_Widget_label_AS (_widget c)) foreign import ccall "fl_Widget_labelsize_AG" fl_Widget_labelsize_AG :: Ptr Widget -> IO Int foreign import ccall "fl_Widget_labelsize_AS" fl_Widget_labelsize_AS :: Ptr Widget -> Int -> IO () -- | Size of label in pt. labelSize :: Widget_C c => Attr c Int labelSize = Attr (fl_Widget_labelsize_AG._widget) (\c v -> fl_Widget_labelsize_AS (_widget c) v) foreign import ccall "fl_Widget_tooltip_AG" fl_Widget_tooltip_AG :: Ptr Widget -> IO CString foreign import ccall "fl_Widget_tooltip_AS" fl_Widget_tooltip_AS :: Ptr Widget -> CString -> IO () -- | The tooltip of the widget. tooltip :: Widget_C c => Attr c String tooltip = Attr (\w -> fl_Widget_tooltip_AG (_widget w) >>= peekCString) (\c v -> newCString v >>= fl_Widget_tooltip_AS (_widget c)) -- | When are actions fired? newtype When = When Int -- | Never any actions wNever = When 0 -- | When the widget is changed. wChanged = When 1 -- | When the widget is released. wRelease = When 4 -- | Allways when the widget is pressed. wReleaseAllways = When 6 -- | When enter is pressed. wEnter = When 8 -- | When enter is pressed allways. wEnterAllways = When 10 -- | When enter is pressed and widget changed. wEnterChanged = When 11 -- | When widget not changed. wNotChanged = When 2 foreign import ccall "fl_Widget_when_AG" fl_Widget_when_AG:: Ptr Widget -> IO When foreign import ccall "fl_Widget_when_AS" fl_Widget_when_AS:: Ptr Widget -> When ->IO() -- | Change when the action is fired. when :: Widget_C c => Attr c When when = Attr (fl_Widget_when_AG._widget) (\w v -> fl_Widget_when_AS (_widget w) v) -- | The type for actions. type Act t = t -> IO () foreign import ccall "fl_Widget_action_AG" fl_Widget_action_AG :: Ptr a -> IO (StablePtr (Act b)) foreign import ccall "fl_Widget_action_AS" fl_Widget_action_AS :: Ptr a -> StablePtr (Act b) ->IO() foreign export ccall "mhf_callback_handler" callbackHandler :: Widget -> StablePtr (Act Widget) -> IO () callbackHandler w sp = if castStablePtrToPtr sp == nullPtr then return () else deRefStablePtr sp >>= \h -> h w actionG :: Widget_C c => c -> IO (Act c) actionG w = fl_Widget_action_AG (_widget w) >>= deRefStablePtr actionS :: Widget_C c => c -> Act c -> IO () actionS w v = newStablePtr v >>= fl_Widget_action_AS (_widget w) nothing _ = return () -- Deletion foreign import ccall "fl_Widget_delete" _delete :: Ptr Widget -> IO () -- | Destroy a widget destroy :: Widget_C w => w -> IO () destroy w = _delete (_widget w) -- Colors newtype Color = Color Int black = Color 56 red = Color 88 green = Color 63 yellow = Color 95 blue = Color 216 magenta = Color 248 cyan = Color 223 white = Color 255 foreign import ccall "fl_rgb" rgb :: Int -> Int -> Int -> Color foreign import ccall "fl_Widget_color_AG" fl_Widget_color_AG:: Ptr Widget -> IO Color foreign import ccall "fl_Widget_color_AS" fl_Widget_color_AS:: Ptr Widget -> Color ->IO() -- | Change Color the action is fired. color :: Widget_C c => Attr c Color color = Attr (fl_Widget_color_AG._widget) (\w v -> fl_Widget_color_AS (_widget w) v) foreign import ccall "fl_Widget_labelcolor_AG" fl_Widget_labelcolor_AG:: Ptr Widget -> IO Color foreign import ccall "fl_Widget_labelcolor_AS" fl_Widget_labelcolor_AS:: Ptr Widget -> Color ->IO() -- | Change Color the action is fired. labelColor :: Widget_C c => Attr c Color labelColor = Attr (fl_Widget_labelcolor_AG._widget) (\w v -> fl_Widget_labelcolor_AS (_widget w) v) foreign import ccall "fl_Widget_selection_color_AG" fl_Widget_selection_color_AG:: Ptr Widget -> IO Color foreign import ccall "fl_Widget_selection_color_AS" fl_Widget_selection_color_AS:: Ptr Widget -> Color ->IO() -- | Change Color the action is fired. selectionColor :: Widget_C c => Attr c Color selectionColor = Attr (fl_Widget_selection_color_AG._widget) (\w v -> fl_Widget_selection_color_AS (_widget w) v) -- Alignment class CFlag a where (+|+) :: a -> a -> a newtype Align = A Int instance CFlag Align where (A a) +|+ (A b) = A $ a + b aBottom, aCenter, aClip, aInside, aLeft, aRight, aTextOverImage, aTop, aWrap :: Align aBottom = A 2 aCenter = A 0 aClip = A 64 aInside = A 16 aLeft = A 4 aRight = A 8 aTextOverImage = A 32 aTop = A 1 aWrap = A 128 foreign import ccall "fl_Widget_align_AG" fl_Widget_align_AG:: Ptr Widget -> IO Align foreign import ccall "fl_Widget_align_AS" fl_Widget_align_AS:: Ptr Widget -> Align ->IO() -- | Change Align the action is fired. align :: Widget_C c => Attr c Align align = Attr (fl_Widget_align_AG._widget) (\w v -> fl_Widget_align_AS (_widget w) v) -- Coordinates foreign import ccall "fl_Widget_Coords_AG" coordsAG :: Ptr Widget -> Ptr Int -> IO () foreign import ccall "fl_Widget_Coords_AS" coordsAS :: Ptr Widget -> Int->Int->Int->Int -> IO () -- | Coordinates (x,y,width,heigth) of a widget coords :: Widget_C c => Attr c (Int,Int,Int,Int) coords = Attr (\w -> allocaArray 4 $ getCoords $ _widget w) (\p (x,y,w,h) -> coordsAS (_widget p) x y w h) getCoords w p = do coordsAG w p [x,y,w,h] <- peekArray 4 p return (x,y,w,h) foreign import ccall "fl_wait" wait :: IO ()