{-# 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 ()