type role Ref nominal

type role Ref nominal

{-# LANGUAGE CPP, EmptyDataDecls, ExistentialQuantification, RoleAnnotations #-}

#ifdef CALLSTACK_AVAILABLE
{-# LANGUAGE ImplicitParams #-}
#endif

module Graphics.UI.FLTK.LowLevel.Fl_Types where
#include "Fl_Types.h"
#include "Fl_Text_EditorC.h"
#include "FL/platform_types.h"
import Foreign
import Foreign.C hiding (CClock)
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import qualified Foreign.ForeignPtr.Unsafe as Unsafe
import Debug.Trace
import Control.Exception
import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)
import qualified Data.Text as T
#if defined(CALLSTACK_AVAILABLE) || defined(HASCALLSTACK_AVAILABLE)
import GHC.Stack
#endif
import qualified Data.ByteString as B
#c
  enum SliderType {
    VertSliderType = FL_VERT_SLIDER,
    HorSliderType = FL_HOR_SLIDER,
    VertFillSliderType = FL_VERT_FILL_SLIDER,
    HorFillSliderType = FL_HOR_FILL_SLIDER,
    VertNiceSliderType = FL_VERT_NICE_SLIDER,
    HorNiceSliderType = FL_HOR_NICE_SLIDER
  };
  enum ScrollbarType {
    VertScrollbar = FL_VERT_SLIDER,
    HorScrollbar = FL_HOR_SLIDER
  };
  enum BrowserType {
    NormalBrowserType = FL_NORMAL_BROWSER,
    SelectBrowserType = FL_SELECT_BROWSER,
    HoldBrowserType = FL_HOLD_BROWSER,
    MultiBrowserType = FL_MULTI_BROWSER
  };
  enum SortType {
    SortAscending = FL_SORT_ASCENDING,
    SortDescending = FL_SORT_DESCENDING
  };
  enum FileBrowserType {
    FileBrowserFiles = FL_FILE_BROWSER_FILES,
    FileBrowserDirectories = FL_FILE_BROWSER_DIRECTORIES,
  };
  enum FileIconType {
 FileIconAny = FL_FILE_ICON_ANY,
 FileIconPlain = FL_FILE_ICON_PLAIN,
 FileIconFifo = FL_FILE_ICON_FIFO,
 FileIconDevice = FL_FILE_ICON_DEVICE,
 FileIconLink = FL_FILE_ICON_LINK,
 FileIconDirectory = FL_FILE_ICON_DIRECTORY
  };
  enum FileIconProps {
 FileIconEnd = FL_FILE_ICON_END,
 FileIconColor = FL_FILE_ICON_COLOR,
 FileIconLine = FL_FILE_ICON_LINE,
 FileIconClosedline = FL_FILE_ICON_CLOSEDLINE,
 FileIconPolygon = FL_FILE_ICON_POLYGON,
 FileIconOutlinepolygon = FL_FILE_ICON_OUTLINEPOLYGON,
 FileIconVertex = FL_FILE_ICON_VERTEX
  };
  enum FileChooserType {
 FileChooserSingle = FL_FILE_CHOOSER_SINGLE,
 FileChooserMulti = FL_FILE_CHOOSER_MULTI,
 FileChooserCreate = FL_FILE_CHOOSER_CREATE,
 FileChooserDirectory = FL_FILE_CHOOSER_DIRECTORY
  };
  enum ButtonType{
   NormalButtonType = FL_NORMAL_BUTTON,
   ToggleButtonType = FL_TOGGLE_BUTTON,
   RadioButtonType = FL_RADIO_BUTTON,
   HiddenButtonType = FL_HIDDEN_BUTTON
  };
  enum TreeReasonType {
    TreeReasonNone = FL_TREE_REASON_NONE,
    TreeReasonSelected = FL_TREE_REASON_SELECTED,
    TreeReasonDeselected = FL_TREE_REASON_DESELECTED,
    TreeReasonReselected = FL_TREE_REASON_RESELECTED,
    TreeReasonOpened = FL_TREE_REASON_OPENED,
    TreeReasonClosed = FL_TREE_REASON_CLOSED,
    TreeReasonDragged = FL_TREE_REASON_DRAGGED
  };
  enum MenuItemFlag{
     MenuItemNormal = 0,
     MenuItemInactive = FL_MENU_INACTIVE,
     MenuItemToggle = FL_MENU_TOGGLE,
     MenuItemValue = FL_MENU_VALUE,
     MenuItemRadio = FL_MENU_RADIO,
     MenuItemInvisible = FL_MENU_INVISIBLE,
     SubmenuPointer = FL_SUBMENU_POINTER,
     Submenu = FL_SUBMENU,
     MenuItemDivider = FL_MENU_DIVIDER,
     MenuItemHorizontal = FL_MENU_HORIZONTAL
  };
  enum ScrollbarMode {
    HorizontalScrollBar = HORIZONTAL,
    VerticalScrollBar = VERTICAL,
    BothScrollBar = BOTH,
    AlwaysOnScrollBar = ALWAYS_ON,
    HorizontalAlwaysScrollBar = HORIZONTAL_ALWAYS,
    VerticalAlwaysScrollBar = VERTICAL_ALWAYS,
    BothAlwaysScrollBar = BOTH_ALWAYS
  };
  enum CursorType {
    NormalCursor = NORMAL_CURSOR,
    CaretCursor = CARET_CURSOR,
    DimCursor = DIM_CURSOR,
    BlockCursor = BLOCK_CURSOR,
    HeavyCursor = HEAVY_CURSOR,
    SimpleCursor = SIMPLE_CURSOR
  };
  enum PositionType {
    CursorPos = CURSOR_POS,
    CharacterPos = CHARACTER_POS
  };
  enum DragType {
    DragNone = DRAG_NONE,
    DragStartDnd = DRAG_START_DND,
    DragChar = DRAG_CHAR,
    DragWord = DRAG_WORD,
    DragLine = DRAG_LINE
  };
  enum WrapTypeFl {
    WrapNoneFl = WRAP_NONE,
    WrapAtColumnFl = WRAP_AT_COLUMN,
    WrapAtPixelFl = WRAP_AT_PIXEL,
    WrapAtBoundsFl = WRAP_AT_BOUNDS
  };
  enum PageFormat {
    A0 = 0,
    A1 = 1,
    A2 = 2,
    A3 = 3,
    A4 = 4,
    A5 = 5,
    A6 = 6,
    A7 = 7,
    A8 = 8,
    A9 = 9,
    B0 = 10,
    B1 = 11,
    B2 = 12,
    B3 = 13,
    B4 = 14,
    B5 = 15,
    B6 = 16,
    B7 = 17,
    B8 = 18,
    B9 = 19,
    B10 = 20,
    C5E = 21,
    DLE = 22,
    Executive = EXECUTIVE,
    Folio = FOLIO,
    Ledger = LEDGER,
    Legal = LEGAL,
    Letter = LETTER,
    Tabloid = TABLOID,
    Envelope = ENVELOPE,
    Media = MEDIA
  };
  enum PageLayout {
    Portrait = PORTRAIT,
    Landscape = LANDSCAPE,
    Reversed = REVERSED,
    Orientation = ORIENTATION
  };
  typedef struct KeyBinding {
    int key;
    int state;
    fl_Key_Func* function;
  } KeyBinding;
  enum TableRowSelectMode {
     SelectNone = SELECT_NONEC,
     SelectSingle = SELECT_SINGLEC,
     SelectMulti = SELECT_MULTIC
  };
  enum TableContext {
     ContextNone = CONTEXT_NONEC,
     ContextStartPage = CONTEXT_STARTPAGEC,
     ContextEndPage = CONTEXT_ENDPAGEC,
     ContextRowHeader = CONTEXT_ROW_HEADERC,
     ContextColHeader = CONTEXT_COL_HEADERC,
     ContextCell = CONTEXT_CELLC,
     ContextTable = CONTEXT_TABLEC,
     ContextRCResize = CONTEXT_RC_RESIZEC
  };
  enum LinePosition {
    LinePositionTop = TOP,
    LinePositionMiddle = MIDDLE,
    LinePositionBottom = BOTTOM
  };
  enum PackType {
    PackVertical = PACK_VERTICAL,
    PackHorizontal = PACK_HORIZONTAL
  };
  enum ColorChooserMode {
    RgbMode = 0,
    ByteMode = 1,
    HexMode = 2,
    HsvMode = 3
  };
#endc
{#enum SliderType {} deriving (Show, Eq, Ord) #}
{#enum ScrollbarType {} deriving (Show, Eq, Ord) #}
{#enum BrowserType {} deriving (Show, Eq, Ord) #}
{#enum SortType {} deriving (Show, Eq, Ord) #}
{#enum FileBrowserType {} deriving (Show, Eq, Ord) #}
{#enum FileIconType {} deriving (Show, Eq, Ord) #}
{#enum FileIconProps {} deriving (Show, Eq, Ord) #}
{#enum FileChooserType {} deriving (Show, Eq, Ord) #}
{#enum ButtonType {} deriving (Show, Eq, Ord) #}
{#enum TreeReasonType {} deriving (Show, Eq, Ord) #}
{#enum MenuItemFlag {} deriving (Show, Eq, Ord) #}
{#enum ColorChooserMode {} deriving (Show, Eq, Ord) #}
newtype MenuItemFlags = MenuItemFlags [MenuItemFlag] deriving (Eq, Show, Ord)
allMenuItemFlags :: [MenuItemFlag]
allMenuItemFlags =
  [
     MenuItemInactive,
     MenuItemToggle,
     MenuItemValue,
     MenuItemRadio,
     MenuItemInvisible,
     SubmenuPointer,
     Submenu,
     MenuItemDivider,
     MenuItemHorizontal
  ]
{#enum CursorType {} deriving (Show, Eq, Ord) #}
{#enum PositionType {} deriving (Show, Eq, Ord) #}
{#enum DragType {} deriving (Show, Eq, Ord) #}
{#enum WrapTypeFl {} deriving (Show, Eq, Ord) #}
data WrapType = WrapNone | WrapAtColumn ColumnNumber | WrapAtPixel PixelPosition | WrapAtBounds deriving (Eq, Show, Ord)
{#enum PageFormat {} deriving (Show, Eq, Ord) #}
{#enum PageLayout {} deriving (Show, Eq, Ord) #}
{#enum TableRowSelectMode {} deriving (Show, Eq, Ord)  #}
{#enum TableContext {} deriving (Show, Eq, Ord) #}
{#enum LinePosition {} deriving (Show, Eq, Ord)  #}
{#enum ScrollbarMode {} deriving (Show, Eq, Ord) #}
data StyleTableEntry = StyleTableEntry (Maybe Color) (Maybe Font) (Maybe FontSize) deriving (Eq, Show, Ord)
{#enum PackType{} deriving (Show, Eq, Ord) #}
type FlShortcut      = {#type Fl_Shortcut #}
type FlColor         = {#type Fl_Color #}
type FlFont          = {#type Fl_Font #}
type FlAlign         = {#type Fl_Align #}
type LineDelta       = Maybe Int
type Delta           = Maybe Int
type FlIntPtr        = {#type fl_intptr_t #}
type FlUIntPtr       = {#type fl_uintptr_t#}
type ID              = {#type ID#}
type Fl_Offscreen = {#type Fl_Offscreen #}
type Fl_Socket = {#type FL_SOCKET #}
type Fl_Bitmask = {#type Fl_Bitmask #}
type Fl_Region = {#type Fl_Region #}
newtype WindowHandle = WindowHandle (Ptr ())

newtype NumInserted = NumInserted Int deriving (Show, Eq, Ord)
newtype NumDeleted = NumDeleted Int deriving (Show, Eq, Ord)
newtype NumRestyled = NumRestyled Int deriving (Show, Eq, Ord)
newtype DeletedText = DeletedText T.Text deriving (Show, Eq, Ord)

type role Ref nominal
data Ref a           = Ref !(ForeignPtr (Ptr ())) deriving (Eq, Show, Ord)
data FunRef          = FunRef !(FunPtr ())
-- * The FLTK widget hierarchy
data CBase parent
type Base = CBase ()

type GlobalCallback              = IO ()
type CallbackWithUserDataPrim    = Ptr () -> Ptr () -> IO ()
type CallbackPrim                = Ptr () -> IO ()
type CustomColorAveragePrim    = Ptr () -> CUInt -> CFloat -> IO ()
type CustomImageDrawPrim       = Ptr () -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO ()
type CustomImageCopyPrim       = Ptr () -> CInt -> CInt -> IO (Ptr ())
type GlobalEventHandlerPrim      = CInt -> IO CInt
type GlobalEventHandlerF         = Event -> IO Int
type DrawCallback                = T.Text -> Position -> IO ()
type DrawCallbackPrim            = CString -> CInt -> CInt -> CInt -> IO ()
type TextBufferCallback          = FunPtr (Ptr () -> IO ())
type FileChooserCallback         = FunPtr (Ptr () -> Ptr () -> IO())
type SharedImageHandler          = FunPtr (CString -> CUChar -> CInt -> Ptr ())
type BoxDrawF                    = Rectangle -> Color -> IO ()
type BoxDrawFPrim                = CInt -> CInt -> CInt -> CInt -> FlColor -> IO ()
type FDHandlerPrim               = Fl_Socket -> Ptr () -> IO ()
type FDHandler                   = FlSocket -> IO ()
type TextModifyCb                = AtIndex -> NumInserted -> NumDeleted -> NumRestyled -> DeletedText -> IO ()
type TextModifyCbPrim            = CInt -> CInt -> CInt -> CInt -> Ptr CChar -> Ptr () -> IO ()
type TextPredeleteCb             = AtIndex -> NumDeleted -> IO ()
type TextPredeleteCbPrim         = CInt -> CInt -> Ptr () -> IO ()
type UnfinishedStyleCb           = AtIndex -> IO ()
type UnfinishedStyleCbPrim       = CInt -> Ptr () -> IO ()
type MenuItemDrawF               = Ptr () -> CInt -> CInt -> CInt -> CInt -> Ptr () -> CInt -> IO ()
type TabPositionsPrim            = Ptr () -> Ptr CInt -> Ptr CInt -> IO CInt
type TabHeightPrim               = Ptr () -> IO CInt
type TabWhichPrim                = Ptr () -> CInt -> CInt -> IO (Ptr ())
type TabClientAreaPrim           = Ptr () -> Ptr CInt -> Ptr CInt ->  Ptr CInt -> Ptr CInt -> CInt -> IO ()
type GetDoublePrim               = Ptr () -> IO (CDouble)
type GetIntPrim                  = Ptr () -> IO CInt
type SetIntPrim                  = Ptr () -> CInt -> IO ()
type ColorSetPrim                = Ptr () -> CDouble -> CDouble -> CDouble -> IO CInt
type DestroyCallbacksPrim        = Ptr () -> Ptr () -> IO ()

newtype Width = Width Int deriving (Eq, Show, Ord)
newtype Height = Height Int deriving (Eq, Show, Ord)
newtype PreciseWidth = PreciseWidth Double deriving (Eq, Show, Ord)
newtype PreciseHeight = PreciseHeight Double deriving (Eq, Show, Ord)
newtype Depth = Depth Int deriving (Eq, Show, Ord)
newtype LineSize = LineSize Int deriving (Eq, Show, Ord)
newtype X = X Int deriving (Eq, Show, Ord)
newtype PreciseX = PreciseX Double deriving (Eq, Show, Ord)
newtype Y = Y Int deriving (Eq, Show, Ord)
newtype PreciseY = PreciseY Double deriving (Eq, Show, Ord)
newtype ByX = ByX Double deriving (Eq, Show, Ord)
newtype ByY = ByY Double deriving (Eq, Show, Ord)
newtype Angle = Angle CShort deriving (Eq, Show, Ord)
newtype PreciseAngle = PreciseAngle Double deriving (Eq, Show, Ord)
data Position = Position X Y deriving (Eq, Show, Ord)
data PrecisePosition = PrecisePosition PreciseX PreciseY deriving (Eq, Show, Ord)
data CountDirection = CountUp | CountDown deriving (Eq, Show, Ord)
data DPI = DPI Float Float deriving (Eq, Show, Ord)
newtype TextDisplayStyle = TextDisplayStyle CInt deriving (Eq, Show, Ord)
data IndexRange = IndexRange AtIndex AtIndex deriving (Eq, Show, Ord)
statusToIndexRange :: (Ptr CInt -> Ptr CInt -> IO Int) -> IO (Maybe IndexRange)
statusToIndexRange f =
  alloca $ \start' ->
  alloca $ \end' ->
  f start' end' >>= \status' ->
  case status' of
    0 -> return Nothing
    _ -> do
      start'' <- peekIntConv start'
      end'' <- peekIntConv end'
      return (Just (IndexRange (AtIndex start'') (AtIndex end'')))

data ColorChooserRGB = Decimals (Between0And1, Between0And1, Between0And1) | Words RGB deriving (Eq, Show, Ord)
data Rectangle = Rectangle { rectanglePosition :: Position , rectangleSize :: Size } deriving (Eq, Show, Ord)
data ByXY = ByXY ByX ByY deriving (Eq, Show, Ord)
data Intersection = Contained | Partial deriving (Eq, Show, Ord)
data Size = Size Width Height deriving (Eq, Show, Ord)
data PreciseSize = PreciseSize PreciseWidth PreciseHeight deriving (Eq, Show, Ord)
newtype Lines = Lines Int deriving (Eq,Show,Ord)
newtype LineNumber = LineNumber Int deriving (Eq,Show,Ord)
newtype ColumnNumber = ColumnNumber Int deriving (Eq, Show, Ord)
newtype PixelPosition = PixelPosition Int deriving (Eq,Show,Ord)
newtype AtIndex = AtIndex Int deriving (Eq,Show,Ord)
newtype Rows = Rows Int deriving (Eq,Show,Ord)
newtype Columns = Columns Int deriving (Eq,Show,Ord)
data KeyType = SpecialKeyType SpecialKey | NormalKeyType Char deriving (Eq, Show, Ord)
data ShortcutKeySequence = ShortcutKeySequence [EventState] KeyType deriving (Eq, Show, Ord)
data Shortcut = KeySequence ShortcutKeySequence | KeyFormat T.Text deriving (Eq, Show, Ord)
data KeyBindingKeySequence = KeyBindingKeySequence (Maybe [EventState]) KeyType deriving (Eq, Show, Ord)
newtype Between0And1 = Between0And1 Double deriving (Eq, Show, Ord)
newtype Between0And6 = Between0And6 Double deriving (Eq, Show, Ord)
data ScreenLocation = Intersect Rectangle
                    | ScreenNumber Int
                    | ScreenPosition Position deriving (Eq, Show, Ord)
newtype FontSize = FontSize CInt deriving (Eq, Show, Ord)
newtype PixmapHs = PixmapHs [T.Text] deriving (Eq, Show, Ord)
data BitmapHs = BitmapHs B.ByteString Size deriving (Eq, Show, Ord)
data Clipboard = InternalClipboard | SharedClipboard deriving (Eq, Show, Ord)
data OutOfRangeOrNotSubmenu = OutOfRangeOrNotSubmenu deriving (Eq, Show, Ord)
-- | The type of 'Fl_Offscreen' varies wildly from platform to platform. Feel free to examine the insides when debugging
-- but any computation based on it will probably not be portable.
newtype FlOffscreen = FlOffscreen Fl_Offscreen
newtype FlBitmask = FlBitmask Fl_Bitmask
newtype FlRegion = FlRegion Fl_Region
newtype FlSocket = FlSocket Fl_Socket
#if GLSUPPORT
type Fl_GlContext = {#type GLContext #}
newtype FlGlContext = FlGlContext Fl_GlContext
#endif
successOrOutOfRangeOrNotSubmenu :: Int -> Either OutOfRangeOrNotSubmenu ()
successOrOutOfRangeOrNotSubmenu status = if (status == (-1)) then Left OutOfRangeOrNotSubmenu else Right ()
data AwakeRingFull = AwakeRingFull deriving (Eq, Show, Ord)
successOrAwakeRingFull :: Int -> Either AwakeRingFull ()
successOrAwakeRingFull status = if (status == (-1)) then Left AwakeRingFull else Right ()
data UnknownEvent = UnknownEvent deriving (Eq, Show, Ord)
successOrUnknownEvent :: Int -> Either UnknownEvent ()
successOrUnknownEvent status = if (status == 0) then Left UnknownEvent else Right ()
data UnknownError = UnknownError deriving (Eq, Show, Ord)
successOrUnknownError :: a -> Int -> Either UnknownError a
successOrUnknownError a result = if (result == 0) then (Left UnknownError) else (Right a)
data NotFound = NotFound deriving (Eq, Show, Ord)
data OutOfRange = OutOfRange deriving (Eq, Show, Ord)
successOrOutOfRange :: a -> Bool -> (a -> IO b) -> IO (Either OutOfRange b)
successOrOutOfRange a pred' tr = if pred' then return (Left OutOfRange) else tr a >>= return . Right
data NoChange = NoChange deriving (Eq, Show, Ord)
successOrNoChange :: Int -> Either NoChange ()
successOrNoChange status = if (status == 0) then Left NoChange else Right ()
data DataProcessingError = NoDataProcessedError | PartialDataProcessedError | UnknownDataError Int
successOrDataProcessingError :: Int -> Either DataProcessingError ()
successOrDataProcessingError status = case status of
  0 -> Right ()
  1 -> Left NoDataProcessedError
  2 -> Left PartialDataProcessedError
  x -> Left $ UnknownDataError x
newtype PreferredSize = PreferredSize Int deriving (Eq, Show, Ord)
newtype GapSize = GapSize Int deriving (Eq, Show, Ord)
data DrawShortcut = NormalDrawShortcut | ElideAmpersandDrawShortcut deriving (Eq,Show,Ord)
data ResolveImageLabelConflict = ResolveImageLabelOverwrite | ResolveImageLabelDoNothing deriving (Show)
data MultiLabelShrinkError = MultiLabelShrinkError deriving Show
toRectangle :: (Int,Int,Int,Int) -> Rectangle
toRectangle (x_pos, y_pos, width, height) =
    Rectangle (Position
               (X x_pos)
               (Y y_pos))
              (Size
               (Width width)
               (Height height))

fromRectangle ::  Rectangle -> (Int,Int,Int,Int)
fromRectangle (Rectangle (Position
                          (X x_pos)
                          (Y y_pos))
                         (Size
                          (Width width)
                          (Height height))) =
              (x_pos, y_pos, width, height)

toSize :: (Int, Int) -> Size
toSize (width', height') = Size (Width width') (Height height')

toPosition :: (Int,Int) -> Position
toPosition (xPos', yPos') = Position (X xPos') (Y yPos')

toPrecisePosition :: Position -> PrecisePosition
toPrecisePosition (Position (X xPos') (Y yPos')) =
  PrecisePosition
    (PreciseX (fromIntegral xPos'))
    (PreciseY (fromIntegral yPos'))

toPreciseSize :: Size -> PreciseSize
toPreciseSize (Size (Width w) (Height h)) =
  PreciseSize
    (PreciseWidth (fromIntegral w))
    (PreciseHeight (fromIntegral h))

throwStackOnError :: IO a -> IO a
throwStackOnError f =
  f `catch` throwStack
  where
  throwStack :: SomeException -> IO b
  throwStack e = traceStack (show e) $ error ""

withForeignPtrs :: [ForeignPtr a] -> ([Ptr a] -> IO c) -> IO c
withForeignPtrs fptrs io = do
  let ptrs = map Unsafe.unsafeForeignPtrToPtr fptrs
  r <- io ptrs
  mapM_ touchForeignPtr fptrs
  return r

#ifdef CALLSTACK_AVAILABLE
toRefPtr :: (?loc :: CallStack) => Ptr (Ptr a) -> IO (Ptr a)
#elif defined(HASCALLSTACK_AVAILABLE)
toRefPtr :: HasCallStack => Ptr (Ptr a) -> IO (Ptr a)
#else
toRefPtr :: Ptr (Ptr a) -> IO (Ptr a)
#endif
toRefPtr ptrToRefPtr = do
  refPtr <- peek ptrToRefPtr
  if (refPtr == nullPtr)
#ifdef CALLSTACK_AVAILABLE
   then error $ "Ref does not exist. " ++ (showCallStack ?loc)
#elif defined(HASCALLSTACK_AVAILABLE)
   then error $ "Ref does not exist. " ++ (prettyCallStack callStack)
#else
   then error "Ref does not exist. "
#endif
   else return refPtr

#ifdef CALLSTACK_AVAILABLE
withRef :: (?loc :: CallStack) => Ref a -> (Ptr b -> IO c) -> IO c
#elif defined(HASCALLSTACK_AVAILABLE)
withRef :: HasCallStack => Ref a -> (Ptr b -> IO c) -> IO c
#else
withRef :: Ref a -> (Ptr b -> IO c) -> IO c
#endif
withRef (Ref fptr) f =
   throwStackOnError $
     withForeignPtr fptr
       (\ptrToRefPtr -> do
           refPtr <- toRefPtr ptrToRefPtr
           f (castPtr refPtr)
       )

isNull :: Ref a -> IO Bool
isNull (Ref fptr) =
  withForeignPtr fptr
   (\ptrToRefPtr -> do
        refPtr <- peek ptrToRefPtr
        return (refPtr == nullPtr)
   )

#ifdef CALLSTACK_AVAILABLE
unsafeRefToPtr :: (?loc :: CallStack) => Ref a -> IO (Ptr ())
#elif defined(HASCALLSTACK_AVAILABLE)
unsafeRefToPtr :: HasCallStack => Ref a -> IO (Ptr ())
#else
unsafeRefToPtr :: Ref a -> IO (Ptr ())
#endif
unsafeRefToPtr (Ref fptr) =
    throwStackOnError $ do
      refPtr <- toRefPtr $ Unsafe.unsafeForeignPtrToPtr fptr
      return $ castPtr refPtr

#ifdef CALLSTACK_AVAILABLE
withRefs :: (?loc :: CallStack) => [Ref a] -> (Ptr (Ptr b) -> IO c) -> IO c
#elif HASCALLSTACK_AVAILABLE
withRefs :: HasCallStack => [Ref a] -> (Ptr (Ptr b) -> IO c) -> IO c
#else
withRefs :: [Ref a] -> (Ptr (Ptr b) -> IO c) -> IO c
#endif
withRefs refs f =
  throwStackOnError
  $ withForeignPtrs
        (map (\(Ref fptr) -> fptr) refs)
        (\ptrToRefPtrs -> do
           refPtrs <- mapM toRefPtr ptrToRefPtrs
           arrayPtr <- newArray refPtrs
           f (castPtr arrayPtr)
        )

withMaybeRef :: Maybe (Ref a) -> (Ptr () -> IO c) -> IO c
withMaybeRef (Just o) f = withRef o f
withMaybeRef Nothing f = f (castPtr nullPtr)

swapRef :: Ref a -> (Ptr b -> IO (Ptr ())) -> IO ()
swapRef ref@(Ref fptr) f = do
   result <- withRef ref f
   withForeignPtr fptr $ \p -> poke p result

wrapInRef :: ForeignPtr (Ptr ()) -> Ref a
wrapInRef = Ref . castForeignPtr

toFunRef :: FunPtr a -> FunRef
toFunRef fptr = FunRef $ castFunPtr fptr

fromFunRef :: FunRef -> (FunPtr ())
fromFunRef (FunRef f) = castFunPtr f

refPtrEquals :: Ref a -> Ref b -> IO Bool
refPtrEquals w1 w2 = do
  w1Null <- isNull w1
  w2Null <- isNull w2
  if (w1Null || w2Null) then return False
    else withRef w1 (\w1Ptr -> withRef w2 (\w2Ptr -> return (w1Ptr == w2Ptr)))

unpackFunctionPointerToFreeStruct :: Ptr () -> IO (CInt, Ptr (FunPtr (IO ())))
unpackFunctionPointerToFreeStruct fpts = do
  numFps <- {#get Function_Pointers_To_Free->length #} fpts
  fpArray <- {#get Function_Pointers_To_Free->function_pointer_array #} fpts
  return (numFps, fpArray)

{-# LANGUAGE CPP, EmptyDataDecls, ExistentialQuantification #-}

#ifdef CALLSTACK_AVAILABLE
{-# LANGUAGE ImplicitParams #-}
#endif

module Graphics.UI.FLTK.LowLevel.Fl_Types where
#include "Fl_Types.h"
#include "Fl_Text_EditorC.h"
#include "FL/platform_types.h"
import Foreign
import Foreign.C hiding (CClock)
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import qualified Foreign.ForeignPtr.Unsafe as Unsafe
import Debug.Trace
import Control.Exception
import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)
import qualified Data.Text as T
#if defined(CALLSTACK_AVAILABLE) || defined(HASCALLSTACK_AVAILABLE)
import GHC.Stack
#endif
import qualified Data.ByteString as B
#c
  enum SliderType {
    VertSliderType = FL_VERT_SLIDER,
    HorSliderType = FL_HOR_SLIDER,
    VertFillSliderType = FL_VERT_FILL_SLIDER,
    HorFillSliderType = FL_HOR_FILL_SLIDER,
    VertNiceSliderType = FL_VERT_NICE_SLIDER,
    HorNiceSliderType = FL_HOR_NICE_SLIDER
  };
  enum ScrollbarType {
    VertScrollbar = FL_VERT_SLIDER,
    HorScrollbar = FL_HOR_SLIDER
  };
  enum BrowserType {
    NormalBrowserType = FL_NORMAL_BROWSER,
    SelectBrowserType = FL_SELECT_BROWSER,
    HoldBrowserType = FL_HOLD_BROWSER,
    MultiBrowserType = FL_MULTI_BROWSER
  };
  enum SortType {
    SortAscending = FL_SORT_ASCENDING,
    SortDescending = FL_SORT_DESCENDING
  };
  enum FileBrowserType {
    FileBrowserFiles = FL_FILE_BROWSER_FILES,
    FileBrowserDirectories = FL_FILE_BROWSER_DIRECTORIES,
  };
  enum FileIconType {
 FileIconAny = FL_FILE_ICON_ANY,
 FileIconPlain = FL_FILE_ICON_PLAIN,
 FileIconFifo = FL_FILE_ICON_FIFO,
 FileIconDevice = FL_FILE_ICON_DEVICE,
 FileIconLink = FL_FILE_ICON_LINK,
 FileIconDirectory = FL_FILE_ICON_DIRECTORY
  };
  enum FileIconProps {
 FileIconEnd = FL_FILE_ICON_END,
 FileIconColor = FL_FILE_ICON_COLOR,
 FileIconLine = FL_FILE_ICON_LINE,
 FileIconClosedline = FL_FILE_ICON_CLOSEDLINE,
 FileIconPolygon = FL_FILE_ICON_POLYGON,
 FileIconOutlinepolygon = FL_FILE_ICON_OUTLINEPOLYGON,
 FileIconVertex = FL_FILE_ICON_VERTEX
  };
  enum FileChooserType {
 FileChooserSingle = FL_FILE_CHOOSER_SINGLE,
 FileChooserMulti = FL_FILE_CHOOSER_MULTI,
 FileChooserCreate = FL_FILE_CHOOSER_CREATE,
 FileChooserDirectory = FL_FILE_CHOOSER_DIRECTORY
  };
  enum ButtonType{
   NormalButtonType = FL_NORMAL_BUTTON,
   ToggleButtonType = FL_TOGGLE_BUTTON,
   RadioButtonType = FL_RADIO_BUTTON,
   HiddenButtonType = FL_HIDDEN_BUTTON
  };
  enum TreeReasonType {
    TreeReasonNone = FL_TREE_REASON_NONE,
    TreeReasonSelected = FL_TREE_REASON_SELECTED,
    TreeReasonDeselected = FL_TREE_REASON_DESELECTED,
    TreeReasonReselected = FL_TREE_REASON_RESELECTED,
    TreeReasonOpened = FL_TREE_REASON_OPENED,
    TreeReasonClosed = FL_TREE_REASON_CLOSED,
    TreeReasonDragged = FL_TREE_REASON_DRAGGED
  };
  enum MenuItemFlag{
     MenuItemNormal = 0,
     MenuItemInactive = FL_MENU_INACTIVE,
     MenuItemToggle = FL_MENU_TOGGLE,
     MenuItemValue = FL_MENU_VALUE,
     MenuItemRadio = FL_MENU_RADIO,
     MenuItemInvisible = FL_MENU_INVISIBLE,
     SubmenuPointer = FL_SUBMENU_POINTER,
     Submenu = FL_SUBMENU,
     MenuItemDivider = FL_MENU_DIVIDER,
     MenuItemHorizontal = FL_MENU_HORIZONTAL
  };
  enum ScrollbarMode {
    HorizontalScrollBar = HORIZONTAL,
    VerticalScrollBar = VERTICAL,
    BothScrollBar = BOTH,
    AlwaysOnScrollBar = ALWAYS_ON,
    HorizontalAlwaysScrollBar = HORIZONTAL_ALWAYS,
    VerticalAlwaysScrollBar = VERTICAL_ALWAYS,
    BothAlwaysScrollBar = BOTH_ALWAYS
  };
  enum CursorType {
    NormalCursor = NORMAL_CURSOR,
    CaretCursor = CARET_CURSOR,
    DimCursor = DIM_CURSOR,
    BlockCursor = BLOCK_CURSOR,
    HeavyCursor = HEAVY_CURSOR,
    SimpleCursor = SIMPLE_CURSOR
  };
  enum PositionType {
    CursorPos = CURSOR_POS,
    CharacterPos = CHARACTER_POS
  };
  enum DragType {
    DragNone = DRAG_NONE,
    DragStartDnd = DRAG_START_DND,
    DragChar = DRAG_CHAR,
    DragWord = DRAG_WORD,
    DragLine = DRAG_LINE
  };
  enum WrapTypeFl {
    WrapNoneFl = WRAP_NONE,
    WrapAtColumnFl = WRAP_AT_COLUMN,
    WrapAtPixelFl = WRAP_AT_PIXEL,
    WrapAtBoundsFl = WRAP_AT_BOUNDS
  };
  enum PageFormat {
    A0 = 0,
    A1 = 1,
    A2 = 2,
    A3 = 3,
    A4 = 4,
    A5 = 5,
    A6 = 6,
    A7 = 7,
    A8 = 8,
    A9 = 9,
    B0 = 10,
    B1 = 11,
    B2 = 12,
    B3 = 13,
    B4 = 14,
    B5 = 15,
    B6 = 16,
    B7 = 17,
    B8 = 18,
    B9 = 19,
    B10 = 20,
    C5E = 21,
    DLE = 22,
    Executive = EXECUTIVE,
    Folio = FOLIO,
    Ledger = LEDGER,
    Legal = LEGAL,
    Letter = LETTER,
    Tabloid = TABLOID,
    Envelope = ENVELOPE,
    Media = MEDIA
  };
  enum PageLayout {
    Portrait = PORTRAIT,
    Landscape = LANDSCAPE,
    Reversed = REVERSED,
    Orientation = ORIENTATION
  };
  typedef struct KeyBinding {
    int key;
    int state;
    fl_Key_Func* function;
  } KeyBinding;
  enum TableRowSelectMode {
     SelectNone = SELECT_NONEC,
     SelectSingle = SELECT_SINGLEC,
     SelectMulti = SELECT_MULTIC
  };
  enum TableContext {
     ContextNone = CONTEXT_NONEC,
     ContextStartPage = CONTEXT_STARTPAGEC,
     ContextEndPage = CONTEXT_ENDPAGEC,
     ContextRowHeader = CONTEXT_ROW_HEADERC,
     ContextColHeader = CONTEXT_COL_HEADERC,
     ContextCell = CONTEXT_CELLC,
     ContextTable = CONTEXT_TABLEC,
     ContextRCResize = CONTEXT_RC_RESIZEC
  };
  enum LinePosition {
    LinePositionTop = TOP,
    LinePositionMiddle = MIDDLE,
    LinePositionBottom = BOTTOM
  };
  enum PackType {
    PackVertical = PACK_VERTICAL,
    PackHorizontal = PACK_HORIZONTAL
  };
  enum ColorChooserMode {
    RgbMode = 0,
    ByteMode = 1,
    HexMode = 2,
    HsvMode = 3
  };
#endc
{#enum SliderType {} deriving (Show, Eq, Ord) #}
{#enum ScrollbarType {} deriving (Show, Eq, Ord) #}
{#enum BrowserType {} deriving (Show, Eq, Ord) #}
{#enum SortType {} deriving (Show, Eq, Ord) #}
{#enum FileBrowserType {} deriving (Show, Eq, Ord) #}
{#enum FileIconType {} deriving (Show, Eq, Ord) #}
{#enum FileIconProps {} deriving (Show, Eq, Ord) #}
{#enum FileChooserType {} deriving (Show, Eq, Ord) #}
{#enum ButtonType {} deriving (Show, Eq, Ord) #}
{#enum TreeReasonType {} deriving (Show, Eq, Ord) #}
{#enum MenuItemFlag {} deriving (Show, Eq, Ord) #}
{#enum ColorChooserMode {} deriving (Show, Eq, Ord) #}
newtype MenuItemFlags = MenuItemFlags [MenuItemFlag] deriving (Eq, Show, Ord)
allMenuItemFlags :: [MenuItemFlag]
allMenuItemFlags =
  [
     MenuItemInactive,
     MenuItemToggle,
     MenuItemValue,
     MenuItemRadio,
     MenuItemInvisible,
     SubmenuPointer,
     Submenu,
     MenuItemDivider,
     MenuItemHorizontal
  ]
{#enum CursorType {} deriving (Show, Eq, Ord) #}
{#enum PositionType {} deriving (Show, Eq, Ord) #}
{#enum DragType {} deriving (Show, Eq, Ord) #}
{#enum WrapTypeFl {} deriving (Show, Eq, Ord) #}
data WrapType = WrapNone | WrapAtColumn ColumnNumber | WrapAtPixel PixelPosition | WrapAtBounds deriving (Eq, Show, Ord)
{#enum PageFormat {} deriving (Show, Eq, Ord) #}
{#enum PageLayout {} deriving (Show, Eq, Ord) #}
{#enum TableRowSelectMode {} deriving (Show, Eq, Ord)  #}
{#enum TableContext {} deriving (Show, Eq, Ord) #}
{#enum LinePosition {} deriving (Show, Eq, Ord)  #}
{#enum ScrollbarMode {} deriving (Show, Eq, Ord) #}
data StyleTableEntry = StyleTableEntry (Maybe Color) (Maybe Font) (Maybe FontSize) deriving (Eq, Show, Ord)
{#enum PackType{} deriving (Show, Eq, Ord) #}
type FlShortcut      = {#type Fl_Shortcut #}
type FlColor         = {#type Fl_Color #}
type FlFont          = {#type Fl_Font #}
type FlAlign         = {#type Fl_Align #}
type LineDelta       = Maybe Int
type Delta           = Maybe Int
type FlIntPtr        = {#type fl_intptr_t #}
type FlUIntPtr       = {#type fl_uintptr_t#}
type ID              = {#type ID#}
type Fl_Offscreen = {#type Fl_Offscreen #}
type Fl_Socket = {#type FL_SOCKET #}
type Fl_Bitmask = {#type Fl_Bitmask #}
type Fl_Region = {#type Fl_Region #}
newtype WindowHandle = WindowHandle (Ptr ())

newtype NumInserted = NumInserted Int deriving (Show, Eq, Ord)
newtype NumDeleted = NumDeleted Int deriving (Show, Eq, Ord)
newtype NumRestyled = NumRestyled Int deriving (Show, Eq, Ord)
newtype DeletedText = DeletedText T.Text deriving (Show, Eq, Ord)

data Ref a           = Ref !(ForeignPtr (Ptr ())) deriving (Eq, Show, Ord)
data FunRef          = FunRef !(FunPtr ())
-- * The FLTK widget hierarchy
data CBase parent
type Base = CBase ()

type GlobalCallback              = IO ()
type CallbackWithUserDataPrim    = Ptr () -> Ptr () -> IO ()
type CallbackPrim                = Ptr () -> IO ()
type CustomColorAveragePrim    = Ptr () -> CUInt -> CFloat -> IO ()
type CustomImageDrawPrim       = Ptr () -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO ()
type CustomImageCopyPrim       = Ptr () -> CInt -> CInt -> IO (Ptr ())
type GlobalEventHandlerPrim      = CInt -> IO CInt
type GlobalEventHandlerF         = Event -> IO Int
type DrawCallback                = T.Text -> Position -> IO ()
type DrawCallbackPrim            = CString -> CInt -> CInt -> CInt -> IO ()
type TextBufferCallback          = FunPtr (Ptr () -> IO ())
type FileChooserCallback         = FunPtr (Ptr () -> Ptr () -> IO())
type SharedImageHandler          = FunPtr (CString -> CUChar -> CInt -> Ptr ())
type BoxDrawF                    = Rectangle -> Color -> IO ()
type BoxDrawFPrim                = CInt -> CInt -> CInt -> CInt -> FlColor -> IO ()
type FDHandlerPrim               = Fl_Socket -> Ptr () -> IO ()
type FDHandler                   = FlSocket -> IO ()
type TextModifyCb                = AtIndex -> NumInserted -> NumDeleted -> NumRestyled -> DeletedText -> IO ()
type TextModifyCbPrim            = CInt -> CInt -> CInt -> CInt -> Ptr CChar -> Ptr () -> IO ()
type TextPredeleteCb             = AtIndex -> NumDeleted -> IO ()
type TextPredeleteCbPrim         = CInt -> CInt -> Ptr () -> IO ()
type UnfinishedStyleCb           = AtIndex -> IO ()
type UnfinishedStyleCbPrim       = CInt -> Ptr () -> IO ()
type MenuItemDrawF               = Ptr () -> CInt -> CInt -> CInt -> CInt -> Ptr () -> CInt -> IO ()
type TabPositionsPrim            = Ptr () -> Ptr CInt -> Ptr CInt -> IO CInt
type TabHeightPrim               = Ptr () -> IO CInt
type TabWhichPrim                = Ptr () -> CInt -> CInt -> IO (Ptr ())
type TabClientAreaPrim           = Ptr () -> Ptr CInt -> Ptr CInt ->  Ptr CInt -> Ptr CInt -> CInt -> IO ()
type GetDoublePrim               = Ptr () -> IO (CDouble)
type GetIntPrim                  = Ptr () -> IO CInt
type SetIntPrim                  = Ptr () -> CInt -> IO ()
type ColorSetPrim                = Ptr () -> CDouble -> CDouble -> CDouble -> IO CInt
type DestroyCallbacksPrim        = Ptr () -> Ptr () -> IO ()

newtype Width = Width Int deriving (Eq, Show, Ord)
newtype Height = Height Int deriving (Eq, Show, Ord)
newtype PreciseWidth = PreciseWidth Double deriving (Eq, Show, Ord)
newtype PreciseHeight = PreciseHeight Double deriving (Eq, Show, Ord)
newtype Depth = Depth Int deriving (Eq, Show, Ord)
newtype LineSize = LineSize Int deriving (Eq, Show, Ord)
newtype X = X Int deriving (Eq, Show, Ord)
newtype PreciseX = PreciseX Double deriving (Eq, Show, Ord)
newtype Y = Y Int deriving (Eq, Show, Ord)
newtype PreciseY = PreciseY Double deriving (Eq, Show, Ord)
newtype ByX = ByX Double deriving (Eq, Show, Ord)
newtype ByY = ByY Double deriving (Eq, Show, Ord)
newtype Angle = Angle CShort deriving (Eq, Show, Ord)
newtype PreciseAngle = PreciseAngle Double deriving (Eq, Show, Ord)
data Position = Position X Y deriving (Eq, Show, Ord)
data PrecisePosition = PrecisePosition PreciseX PreciseY deriving (Eq, Show, Ord)
data CountDirection = CountUp | CountDown deriving (Eq, Show, Ord)
data DPI = DPI Float Float deriving (Eq, Show, Ord)
newtype TextDisplayStyle = TextDisplayStyle CInt deriving (Eq, Show, Ord)
data IndexRange = IndexRange AtIndex AtIndex deriving (Eq, Show, Ord)
statusToIndexRange :: (Ptr CInt -> Ptr CInt -> IO Int) -> IO (Maybe IndexRange)
statusToIndexRange f =
  alloca $ \start' ->
  alloca $ \end' ->
  f start' end' >>= \status' ->
  case status' of
    0 -> return Nothing
    _ -> do
      start'' <- peekIntConv start'
      end'' <- peekIntConv end'
      return (Just (IndexRange (AtIndex start'') (AtIndex end'')))

data ColorChooserRGB = Decimals (Between0And1, Between0And1, Between0And1) | Words RGB deriving (Eq, Show, Ord)
data Rectangle = Rectangle { rectanglePosition :: Position , rectangleSize :: Size } deriving (Eq, Show, Ord)
data ByXY = ByXY ByX ByY deriving (Eq, Show, Ord)
data Intersection = Contained | Partial deriving (Eq, Show, Ord)
data Size = Size Width Height deriving (Eq, Show, Ord)
data PreciseSize = PreciseSize PreciseWidth PreciseHeight deriving (Eq, Show, Ord)
newtype Lines = Lines Int deriving (Eq,Show,Ord)
newtype LineNumber = LineNumber Int deriving (Eq,Show,Ord)
newtype ColumnNumber = ColumnNumber Int deriving (Eq, Show, Ord)
newtype PixelPosition = PixelPosition Int deriving (Eq,Show,Ord)
newtype AtIndex = AtIndex Int deriving (Eq,Show,Ord)
newtype Rows = Rows Int deriving (Eq,Show,Ord)
newtype Columns = Columns Int deriving (Eq,Show,Ord)
data KeyType = SpecialKeyType SpecialKey | NormalKeyType Char deriving (Eq, Show, Ord)
data ShortcutKeySequence = ShortcutKeySequence [EventState] KeyType deriving (Eq, Show, Ord)
data Shortcut = KeySequence ShortcutKeySequence | KeyFormat T.Text deriving (Eq, Show, Ord)
data KeyBindingKeySequence = KeyBindingKeySequence (Maybe [EventState]) KeyType deriving (Eq, Show, Ord)
newtype Between0And1 = Between0And1 Double deriving (Eq, Show, Ord)
newtype Between0And6 = Between0And6 Double deriving (Eq, Show, Ord)
data ScreenLocation = Intersect Rectangle
                    | ScreenNumber Int
                    | ScreenPosition Position deriving (Eq, Show, Ord)
newtype FontSize = FontSize CInt deriving (Eq, Show, Ord)
newtype PixmapHs = PixmapHs [T.Text] deriving (Eq, Show, Ord)
data BitmapHs = BitmapHs B.ByteString Size deriving (Eq, Show, Ord)
data Clipboard = InternalClipboard | SharedClipboard deriving (Eq, Show, Ord)
data OutOfRangeOrNotSubmenu = OutOfRangeOrNotSubmenu deriving (Eq, Show, Ord)
-- | The type of 'Fl_Offscreen' varies wildly from platform to platform. Feel free to examine the insides when debugging
-- but any computation based on it will probably not be portable.
newtype FlOffscreen = FlOffscreen Fl_Offscreen
newtype FlBitmask = FlBitmask Fl_Bitmask
newtype FlRegion = FlRegion Fl_Region
newtype FlSocket = FlSocket Fl_Socket
#if GLSUPPORT
type Fl_GlContext = {#type GLContext #}
newtype FlGlContext = FlGlContext Fl_GlContext
#endif
successOrOutOfRangeOrNotSubmenu :: Int -> Either OutOfRangeOrNotSubmenu ()
successOrOutOfRangeOrNotSubmenu status = if (status == (-1)) then Left OutOfRangeOrNotSubmenu else Right ()
data AwakeRingFull = AwakeRingFull deriving (Eq, Show, Ord)
successOrAwakeRingFull :: Int -> Either AwakeRingFull ()
successOrAwakeRingFull status = if (status == (-1)) then Left AwakeRingFull else Right ()
data UnknownEvent = UnknownEvent deriving (Eq, Show, Ord)
successOrUnknownEvent :: Int -> Either UnknownEvent ()
successOrUnknownEvent status = if (status == 0) then Left UnknownEvent else Right ()
data UnknownError = UnknownError deriving (Eq, Show, Ord)
successOrUnknownError :: a -> Int -> Either UnknownError a
successOrUnknownError a result = if (result == 0) then (Left UnknownError) else (Right a)
data NotFound = NotFound deriving (Eq, Show, Ord)
data OutOfRange = OutOfRange deriving (Eq, Show, Ord)
successOrOutOfRange :: a -> Bool -> (a -> IO b) -> IO (Either OutOfRange b)
successOrOutOfRange a pred' tr = if pred' then return (Left OutOfRange) else tr a >>= return . Right
data NoChange = NoChange deriving (Eq, Show, Ord)
successOrNoChange :: Int -> Either NoChange ()
successOrNoChange status = if (status == 0) then Left NoChange else Right ()
data DataProcessingError = NoDataProcessedError | PartialDataProcessedError | UnknownDataError Int
successOrDataProcessingError :: Int -> Either DataProcessingError ()
successOrDataProcessingError status = case status of
  0 -> Right ()
  1 -> Left NoDataProcessedError
  2 -> Left PartialDataProcessedError
  x -> Left $ UnknownDataError x
newtype PreferredSize = PreferredSize Int deriving (Eq, Show, Ord)
newtype GapSize = GapSize Int deriving (Eq, Show, Ord)
data DrawShortcut = NormalDrawShortcut | ElideAmpersandDrawShortcut deriving (Eq,Show,Ord)
data ResolveImageLabelConflict = ResolveImageLabelOverwrite | ResolveImageLabelDoNothing deriving (Show)
data MultiLabelShrinkError = MultiLabelShrinkError deriving Show
toRectangle :: (Int,Int,Int,Int) -> Rectangle
toRectangle (x_pos, y_pos, width, height) =
    Rectangle (Position
               (X x_pos)
               (Y y_pos))
              (Size
               (Width width)
               (Height height))

fromRectangle ::  Rectangle -> (Int,Int,Int,Int)
fromRectangle (Rectangle (Position
                          (X x_pos)
                          (Y y_pos))
                         (Size
                          (Width width)
                          (Height height))) =
              (x_pos, y_pos, width, height)

toSize :: (Int, Int) -> Size
toSize (width', height') = Size (Width width') (Height height')

toPosition :: (Int,Int) -> Position
toPosition (xPos', yPos') = Position (X xPos') (Y yPos')

toPrecisePosition :: Position -> PrecisePosition
toPrecisePosition (Position (X xPos') (Y yPos')) =
  PrecisePosition
    (PreciseX (fromIntegral xPos'))
    (PreciseY (fromIntegral yPos'))

toPreciseSize :: Size -> PreciseSize
toPreciseSize (Size (Width w) (Height h)) =
  PreciseSize
    (PreciseWidth (fromIntegral w))
    (PreciseHeight (fromIntegral h))

throwStackOnError :: IO a -> IO a
throwStackOnError f =
  f `catch` throwStack
  where
  throwStack :: SomeException -> IO b
  throwStack e = traceStack (show e) $ error ""

withForeignPtrs :: [ForeignPtr a] -> ([Ptr a] -> IO c) -> IO c
withForeignPtrs fptrs io = do
  let ptrs = map Unsafe.unsafeForeignPtrToPtr fptrs
  r <- io ptrs
  mapM_ touchForeignPtr fptrs
  return r

#ifdef CALLSTACK_AVAILABLE
toRefPtr :: (?loc :: CallStack) => Ptr (Ptr a) -> IO (Ptr a)
#elif defined(HASCALLSTACK_AVAILABLE)
toRefPtr :: HasCallStack => Ptr (Ptr a) -> IO (Ptr a)
#else
toRefPtr :: Ptr (Ptr a) -> IO (Ptr a)
#endif
toRefPtr ptrToRefPtr = do
  refPtr <- peek ptrToRefPtr
  if (refPtr == nullPtr)
#ifdef CALLSTACK_AVAILABLE
   then error $ "Ref does not exist. " ++ (showCallStack ?loc)
#elif defined(HASCALLSTACK_AVAILABLE)
   then error $ "Ref does not exist. " ++ (prettyCallStack callStack)
#else
   then error "Ref does not exist. "
#endif
   else return refPtr

#ifdef CALLSTACK_AVAILABLE
withRef :: (?loc :: CallStack) => Ref a -> (Ptr b -> IO c) -> IO c
#elif defined(HASCALLSTACK_AVAILABLE)
withRef :: HasCallStack => Ref a -> (Ptr b -> IO c) -> IO c
#else
withRef :: Ref a -> (Ptr b -> IO c) -> IO c
#endif
withRef (Ref fptr) f =
   throwStackOnError $
     withForeignPtr fptr
       (\ptrToRefPtr -> do
           refPtr <- toRefPtr ptrToRefPtr
           f (castPtr refPtr)
       )

isNull :: Ref a -> IO Bool
isNull (Ref fptr) =
  withForeignPtr fptr
   (\ptrToRefPtr -> do
        refPtr <- peek ptrToRefPtr
        return (refPtr == nullPtr)
   )

#ifdef CALLSTACK_AVAILABLE
unsafeRefToPtr :: (?loc :: CallStack) => Ref a -> IO (Ptr ())
#elif defined(HASCALLSTACK_AVAILABLE)
unsafeRefToPtr :: HasCallStack => Ref a -> IO (Ptr ())
#else
unsafeRefToPtr :: Ref a -> IO (Ptr ())
#endif
unsafeRefToPtr (Ref fptr) =
    throwStackOnError $ do
      refPtr <- toRefPtr $ Unsafe.unsafeForeignPtrToPtr fptr
      return $ castPtr refPtr

#ifdef CALLSTACK_AVAILABLE
withRefs :: (?loc :: CallStack) => [Ref a] -> (Ptr (Ptr b) -> IO c) -> IO c
#elif HASCALLSTACK_AVAILABLE
withRefs :: HasCallStack => [Ref a] -> (Ptr (Ptr b) -> IO c) -> IO c
#else
withRefs :: [Ref a] -> (Ptr (Ptr b) -> IO c) -> IO c
#endif
withRefs refs f =
  throwStackOnError
  $ withForeignPtrs
        (map (\(Ref fptr) -> fptr) refs)
        (\ptrToRefPtrs -> do
           refPtrs <- mapM toRefPtr ptrToRefPtrs
           arrayPtr <- newArray refPtrs
           f (castPtr arrayPtr)
        )

withMaybeRef :: Maybe (Ref a) -> (Ptr () -> IO c) -> IO c
withMaybeRef (Just o) f = withRef o f
withMaybeRef Nothing f = f (castPtr nullPtr)

swapRef :: Ref a -> (Ptr b -> IO (Ptr ())) -> IO ()
swapRef ref@(Ref fptr) f = do
   result <- withRef ref f
   withForeignPtr fptr $ \p -> poke p result

wrapInRef :: ForeignPtr (Ptr ()) -> Ref a
wrapInRef = Ref . castForeignPtr

toFunRef :: FunPtr a -> FunRef
toFunRef fptr = FunRef $ castFunPtr fptr

fromFunRef :: FunRef -> (FunPtr ())
fromFunRef (FunRef f) = castFunPtr f

refPtrEquals :: Ref a -> Ref b -> IO Bool
refPtrEquals w1 w2 = do
  w1Null <- isNull w1
  w2Null <- isNull w2
  if (w1Null || w2Null) then return False
    else withRef w1 (\w1Ptr -> withRef w2 (\w2Ptr -> return (w1Ptr == w2Ptr)))

unpackFunctionPointerToFreeStruct :: Ptr () -> IO (CInt, Ptr (FunPtr (IO ())))
unpackFunctionPointerToFreeStruct fpts = do
  numFps <- {#get Function_Pointers_To_Free->length #} fpts
  fpArray <- {#get Function_Pointers_To_Free->function_pointer_array #} fpts
  return (numFps, fpArray)


More types added.

More types added.

{-# LANGUAGE ForeignFunctionInterface #-}

module Graphics.Formats.Assimp where

import C2HS
--import Foreign.Ptr
--import System.IO.Unsafe
import Control.Monad
import Control.Applicative ((<$>), (<*>))

#include "../../assimp/include/assimp.h"        // Plain-C interface
#include "../../assimp/include/aiScene.h"       // Output data structure
#include "../../assimp/include/aiPostProcess.h" // Post processing flags

{#context lib="assimp"#}

{#enum define SceneFlags {AI_SCENE_FLAGS_INCOMPLETE         as FlagsIncomplete
                        , AI_SCENE_FLAGS_VALIDATED          as FlagsValidated
                        , AI_SCENE_FLAGS_VALIDATION_WARNING as FlagsValidationWarning
                        , AI_SCENE_FLAGS_NON_VERBOSE_FORMAT as FlagsNonVerboseFormat
                        , AI_SCENE_FLAGS_TERRAIN            as FlagsTerrain
                        }#}

{#enum aiPostProcessSteps as AiPostProcessSteps {underscoreToCase} deriving (Show, Eq)#}
{#enum aiReturn as AiReturn                     {underscoreToCase} deriving (Show, Eq)#}
{#enum aiOrigin as AiOrigin                     {underscoreToCase} deriving (Show, Eq)#}
{#enum aiDefaultLogStream as AiDefaultLogStream {underscoreToCase} deriving (Show, Eq)#}
{#enum aiPrimitiveType as AiPrimitiveType       {underscoreToCase} deriving (Show, Eq)#}

-- This seems to be necessary for #sizeof to work
#c
typedef struct aiScene aiScene;
typedef struct aiString aiString;
typedef struct aiNode aiNode;
typedef struct aiFace aiFace;
typedef struct aiVertexWeight aiVertexWeight;
typedef struct aiBone aiBone;
typedef struct aiMesh aiMesh;
typedef struct aiMatrix4x4 aiMatrix4x4;
#endc

--{#pointer *aiNode         as AiNode         #}
--{#pointer *aiScene        as AiScene        #}
{#pointer *aiPlane        as AiPlane        #}
{#pointer *aiRay          as AiRay          #}
{#pointer *aiColor3D      as AiColor3D      #}
{#pointer *aiColor4D      as AiColor4D      #}
--{#pointer *aiString       as AiString       #}
{#pointer *aiMemoryInfo   as AiMemoryInfo   #}
{#pointer *aiLogStream    as AiLogStream    #}
{#pointer *aiQuaternion   as AiQuaternion   #}
{#pointer *aiMatrix3x3    as AiMatrix3x3    #}
{#pointer *aiMatrix4x4    as AiMatrix4x4    #}
{#pointer *aiVector3D     as AiVector3D     #}
--{#pointer *aiFace         as AiFace         #}
--{#pointer *aiVertexWeight as AiVertexWeight #}
--{#pointer *aiBone         as AiBone         #}
--{#pointer *aiMesh         as AiMesh         #}

data AiString = AiString
  { length'AiString :: Int
  , data'AiString   :: String -- Maximum length MAXLEN
  }
aiStringToString = data'AiString
stringToAiString x = AiString (length x) x
instance Storable AiString where
  sizeOf _ = {#sizeof aiString#}
  alignment _ = 4 -- http://web.archiveorange.com/archive/v/V6skIGuT4JclKSXDM7Xj
  peek p = liftM2 AiString
    (liftM cIntConv ({#get aiString.length#} p))
    ({#get aiString.data#} p >>= peekCString)
  poke p x = do
    {#set aiString.length#} p (cIntConv $ length'AiString x)
    str <- newCString $ data'AiString x
    {#set aiString.data#} p str

{- From the Assimp source:
 -
 - Nodes are little named entities in the scene that have a place and
 - orientation relative to their parents. Starting from the scene's root node
 - all nodes can have 0 to x child nodes, thus forming a hierarchy. They form
 - the base on which the scene is built on: a node can refer to 0..x meshes,
 - can be referred to by a bone of a mesh or can be animated by a key sequence
 - of an animation. DirectX calls them "frames", others call them "objects", we
 - call them aiNode.
 -
 - A node can potentially refer to single or multiple meshes. The meshes are
 - not stored inside the node, but instead in an array of aiMesh inside the
 - aiScene. A node only refers to them by their array index. This also means
 - that multiple nodes can refer to the same mesh, which provides a simple form
 - of instancing. A mesh referred to by this way lives in the node's local
 - coordinate system. If you want the mesh's orientation in global space, you'd
 - have to concatenate the transformations from the referring node and all of
 - its parents.
-}
data AiNode = AiNode
  { mName'AiNode           :: String
  , mTransformation'AiNode :: AiMatrix4x4
  , mParent'AiNode         :: AiNode
  --, mNumChildren'AiNode    :: CUInt
  , mChildren'AiNode       :: [AiNode]
  --, mNumMeshes'AiNode      :: CUInt
  , mMeshes                :: [CUInt]
  }
instance Storable AiNode where
  sizeOf _ = {#sizeof aiNode#}
  alignment _ = 4
  peek = undefined
  poke = undefined
  --peek p = do
  --  mName <- liftM aiStringToString $ {#get aiNode.mName#} p
  --  mTransformation <- {#get aiNode.mTransformation#} p
  --  mParent <- {#get aiNode.mParent#} p
  --  mNumChildren <- {#get aiNode.mNumChildren#} p
  --  mChildren <- peekArray mNumChildren ({#get aiNode.mChildren#} p) -- TODO
  --  mMeshes <- peekArray ({#get aiNode.mNumMeshes#} p) ({#get aiNode.mMeshes#})
  --  return $ AiNode mName mTransformation mParent mChildren mMeshes
  --poke p (AiNode name trans par chil mes) = do
  --  {#set aiNode.mName#} $ stringToAiString $ mName'AiNode p
  --  {#set aiNode.mTransformation#} $ mTransformation'AiNode p
  --  {#set aiNode.mParent#} $ mParent'AiNode p
  --  {#set aiNode.mChildren#} $ mChildren'AiNode p
  --  {#set aiNode.mMeshes#} $ mMeshes'AiNode p

data AiFace = AiFace
  { --mNumIndices :: CUInt
    mIndices'AiFace    :: [CUInt]
  }
instance Storable AiFace where
  sizeOf _ = {#sizeof aiFace#}
  alignment _ = 4
  peek p = do
    mNumIndices <- {#get aiFace.mNumIndices#}
    mIndices <- {#get aiFace.mIndices#}
    lst <- peekArray mNumIndices mIndices
    return $ AiFace lst
  poke p (AiFace mIndices) = do
    {#set aiFace.mNumIndices#} p $ cIntConv $ length mIndices
    newArray mIndices >>= ({#set aiFace.mIndices#} p)

data AiVertexWeight = AiVertexWeight
  { mVertexId'AiVertexWeight :: CUInt
  , mWeight'AiVertexWeight   :: CFloat
  }
instance Storable AiVertexWeight where
  sizeOf _ = {#sizeof aiVertexWeight#}
  alignment _ = 4
  peek p = do
    mV <- {#get aiVertexWeight.mVertexId#}
    mW <- {#get aiVertexWeight.mWeight#}
    return $ AiVertexWeight mV mW
  poke p (AiVertexWeight mV mW) = do
    {#set aiVertexWeight.mVertexId#} p mV
    {#set aiVertexWeight.mWeight#} p mW

data AiBone = AiBone
  { mName'AiBone         :: String
  --, mNumWeights   :: CUInt
  , mWeights'AiBone      :: [AiVertexWeight]
  , mOffsetMatrix'AiBone :: AiMatrix4x4
  }
instance Storable AiBone where
  sizeOf _ = {#sizeof aiBone#}
  alignment _ = 4
  peek = undefined
  poke = undefined
  --peek p = do
  --  mN <- liftM peek $ {#get aiBone.mName#} p
  --  mW <- {#get aiBone.mWeights#} p
  --  mO <- {#get aiBone.mOffsetMatrix#} p >>= peek
  --  return $ AiBone mN mW mO
  --poke p (AiBone mN mW mO) = do
  --  {#set aiBone.mName#} p mN
  --  {#set aiBone.mWeights#} p mW
  --  {#set aiBone.mOffsetMatrix#} p mO

data AiMesh = AiMesh
  { mPrimitiveTypes'AiMesh  :: AiPrimitiveType
  --, mNumVertices     :: CUInt
  , mVertices'AiMesh        :: [AiVector3D]
  , mNormals'AiMesh         :: [AiVector3D]
  , mTangents'AiMesh        :: [AiVector3D]
  , mBitangents'AiMesh      :: [AiVector3D]
  , mColors'AiMesh          :: [AiColor4D]
  , mTextureCoords'AiMesh   :: [AiVector3D]
  , mNumUVComponents'AiMesh :: CUInt
  --, mNumFaces        :: CUInt
  , mFaces'AiMesh           :: [AiFace]
  --, mNumBones        :: CUInt
  , mBones'AiMesh           :: [AiBone]
  , mMaterialIndex'AiMesh   :: CUInt
  , mName'AiMesh            :: String
  --, mNumAnimMeshes :: CUInt
  --, mAnimMeshes    :: [AiAnimMesh]
  }

{#pointer *aiMaterial  as AiMaterial#}
{#pointer *aiAnimation as AiAnimation#}
{#pointer *aiTexture   as AiTexture#}
{#pointer *aiLight     as AiLight#}
{#pointer *aiCamera    as AiCamera#}

data AiScene = AiScene
  { mFlags'AiScene         :: SceneFlags

  --, mNumMeshes     :: CUInt
  , mMeshes'AiScene        :: [AiMesh]

  --, mNumMaterials  :: CUInt
  , mMaterials'AiScene     :: [AiMaterial]

  --, mNumAnimations :: CUInt
  , mAnimations'AiScene    :: [AiAnimation]

  --, mNumTextures   :: CUInt
  , mTextures'AiScene      :: [AiTexture]

  --, mNumLights     :: CUInt
  , mLights'AiScene        :: [AiLight]

  --, mNumCameras    :: CUInt
  , mCameras'AiScene       :: [AiCamera]
  }
instance Storable AiScene where
  sizeOf _ = {#sizeof aiScene#}
  alignment _ = 4
  peek = undefined
  --peek p = do
  --  let mFlags =
  poke p x = undefined--do
    -- {#set aiString.length#} p (cIntConv $ length'AiString x)
    -- str <- newCString $ data'AiString x
    -- {#set aiString.data#} p str

{#fun aiImportFile as ^
  {`String', cFromEnum `SceneFlags'} -> `AiScene' peek#}

-- aiImportFileEx
-- aiImportFileFromMemory

{#fun aiApplyPostProcessing as ^
  {id `AiScene', cFromEnum `AiPostProcessSteps'} -> `AiScene' id#}

--{#fun aiGetPredefinedLogStream as ^
--  {cFromEnum `AiDefaultLogStream', `String'} -> `AiLogStream' id#}

-- aiAttachLogStream
-- aiEnableVerboseLogging
-- aiDetachLogStream
-- aiDetachAllLogStreams

{#fun aiReleaseImport as ^
  {id `AiScene'} -> `()'#}

{#fun aiGetErrorString as ^
  {} -> `String'#}

{#fun aiIsExtensionSupported as ^
  {`String'} -> `Bool'#}

-- aiGetExtensionList
-- aiGetMemoryRequirements

{# fun aiSetImportPropertyInteger as ^
  {`String', `Int'} -> `()'#}

{# fun aiSetImportPropertyFloat as ^
  {`String', `Float'} -> `()'#}

--{# fun aiSetImportPropertyString as ^
--  {`String', `AiString'} -> `()'#}

-- aiCreateQuaternionFromMatrix
-- aiDecomposeMatrix
-- aiTransposematrix4
-- aiTransposematrix3
-- aiTransformVecByMatrix3
-- aiTransformVecByMatrix4
-- aiMultiplyMatrix3
-- aiMultiplyMatrix4
-- aiIdentityMatrix3
-- aiIdentityMatrix4

{-# LANGUAGE ForeignFunctionInterface #-}

module Graphics.Formats.Assimp where

import C2HS
--import Foreign.Ptr
--import System.IO.Unsafe
--import Foreign.C

#include "../../assimp/include/assimp.h"        // Plain-C interface
#include "../../assimp/include/aiScene.h"       // Output data structure
#include "../../assimp/include/aiPostProcess.h" // Post processing flags

{#context lib="assimp"#}

{#enum define SceneFlags {AI_SCENE_FLAGS_INCOMPLETE         as FlagsIncomplete
                        , AI_SCENE_FLAGS_VALIDATED          as FlagsValidated
                        , AI_SCENE_FLAGS_VALIDATION_WARNING as FlagsValidationWarning
                        , AI_SCENE_FLAGS_NON_VERBOSE_FORMAT as FlagsNonVerboseFormat
                        , AI_SCENE_FLAGS_TERRAIN            as FlagsTerrain
                        }#}

{#enum aiPostProcessSteps as AiPostProcessSteps {underscoreToCase} deriving (Show, Eq)#}
{#enum aiReturn as AiReturn {underscoreToCase} deriving (Show, Eq)#}
{#enum aiOrigin as AiOrigin {underscoreToCase} deriving (Show, Eq)#}
{#enum aiDefaultLogStream as AiDefaultLogStream {underscoreToCase} deriving (Show, Eq)#}

{#pointer *aiNode  as AiNode #}
{#pointer *aiScene as AiScene#}
{#pointer *aiPlane as AiPlane#}
{#pointer *aiRay   as AiRay  #}
{#pointer *aiColor3D as AiColor3D#}
{#pointer *aiString as AiString#}
{#pointer *aiMemoryInfo as AiMemoryInfo#}
{#pointer *aiLogStream as AiLogStream#}
{#pointer *aiQuaternion as AiQuaternion#}
{#pointer *aiMatrix3x3 as AiMatrix3x3#}
{#pointer *aiMatrix4x4 as AiMatrix4x4#}
{#pointer *aiVector3D as AiVector3D#}

{#fun aiImportFile as ^
  {`String', cFromEnum `SceneFlags'} -> `AiScene' id#}

-- aiImportFileEx
-- aiImportFileFromMemory

{#fun aiApplyPostProcessing as ^
  {id `AiScene', cFromEnum `AiPostProcessSteps'} -> `AiScene' id#}

--{#fun aiGetPredefinedLogStream as ^
--  {cFromEnum `AiDefaultLogStream', `String'} -> `AiLogStream' id#}

-- aiAttachLogStream
-- aiEnableVerboseLogging
-- aiDetachLogStream
-- aiDetachAllLogStreams

{#fun aiReleaseImport as ^
  {id `AiScene'} -> `()'#}

{#fun aiGetErrorString as ^
  {} -> `String'#}

{#fun aiIsExtensionSupported as ^
  {`String'} -> `Bool'#}

-- aiGetExtensionList
-- aiGetMemoryRequirements

{# fun aiSetImportPropertyInteger as ^
  {`String', `Int'} -> `()'#}

{# fun aiSetImportPropertyFloat as ^
  {`String', `Float'} -> `()'#}

--{# fun aiSetImportPropertyString as ^
--  {`String', `AiString'} -> `()'#}

-- aiCreateQuaternionFromMatrix
-- aiDecomposeMatrix
-- aiTransposematrix4
-- aiTransposematrix3
-- aiTransformVecByMatrix3
-- aiTransformVecByMatrix4
-- aiMultiplyMatrix3
-- aiMultiplyMatrix4
-- aiIdentityMatrix3
-- aiIdentityMatrix4


gstreamer: M.S.G.Core.Format: document everything; remove formatsContains as it's pretty redundant

darcs-hash:20080824020113-21862-925211a4c90e91395cc9fad4f433ae6092a6624d.gz

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module Media.Streaming.GStreamer.Core.Format (

  -- * Types
  Format(..),
  FormatDefinition(..),
  FormatId,

  -- * Format Operations
  formatPercentMax,
  formatPercentScale,
  formatGetName,
  formatToQuark,
  formatRegister,
  formatGetByNick,
  formatGetDetails,
  formatIterateDefinitions

  ) where

{#import Media.Streaming.GStreamer.Core.Types#}

{# context lib = "gstreamer" prefix = "gst" #}

import Control.Monad (liftM)
import System.Glib.FFI
import System.Glib.UTFString
{#import System.Glib.GObject#}

-- | Get a printable name for the given format.
formatGetName :: Format    -- ^ @format@ - a format
              -> IO String -- ^ the name of the format
formatGetName format =
    peekUTFString $
        ({# call fun format_get_name #} $
             fromIntegral $ fromFormat format)

-- | Get the unique quark for the given format.
formatToQuark :: Format   -- ^ @format@ - a format
              -> IO Quark -- ^ the unique quark for the format
formatToQuark =
    {# call format_to_quark #} . fromIntegral . fromFormat

-- | Create a new format based on the given nickname, or register a new format with that nickname.
formatRegister :: String    -- ^ @nick@ - the nickname for the format
               -> String    -- ^ @description@ - the description for the format
               -> IO Format -- ^ the format with the given nickname
formatRegister nick description =
    liftM (toFormat . fromIntegral) $
        withUTFString nick $ \cNick ->
            (withUTFString description $
                 {# call format_register #} cNick)

-- | Get the format with the given nickname, or 'FormatUndefined' if
--   no format by that nickname was found.
formatGetByNick :: String    -- ^ @nick@ - the nickname for the format
                -> IO Format -- ^ the format with the given nickname,
                             --   or 'FormatUndefined' if it was not found
formatGetByNick nick =
    liftM (toFormat . fromIntegral) $
        withUTFString nick {# call format_get_by_nick #}

-- | Get the given format's definition.
formatGetDetails :: Format                      -- ^ @format@ - a format
                 -> IO (Maybe FormatDefinition) -- ^ the definition for the given format, or
                                                --   'Nothing' if the format was not found
formatGetDetails format =
    ({# call format_get_details #} $ fromIntegral $ fromFormat format) >>=
        maybePeek peek . castPtr

-- | Get an Iterator over all registered formats.
formatIterateDefinitions :: IO (Iterator FormatDefinition)
formatIterateDefinitions =
    {# call format_iterate_definitions #} >>= takeIterator

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module Media.Streaming.GStreamer.Core.Format (

  -- * Types
  Format(..),
  FormatDefinition(..),
  FormatId,

  -- * Format Operations
  formatPercentMax,
  formatPercentScale,
  formatGetName,
  formatToQuark,
  formatRegister,
  formatGetByNick,
  formatsContains,
  formatGetDetails,
  formatIterateDefinitions

  ) where

{#import Media.Streaming.GStreamer.Core.Types#}

{# context lib = "gstreamer" prefix = "gst" #}

import Control.Monad (liftM)
import System.Glib.FFI
import System.Glib.UTFString
{#import System.Glib.GObject#}

formatGetName :: Format
              -> IO String
formatGetName format =
    peekUTFString $
        ({# call fun format_get_name #} $
             fromIntegral $ fromFormat format)

formatToQuark :: Format
              -> IO Quark
formatToQuark =
    {# call format_to_quark #} . fromIntegral . fromFormat

formatRegister :: String
               -> String
               -> IO Format
formatRegister nick description =
    liftM (toFormat . fromIntegral) $
        withUTFString nick $ \cNick ->
            (withUTFString description $
                 {# call format_register #} cNick)

formatGetByNick :: String
                -> IO Format
formatGetByNick nick =
    liftM (toFormat . fromIntegral) $
        withUTFString nick {# call format_get_by_nick #}

formatsContains :: [Format]
                -> Format
                -> IO Bool
formatsContains formats format =
    liftM toBool $
        withArray0 0 (map cFromEnum formats) $ \cFormats ->
            {# call formats_contains #} cFormats $ cFromEnum format

formatGetDetails :: Format
                 -> IO FormatDefinition
formatGetDetails format =
    ({# call format_get_details #} $ fromIntegral $ fromFormat format) >>=
        maybePeek peek . castPtr

formatIterateDefinitions :: IO (Iterator FormatDefinition)
formatIterateDefinitions =
    {# call format_iterate_definitions #} >>= takeIterator


Don't export valueUnset since it's not used outside of the module

darcs-hash:20060204171730-b4c10-501a227ce76d651ee417850338be14ac39709d40.gz

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValue
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Version $Revision: 1.3 $ from $Date: 2005/11/16 13:14:16 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- This module implements only the necessities for the GTK binding.
--
-- * Everything here is only used by "Graphics.UI.Gtk.TreeList.TreeModel" and
-- friends.
--
module System.Glib.GValue (
  GValue(GValue),
  valueInit,
  valueGetType,
  allocaGValue
  ) where

import Monad	(liftM)

import System.Glib.FFI
import System.Glib.GType	(GType)

{# context lib="glib" prefix="g" #}

{# pointer *GValue newtype #}

-- | Clear a GValue.
--
valueInit :: GValue -> GType -> IO ()
valueInit gv gt = do
  -- The g_type field of the value must be zero or g_value_init will fail.
  {# call unsafe value_init #} gv gt
  return ()

-- | Get the type of the value stored in the GValue
--
valueGetType :: GValue -> IO GType
valueGetType (GValue gvPtr) = {# get GValue->g_type #} gvPtr

-- | Temporarily allocate a GValue.
--
allocaGValue :: (GValue -> IO b) -> IO b
allocaGValue body =
  -- c2hs is broken in that it can't handle arrays of compound arrays in the
  -- sizeof hook
  allocaBytes ({# sizeof GType #}+ 2* {# sizeof guint64 #}) $ \gvPtr -> do
  -- The g_type field of the value must be zero or g_value_init will fail.
  {# set GValue->g_type #} gvPtr (0 :: GType)
  result <- body (GValue gvPtr)
  {#call unsafe value_unset#} (GValue gvPtr)
  return result

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValue
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Version $Revision: 1.3 $ from $Date: 2005/11/16 13:14:16 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- This module implements only the necessities for the GTK binding.
--
-- * Everything here is only used by "Graphics.UI.Gtk.TreeList.TreeModel" and
-- friends.
--
module System.Glib.GValue (
  GValue(GValue),
  valueInit,
  valueUnset,
  valueGetType,
  allocaGValue
  ) where

import Monad	(liftM)

import System.Glib.FFI
import System.Glib.GType	(GType)

{# context lib="glib" prefix="g" #}

{# pointer *GValue newtype #}

-- | Clear a GValue.
--
valueInit :: GValue -> GType -> IO ()
valueInit gv gt = do
  -- The g_type field of the value must be zero or g_value_init will fail.
  {# call unsafe value_init #} gv gt
  return ()

-- | Free the data in a GValue.
--
valueUnset :: GValue -> IO ()
valueUnset = {#call unsafe value_unset#}

-- | Get the type of the value stored in the GValue
--
valueGetType :: GValue -> IO GType
valueGetType (GValue gvPtr) = {# get GValue->g_type #} gvPtr

-- | Temporarily allocate a GValue.
--
allocaGValue :: (GValue -> IO b) -> IO b
allocaGValue body =
  -- c2hs is broken in that it can't handle arrays of compound arrays in the
  -- sizeof hook
  allocaBytes ({# sizeof GType #}+ 2* {# sizeof guint64 #}) $ \gvPtr -> do
  -- The g_type field of the value must be zero or g_value_init will fail.
  {# set GValue->g_type #} gvPtr (0 :: GType)
  result <- body (GValue gvPtr)
  valueUnset (GValue gvPtr)
  return result


glib: make module name for GDateTime the same as the filename :)

-- -*-haskell-*-
--  GIMP Toolkit (GTK)
--
--  Author : Peter Gavin
--
--  Created: 19 March 2002
--
--  Copyright (C) 2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module System.Glib.GDateTime (
  GTimeValPart,
  GTimeVal(..),
  gGetCurrentTime,
  gUSleep,
  gTimeValAdd,
  gTimeValFromISO8601,
  gTimeValToISO8601,
  GDate(..),
  GDateDay,
  GDateMonth,
  GDateYear,
  GDateJulianDay,
  GDateWeekday,
  gDateValidJulian,
  gDateValidDMY,
  gDateNewJulian,
  gDateNewDMY,
  gDateSetDay,
  gDateSetMonth,
  gDateSetYear,
  gDateNewTimeVal,
  gDateParse,
  gDateAddDays,
  gDateSubtractDays,
  gDateAddMonths,
  gDateSubtractMonths,
  gDateAddYears,
  gDateSubtractYears,
  gDateDaysBetween,
  gDateCompare,
  gDateClamp,
  gDateDay,
  gDateMonth,
  gDateYear,
  gDateWeekday
  ) where

import Control.Monad (liftM)
import System.Glib.FFI
import System.Glib.UTFString

type GTimeValPart = {# type glong #}
data GTimeVal = GTimeVal { gTimeValSec  :: GTimeValPart
                         , gTimeValUSec :: GTimeValPart }
                deriving (Eq, Ord)
instance Storable GTimeVal where
    sizeOf _ = {# sizeof GTimeVal #}
    alignment _ = alignment (undefined :: CString)
    peek ptr =
        do sec <- {# get GTimeVal->tv_sec #} ptr
           uSec <- {# get GTimeVal->tv_usec #} ptr
           return $ GTimeVal sec uSec
    poke ptr (GTimeVal sec uSec) =
        do {# set GTimeVal->tv_sec #} ptr sec
           {# set GTimeVal->tv_usec #} ptr uSec

gGetCurrentTime :: IO GTimeVal
gGetCurrentTime =
    alloca $ \ptr ->
        do {# call g_get_current_time #} $ castPtr ptr
           peek ptr

gUSleep :: GTimeValPart
        -> IO ()
gUSleep microseconds =
    {# call g_usleep #} $ fromIntegral microseconds

gTimeValAdd :: GTimeVal
            -> GTimeValPart
            -> GTimeVal
gTimeValAdd time microseconds =
    unsafePerformIO $ with time $ \ptr ->
        do {# call g_time_val_add #} (castPtr ptr) microseconds
           peek ptr

gTimeValFromISO8601 :: String
                    -> Maybe GTimeVal
gTimeValFromISO8601 isoDate =
    unsafePerformIO $ withUTFString isoDate $ \cISODate ->
        alloca $ \ptr ->
            do success <- liftM toBool $ {# call g_time_val_from_iso8601 #} cISODate $ castPtr ptr
               if success
                   then liftM Just $ peek ptr
                   else return Nothing

gTimeValToISO8601 :: GTimeVal
                  -> String
gTimeValToISO8601 time =
    unsafePerformIO $ with time $ \ptr ->
        {# call g_time_val_to_iso8601 #} (castPtr ptr) >>= readUTFString

newtype GDateDay = GDateDay {# type GDateDay #}
    deriving (Eq, Ord)
instance Bounded GDateDay where
    minBound = GDateDay 1
    maxBound = GDateDay 31

{# enum GDateMonth {underscoreToCase} deriving (Eq, Ord) #}
instance Bounded GDateMonth where
    minBound = GDateJanuary
    maxBound = GDateDecember

newtype GDateYear = GDateYear {# type GDateYear #}
    deriving (Eq, Ord)
instance Bounded GDateYear where
    minBound = GDateYear 1
    maxBound = GDateYear (maxBound :: {# type guint16 #})

type GDateJulianDay = {# type guint32 #}
newtype GDate = GDate { gDateJulianDay :: GDateJulianDay }
    deriving (Eq)
instance Storable GDate where
    sizeOf _ = {# sizeof GDate #}
    alignment _ = alignment (undefined :: CString)
    peek =
        (liftM (GDate . fromIntegral)) . {# call g_date_get_julian #} . castPtr
    poke ptr val =
        {# call g_date_set_julian #} (castPtr ptr) $ gDateJulianDay val

{# enum GDateWeekday {underscoreToCase} deriving (Eq, Ord) #}
instance Bounded GDateWeekday where
    minBound = GDateMonday
    maxBound = GDateSunday

gDateValidJulian :: GDateJulianDay
                 -> Bool
gDateValidJulian =
    toBool . {# call fun g_date_valid_julian #}

gDateValidDMY :: GDateDay
              -> GDateMonth
              -> GDateYear
              -> Bool
gDateValidDMY (GDateDay day) month (GDateYear year) =
    toBool $ {# call fun g_date_valid_dmy #} day
                                             (fromIntegral $ fromEnum month)
                                             year

gDateNewJulian :: GDateJulianDay
               -> Maybe GDate
gDateNewJulian julian =
    if gDateValidJulian julian
        then Just $ GDate julian
        else Nothing

gDateNewDMY :: GDateDay
            -> GDateMonth
            -> GDateYear
            -> Maybe GDate
gDateNewDMY day month year =
    if gDateValidDMY day month year
        then Just $ unsafePerformIO $ alloca $ \ptr ->
            do let GDateDay day' = day
                   GDateYear year' = year
               {# call g_date_set_dmy #} (castPtr ptr)
                                         day'
                                         (fromIntegral $ fromEnum month)
                                         year'
               peek ptr
        else Nothing

gDateSetDay :: GDate
            -> GDateDay
            -> Maybe GDate
gDateSetDay date (GDateDay day) =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_day #} (castPtr ptr) day
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateSetMonth :: GDate
              -> GDateMonth
              -> Maybe GDate
gDateSetMonth date month =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_month #} (castPtr ptr) $ fromIntegral $ fromEnum month
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateSetYear :: GDate
             -> GDateYear
             -> Maybe GDate
gDateSetYear date (GDateYear year) =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_year #} (castPtr ptr) year
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateNewTimeVal :: GTimeVal
                -> GDate
gDateNewTimeVal timeVal =
    unsafePerformIO $ alloca $ \ptr ->
        with timeVal $ \timeValPtr ->
        do {# call g_date_set_time_val #} (castPtr ptr) $ castPtr timeValPtr
           peek ptr

gDateParse :: String
           -> IO (Maybe GDate)
gDateParse str =
    alloca $ \ptr ->
        do withUTFString str $ {# call g_date_set_parse #} $ castPtr ptr
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateAddDays :: GDate
             -> Word
             -> GDate
gDateAddDays date nDays =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_days #} (castPtr ptr) $ fromIntegral nDays
           peek ptr

gDateSubtractDays :: GDate
                  -> Word
                  -> GDate
gDateSubtractDays date nDays =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_days #} (castPtr ptr) $ fromIntegral nDays
           peek ptr

gDateAddMonths :: GDate
               -> Word
               -> GDate
gDateAddMonths date nMonths =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_months #} (castPtr ptr) $ fromIntegral nMonths
           peek ptr

gDateSubtractMonths :: GDate
                    -> Word
                    -> GDate
gDateSubtractMonths date nMonths =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_months #} (castPtr ptr) $ fromIntegral nMonths
           peek ptr

gDateAddYears :: GDate
              -> Word
              -> GDate
gDateAddYears date nYears =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_years #} (castPtr ptr) $ fromIntegral nYears
           peek ptr

gDateSubtractYears :: GDate
                   -> Word
                   -> GDate
gDateSubtractYears date nYears =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_years #} (castPtr ptr) $ fromIntegral nYears
           peek ptr

gDateDaysBetween :: GDate
                 -> GDate
                 -> Int
gDateDaysBetween date1 date2 =
    fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->
        with date2 $ \ptr2 ->
            {# call g_date_days_between #} (castPtr ptr1) $ castPtr ptr2

gDateCompare :: GDate
             -> GDate
             -> Ordering
gDateCompare date1 date2 =
    let result = fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->
                     with date2 $ \ptr2 ->
                         {# call g_date_compare #} (castPtr ptr1) $ castPtr ptr2
        ordering | result < 0 = LT
                 | result > 0 = GT
                 | otherwise  = EQ
    in ordering

instance Ord GDate where
    compare = gDateCompare

gDateClamp :: GDate
           -> GDate
           -> GDate
           -> GDate
gDateClamp date minDate maxDate =
    unsafePerformIO $ with date $ \ptr ->
        with minDate $ \minPtr ->
            with maxDate $ \maxPtr ->
                do {# call g_date_clamp #} (castPtr ptr) (castPtr minPtr) $ castPtr maxPtr
                   peek ptr

gDateDay :: GDate
         -> GDateDay
gDateDay date =
    GDateDay $ unsafePerformIO $ with date $ {# call g_date_get_day #} . castPtr

gDateMonth :: GDate
           -> GDateMonth
gDateMonth date =
    toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_month #} . castPtr

gDateYear :: GDate
          -> GDateYear
gDateYear date =
    GDateYear $ unsafePerformIO $ with date $ {# call g_date_get_year #} . castPtr

gDateWeekday :: GDate
             -> GDateWeekday
gDateWeekday date =
    toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_weekday #} . castPtr

-- -*-haskell-*-
--  GIMP Toolkit (GTK)
--
--  Author : Peter Gavin
--
--  Created: 19 March 2002
--
--  Copyright (C) 2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module System.Glib.GDate (
  GTimeValPart,
  GTimeVal(..),
  gGetCurrentTime,
  gUSleep,
  gTimeValAdd,
  gTimeValFromISO8601,
  gTimeValToISO8601,
  GDate(..),
  GDateDay,
  GDateMonth,
  GDateYear,
  GDateJulianDay,
  GDateWeekday,
  gDateValidJulian,
  gDateValidDMY,
  gDateNewJulian,
  gDateNewDMY,
  gDateSetDay,
  gDateSetMonth,
  gDateSetYear,
  gDateNewTimeVal,
  gDateParse,
  gDateAddDays,
  gDateSubtractDays,
  gDateAddMonths,
  gDateSubtractMonths,
  gDateAddYears,
  gDateSubtractYears,
  gDateDaysBetween,
  gDateCompare,
  gDateClamp,
  gDateDay,
  gDateMonth,
  gDateYear,
  gDateWeekday
  ) where

import Control.Monad (liftM)
import System.Glib.FFI
import System.Glib.UTFString

type GTimeValPart = {# type glong #}
data GTimeVal = GTimeVal { gTimeValSec  :: GTimeValPart
                         , gTimeValUSec :: GTimeValPart }
                deriving (Eq, Ord)
instance Storable GTimeVal where
    sizeOf _ = {# sizeof GTimeVal #}
    alignment _ = alignment (undefined :: CString)
    peek ptr =
        do sec <- {# get GTimeVal->tv_sec #} ptr
           uSec <- {# get GTimeVal->tv_usec #} ptr
           return $ GTimeVal sec uSec
    poke ptr (GTimeVal sec uSec) =
        do {# set GTimeVal->tv_sec #} ptr sec
           {# set GTimeVal->tv_usec #} ptr uSec

gGetCurrentTime :: IO GTimeVal
gGetCurrentTime =
    alloca $ \ptr ->
        do {# call g_get_current_time #} $ castPtr ptr
           peek ptr

gUSleep :: GTimeValPart
        -> IO ()
gUSleep microseconds =
    {# call g_usleep #} $ fromIntegral microseconds

gTimeValAdd :: GTimeVal
            -> GTimeValPart
            -> GTimeVal
gTimeValAdd time microseconds =
    unsafePerformIO $ with time $ \ptr ->
        do {# call g_time_val_add #} (castPtr ptr) microseconds
           peek ptr

gTimeValFromISO8601 :: String
                    -> Maybe GTimeVal
gTimeValFromISO8601 isoDate =
    unsafePerformIO $ withUTFString isoDate $ \cISODate ->
        alloca $ \ptr ->
            do success <- liftM toBool $ {# call g_time_val_from_iso8601 #} cISODate $ castPtr ptr
               if success
                   then liftM Just $ peek ptr
                   else return Nothing

gTimeValToISO8601 :: GTimeVal
                  -> String
gTimeValToISO8601 time =
    unsafePerformIO $ with time $ \ptr ->
        {# call g_time_val_to_iso8601 #} (castPtr ptr) >>= readUTFString

newtype GDateDay = GDateDay {# type GDateDay #}
    deriving (Eq, Ord)
instance Bounded GDateDay where
    minBound = GDateDay 1
    maxBound = GDateDay 31

{# enum GDateMonth {underscoreToCase} deriving (Eq, Ord) #}
instance Bounded GDateMonth where
    minBound = GDateJanuary
    maxBound = GDateDecember

newtype GDateYear = GDateYear {# type GDateYear #}
    deriving (Eq, Ord)
instance Bounded GDateYear where
    minBound = GDateYear 1
    maxBound = GDateYear (maxBound :: {# type guint16 #})

type GDateJulianDay = {# type guint32 #}
newtype GDate = GDate { gDateJulianDay :: GDateJulianDay }
    deriving (Eq)
instance Storable GDate where
    sizeOf _ = {# sizeof GDate #}
    alignment _ = alignment (undefined :: CString)
    peek =
        (liftM (GDate . fromIntegral)) . {# call g_date_get_julian #} . castPtr
    poke ptr val =
        {# call g_date_set_julian #} (castPtr ptr) $ gDateJulianDay val

{# enum GDateWeekday {underscoreToCase} deriving (Eq, Ord) #}
instance Bounded GDateWeekday where
    minBound = GDateMonday
    maxBound = GDateSunday

gDateValidJulian :: GDateJulianDay
                 -> Bool
gDateValidJulian =
    toBool . {# call fun g_date_valid_julian #}

gDateValidDMY :: GDateDay
              -> GDateMonth
              -> GDateYear
              -> Bool
gDateValidDMY (GDateDay day) month (GDateYear year) =
    toBool $ {# call fun g_date_valid_dmy #} day
                                             (fromIntegral $ fromEnum month)
                                             year

gDateNewJulian :: GDateJulianDay
               -> Maybe GDate
gDateNewJulian julian =
    if gDateValidJulian julian
        then Just $ GDate julian
        else Nothing

gDateNewDMY :: GDateDay
            -> GDateMonth
            -> GDateYear
            -> Maybe GDate
gDateNewDMY day month year =
    if gDateValidDMY day month year
        then Just $ unsafePerformIO $ alloca $ \ptr ->
            do let GDateDay day' = day
                   GDateYear year' = year
               {# call g_date_set_dmy #} (castPtr ptr)
                                         day'
                                         (fromIntegral $ fromEnum month)
                                         year'
               peek ptr
        else Nothing

gDateSetDay :: GDate
            -> GDateDay
            -> Maybe GDate
gDateSetDay date (GDateDay day) =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_day #} (castPtr ptr) day
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateSetMonth :: GDate
              -> GDateMonth
              -> Maybe GDate
gDateSetMonth date month =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_month #} (castPtr ptr) $ fromIntegral $ fromEnum month
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateSetYear :: GDate
             -> GDateYear
             -> Maybe GDate
gDateSetYear date (GDateYear year) =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_year #} (castPtr ptr) year
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateNewTimeVal :: GTimeVal
                -> GDate
gDateNewTimeVal timeVal =
    unsafePerformIO $ alloca $ \ptr ->
        with timeVal $ \timeValPtr ->
        do {# call g_date_set_time_val #} (castPtr ptr) $ castPtr timeValPtr
           peek ptr

gDateParse :: String
           -> IO (Maybe GDate)
gDateParse str =
    alloca $ \ptr ->
        do withUTFString str $ {# call g_date_set_parse #} $ castPtr ptr
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateAddDays :: GDate
             -> Word
             -> GDate
gDateAddDays date nDays =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_days #} (castPtr ptr) $ fromIntegral nDays
           peek ptr

gDateSubtractDays :: GDate
                  -> Word
                  -> GDate
gDateSubtractDays date nDays =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_days #} (castPtr ptr) $ fromIntegral nDays
           peek ptr

gDateAddMonths :: GDate
               -> Word
               -> GDate
gDateAddMonths date nMonths =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_months #} (castPtr ptr) $ fromIntegral nMonths
           peek ptr

gDateSubtractMonths :: GDate
                    -> Word
                    -> GDate
gDateSubtractMonths date nMonths =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_months #} (castPtr ptr) $ fromIntegral nMonths
           peek ptr

gDateAddYears :: GDate
              -> Word
              -> GDate
gDateAddYears date nYears =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_years #} (castPtr ptr) $ fromIntegral nYears
           peek ptr

gDateSubtractYears :: GDate
                   -> Word
                   -> GDate
gDateSubtractYears date nYears =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_years #} (castPtr ptr) $ fromIntegral nYears
           peek ptr

gDateDaysBetween :: GDate
                 -> GDate
                 -> Int
gDateDaysBetween date1 date2 =
    fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->
        with date2 $ \ptr2 ->
            {# call g_date_days_between #} (castPtr ptr1) $ castPtr ptr2

gDateCompare :: GDate
             -> GDate
             -> Ordering
gDateCompare date1 date2 =
    let result = fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->
                     with date2 $ \ptr2 ->
                         {# call g_date_compare #} (castPtr ptr1) $ castPtr ptr2
        ordering | result < 0 = LT
                 | result > 0 = GT
                 | otherwise  = EQ
    in ordering

instance Ord GDate where
    compare = gDateCompare

gDateClamp :: GDate
           -> GDate
           -> GDate
           -> GDate
gDateClamp date minDate maxDate =
    unsafePerformIO $ with date $ \ptr ->
        with minDate $ \minPtr ->
            with maxDate $ \maxPtr ->
                do {# call g_date_clamp #} (castPtr ptr) (castPtr minPtr) $ castPtr maxPtr
                   peek ptr

gDateDay :: GDate
         -> GDateDay
gDateDay date =
    GDateDay $ unsafePerformIO $ with date $ {# call g_date_get_day #} . castPtr

gDateMonth :: GDate
           -> GDateMonth
gDateMonth date =
    toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_month #} . castPtr

gDateYear :: GDate
          -> GDateYear
gDateYear date =
    GDateYear $ unsafePerformIO $ with date $ {# call g_date_get_year #} . castPtr

gDateWeekday :: GDate
             -> GDateWeekday
gDateWeekday date =
    toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_weekday #} . castPtr