Add a function that checks if Ref is null.

{-# 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"
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)
#ifdef CALLSTACK_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,
#if FLTK_ABI_VERSION >= 10302
    TreeReasonReselected = FL_TREE_REASON_RESELECTED,
#endif /*FLTK_ABI_VERSION*/
    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 WrapType {
    WrapNone = WRAP_NONE,
    WrapAtColumn = WRAP_AT_COLUMN,
    WrapAtPixel = WRAP_AT_PIXEL,
    WrapAtBounds = 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
  };
  typedef FL_SOCKET Fl_Socket;

  enum ColorChooserMode {
    RgbMode = 0,
    ByteMode = 1,
    HexMode = 2,
    HsvMode = 3
  };
#endc
{#enum SliderType {} deriving (Show, Eq) #}
{#enum ScrollbarType {} deriving (Show, Eq) #}
{#enum BrowserType {} deriving (Show, Eq) #}
{#enum SortType {} deriving (Show, Eq) #}
{#enum FileBrowserType {} deriving (Show, Eq) #}
{#enum FileIconType {} deriving (Show, Eq) #}
{#enum FileIconProps {} deriving (Show, Eq) #}
{#enum FileChooserType {} deriving (Show, Eq) #}
{#enum ButtonType {} deriving (Show, Eq) #}
{#enum TreeReasonType {} deriving (Show, Eq) #}
{#enum MenuItemFlag {} deriving (Show, Eq, Ord) #}
{#enum ColorChooserMode {} deriving (Show, Eq, Ord) #}
newtype MenuItemFlags = MenuItemFlags [MenuItemFlag] deriving Show
allMenuItemFlags :: [MenuItemFlag]
allMenuItemFlags =
  [
     MenuItemInactive,
     MenuItemToggle,
     MenuItemValue,
     MenuItemRadio,
     MenuItemInvisible,
     SubmenuPointer,
     Submenu,
     MenuItemDivider,
     MenuItemHorizontal
  ]
{#enum CursorType {} deriving (Show, Eq) #}
{#enum PositionType {} deriving (Show, Eq) #}
{#enum DragType {} deriving (Show, Eq) #}
{#enum WrapType {} deriving (Show, Eq) #}
{#enum PageFormat {} deriving (Show, Eq) #}
{#enum PageLayout {} deriving (Show, Eq) #}
{#enum TableRowSelectMode {} deriving (Show, Eq)  #}
{#enum TableContext {} deriving (Show, Eq) #}
{#enum LinePosition {} deriving (Show, Eq)  #}
{#enum ScrollbarMode {} deriving (Show, Eq) #}
data StyleTableEntry = StyleTableEntry (Maybe Color) (Maybe Font) (Maybe FontSize) deriving Show

{#enum PackType{} deriving (Show, Eq, Ord) #}

data GLUTproc = GLUTproc {#type GLUTproc#} deriving Show
newtype GLUTIdleFunction = GLUTIdleFunction (FunPtr (IO ()))
newtype GLUTMenuStateFunction = GLUTMenuStateFunction (FunPtr (CInt -> IO()))
newtype GLUTMenuStatusFunction = GLUTMenuStatusFunction
                                     (FunPtr (CInt -> CInt -> CInt -> IO ()))
{#pointer *Fl_Glut_Bitmap_Font as GlutBitmapFontPtr newtype #}
{#pointer *Fl_Glut_StrokeVertex as GlutStrokeVertexPtr newtype#}
{#pointer *Fl_Glut_StrokeStrip as GlutStrokeStripPtr newtype#}
{#pointer *Fl_Glut_StrokeFont as GlutStrokeFontPtr newtype#}
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#}
data Ref a      = Ref !(ForeignPtr (Ptr ())) deriving (Eq, Show)
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 ColorAverageCallbackPrim    = Ptr () -> CUInt -> CFloat -> IO ()
type ImageDrawCallbackPrim       = Ptr () -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO ()
type ImageCopyCallbackPrim       = Ptr () -> CInt -> CInt -> IO (Ptr ())
type GlobalEventHandlerPrim      = CInt -> IO CInt
type GlobalEventHandlerF         = Event -> IO Int
type DrawCallback                = String -> 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 TextModifyCb                = Int -> Int -> Int -> Int -> String -> IO ()
type TextModifyCbPrim            = CInt -> CInt -> CInt -> CInt -> Ptr CChar -> Ptr () -> IO ()
type TextPredeleteCb             = BufferOffset -> Int -> IO ()
type TextPredeleteCbPrim         = CInt -> CInt -> Ptr () -> IO ()
type UnfinishedStyleCb           = BufferOffset -> IO ()
type UnfinishedStyleCbPrim       = CInt -> Ptr () -> IO ()

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

data ColorChooserRGB = Decimals (Between0And1, Between0And1, Between0And1) | Words RGB deriving Show
data Rectangle = Rectangle Position Size deriving (Eq,Show)
data ByXY = ByXY ByX ByY deriving Show
data Intersection = Contained | Partial deriving Show
data Size = Size Width Height deriving (Eq, Show)
data KeyType = SpecialKeyType SpecialKey | NormalKeyType Char deriving (Show, Eq)
data ShortcutKeySequence = ShortcutKeySequence [EventState] KeyType deriving Show
data Shortcut = KeySequence ShortcutKeySequence | KeyFormat String deriving Show
data KeyBindingKeySequence = KeyBindingKeySequence (Maybe [EventState]) KeyType deriving Show
newtype Between0And1 = Between0And1 Double deriving Show
newtype Between0And6 = Between0And6 Double deriving Show
data ScreenLocation = Intersect Rectangle
                    | ScreenNumber Int
                    | ScreenPosition Position deriving Show
newtype FontSize = FontSize CInt deriving Show
newtype PixmapHs = PixmapHs [String] deriving Show
data BitmapHs = BitmapHs B.ByteString Size deriving Show
data Clipboard = InternalClipboard | SharedClipboard deriving Show
data UnknownError = UnknownError deriving Show
data NotFound = NotFound deriving Show
data OutOfRange = OutOfRange deriving Show
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 Show
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
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')

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)
#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)
#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
#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
        if (refPtr == nullPtr)
          then return True
          else return False
   )

unsafeRefToPtr :: Ref a -> IO (Ptr ())
unsafeRefToPtr (Ref fptr) =
    throwStackOnError $ do
      refPtr <- toRefPtr $ Unsafe.unsafeForeignPtrToPtr fptr
      return $ castPtr refPtr

withRefs :: [Ref a] -> (Ptr (Ptr b) -> IO c) -> IO c
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

{-# 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"
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)
#ifdef CALLSTACK_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,
#if FLTK_ABI_VERSION >= 10302
    TreeReasonReselected = FL_TREE_REASON_RESELECTED,
#endif /*FLTK_ABI_VERSION*/
    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 WrapType {
    WrapNone = WRAP_NONE,
    WrapAtColumn = WRAP_AT_COLUMN,
    WrapAtPixel = WRAP_AT_PIXEL,
    WrapAtBounds = 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
  };
  typedef FL_SOCKET Fl_Socket;

  enum ColorChooserMode {
    RgbMode = 0,
    ByteMode = 1,
    HexMode = 2,
    HsvMode = 3
  };
#endc
{#enum SliderType {} deriving (Show, Eq) #}
{#enum ScrollbarType {} deriving (Show, Eq) #}
{#enum BrowserType {} deriving (Show, Eq) #}
{#enum SortType {} deriving (Show, Eq) #}
{#enum FileBrowserType {} deriving (Show, Eq) #}
{#enum FileIconType {} deriving (Show, Eq) #}
{#enum FileIconProps {} deriving (Show, Eq) #}
{#enum FileChooserType {} deriving (Show, Eq) #}
{#enum ButtonType {} deriving (Show, Eq) #}
{#enum TreeReasonType {} deriving (Show, Eq) #}
{#enum MenuItemFlag {} deriving (Show, Eq, Ord) #}
{#enum ColorChooserMode {} deriving (Show, Eq, Ord) #}
newtype MenuItemFlags = MenuItemFlags [MenuItemFlag] deriving Show
allMenuItemFlags :: [MenuItemFlag]
allMenuItemFlags =
  [
     MenuItemInactive,
     MenuItemToggle,
     MenuItemValue,
     MenuItemRadio,
     MenuItemInvisible,
     SubmenuPointer,
     Submenu,
     MenuItemDivider,
     MenuItemHorizontal
  ]
{#enum CursorType {} deriving (Show, Eq) #}
{#enum PositionType {} deriving (Show, Eq) #}
{#enum DragType {} deriving (Show, Eq) #}
{#enum WrapType {} deriving (Show, Eq) #}
{#enum PageFormat {} deriving (Show, Eq) #}
{#enum PageLayout {} deriving (Show, Eq) #}
{#enum TableRowSelectMode {} deriving (Show, Eq)  #}
{#enum TableContext {} deriving (Show, Eq) #}
{#enum LinePosition {} deriving (Show, Eq)  #}
{#enum ScrollbarMode {} deriving (Show, Eq) #}
data StyleTableEntry = StyleTableEntry (Maybe Color) (Maybe Font) (Maybe FontSize) deriving Show

{#enum PackType{} deriving (Show, Eq, Ord) #}

data GLUTproc = GLUTproc {#type GLUTproc#} deriving Show
newtype GLUTIdleFunction = GLUTIdleFunction (FunPtr (IO ()))
newtype GLUTMenuStateFunction = GLUTMenuStateFunction (FunPtr (CInt -> IO()))
newtype GLUTMenuStatusFunction = GLUTMenuStatusFunction
                                     (FunPtr (CInt -> CInt -> CInt -> IO ()))
{#pointer *Fl_Glut_Bitmap_Font as GlutBitmapFontPtr newtype #}
{#pointer *Fl_Glut_StrokeVertex as GlutStrokeVertexPtr newtype#}
{#pointer *Fl_Glut_StrokeStrip as GlutStrokeStripPtr newtype#}
{#pointer *Fl_Glut_StrokeFont as GlutStrokeFontPtr newtype#}
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#}
data Ref a      = Ref !(ForeignPtr (Ptr ())) deriving (Eq, Show)
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 ColorAverageCallbackPrim    = Ptr () -> CUInt -> CFloat -> IO ()
type ImageDrawCallbackPrim       = Ptr () -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO ()
type ImageCopyCallbackPrim       = Ptr () -> CInt -> CInt -> IO (Ptr ())
type GlobalEventHandlerPrim      = CInt -> IO CInt
type GlobalEventHandlerF         = Event -> IO Int
type DrawCallback                = String -> 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 TextModifyCb                = Int -> Int -> Int -> Int -> String -> IO ()
type TextModifyCbPrim            = CInt -> CInt -> CInt -> CInt -> Ptr CChar -> Ptr () -> IO ()
type TextPredeleteCb             = BufferOffset -> Int -> IO ()
type TextPredeleteCbPrim         = CInt -> CInt -> Ptr () -> IO ()
type UnfinishedStyleCb           = BufferOffset -> IO ()
type UnfinishedStyleCbPrim       = CInt -> Ptr () -> IO ()

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

data ColorChooserRGB = Decimals (Between0And1, Between0And1, Between0And1) | Words RGB deriving Show
data Rectangle = Rectangle Position Size deriving (Eq,Show)
data ByXY = ByXY ByX ByY deriving Show
data Intersection = Contained | Partial deriving Show
data Size = Size Width Height deriving (Eq, Show)
data KeyType = SpecialKeyType SpecialKey | NormalKeyType Char deriving (Show, Eq)
data ShortcutKeySequence = ShortcutKeySequence [EventState] KeyType deriving Show
data Shortcut = KeySequence ShortcutKeySequence | KeyFormat String deriving Show
data KeyBindingKeySequence = KeyBindingKeySequence (Maybe [EventState]) KeyType deriving Show
newtype Between0And1 = Between0And1 Double deriving Show
newtype Between0And6 = Between0And6 Double deriving Show
data ScreenLocation = Intersect Rectangle
                    | ScreenNumber Int
                    | ScreenPosition Position deriving Show
newtype FontSize = FontSize CInt deriving Show
newtype PixmapHs = PixmapHs [String] deriving Show
data BitmapHs = BitmapHs B.ByteString Size deriving Show
data Clipboard = InternalClipboard | SharedClipboard deriving Show
data UnknownError = UnknownError deriving Show
data NotFound = NotFound deriving Show
data OutOfRange = OutOfRange deriving Show
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 Show
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
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')

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

unsafeRefToPtr :: Ref a -> IO (Ptr ())
unsafeRefToPtr (Ref fptr) =
    throwStackOnError $ do
      refPtr <- toRefPtr $ Unsafe.unsafeForeignPtrToPtr fptr
      return $ castPtr refPtr

withRefs :: [Ref a] -> (Ptr (Ptr b) -> IO c) -> IO c
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


GLDrawingArea: provide implementation for GObjectClass

Without this patch, trying to use a GLDrawingArea results in
  program: gtkglext/Graphics/UI/Gtk/OpenGL/DrawingArea.chs:73:0: No instance nor default method for class operation System.Glib.Types.toGObject

darcs-hash:20071031134717-ef904-866f627ea313aadf4321c9d6f0df5396e1e99cf3.gz

-- -*-haskell-*-
--  GIMP Toolkit (GTK) OpenGL Extension: DrawingArea Widget
--
--  Author : Duncan Coutts
--
--  Created: 9 June 2005
--
--  Copyright (C) 2005 Duncan Coutts
--
--  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 Graphics.UI.Gtk.OpenGL.DrawingArea (

-- * Class Hierarchy
-- |
-- @
-- |  'GObject'
-- |   +----'Object'
-- |         +----'Widget'
-- |               +----'DrawingArea'
-- |                     +----GLDrawingArea
-- @

-- * Types
  GLDrawingArea,

-- * Constructors
  glDrawingAreaNew,

-- * Methods
  withGLDrawingArea,
  glDrawingAreaGetGLConfig,
  glDrawingAreaGetGLContext,
  glDrawingAreaGetGLWindow,
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.GObject			(makeNewGObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.OpenGL.Types#}
import Graphics.UI.Gtk.Misc.DrawingArea		(drawingAreaNew)
import Graphics.UI.Gtk.OpenGL.Drawable		(glDrawableGLBegin, glDrawableWaitGL, glDrawableGLEnd)
import Graphics.UI.Gtk.OpenGL.Window		()
import Graphics.UI.Gtk.OpenGL.Context		(GLRenderType(..))

{# context lib="gtkglext" prefix="gtk" #}

--------------------
-- Types

newtype GLDrawingArea = GLDrawingArea DrawingArea

instance DrawingAreaClass GLDrawingArea
instance WidgetClass GLDrawingArea
instance ObjectClass GLDrawingArea
instance GObjectClass GLDrawingArea where
  toGObject (GLDrawingArea gd) = toGObject gd
  unsafeCastGObject = GLDrawingArea . unsafeCastGObject

--------------------
-- Constructors

glDrawingAreaNew :: GLConfig -> IO GLDrawingArea
glDrawingAreaNew glconfig = do
  drawingArea <- drawingAreaNew
  widgetSetGLCapability drawingArea glconfig Nothing True RGBAType
  return (GLDrawingArea drawingArea)

--------------------
-- Methods

withGLDrawingArea :: GLDrawingArea -> (GLWindow -> IO a) -> IO a
withGLDrawingArea glDrawingArea glAction = do
  glcontext <- glDrawingAreaGetGLContext glDrawingArea
  glwindow <- glDrawingAreaGetGLWindow glDrawingArea
  glDrawableGLBegin glwindow glcontext
  result <- glAction glwindow
  glDrawableWaitGL glwindow
  glDrawableGLEnd glwindow
  return result

-- |
--
glDrawingAreaGetGLConfig :: GLDrawingArea -> IO GLConfig
glDrawingAreaGetGLConfig (GLDrawingArea widget) =
  makeNewGObject mkGLConfig $
  {# call gtk_widget_get_gl_config #}
    (toWidget widget)

-- |
--
glDrawingAreaGetGLContext :: GLDrawingArea -> IO GLContext
glDrawingAreaGetGLContext (GLDrawingArea widget) =
  makeNewGObject mkGLContext $
  {# call gtk_widget_get_gl_context #}
    (toWidget widget)

-- |
--
glDrawingAreaGetGLWindow :: GLDrawingArea -> IO GLWindow
glDrawingAreaGetGLWindow (GLDrawingArea widget) =
  makeNewGObject mkGLWindow $
  {# call gtk_widget_get_gl_window #}
    (toWidget widget)

-- |
--
widgetSetGLCapability
 :: WidgetClass widget
 => widget
 -> GLConfig
 -> Maybe GLContext
 -> Bool
 -> GLRenderType
 -> IO Bool
widgetSetGLCapability widget glconfig shareList direct renderType =
  liftM toBool $
  {# call gtk_widget_set_gl_capability #}
    (toWidget widget)
    (toGLConfig glconfig)
    (maybe (mkGLContext nullForeignPtr) toGLContext shareList)
    (fromBool direct)
    ((fromIntegral . fromEnum) renderType)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) OpenGL Extension: DrawingArea Widget
--
--  Author : Duncan Coutts
--
--  Created: 9 June 2005
--
--  Copyright (C) 2005 Duncan Coutts
--
--  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 Graphics.UI.Gtk.OpenGL.DrawingArea (

-- * Class Hierarchy
-- |
-- @
-- |  'GObject'
-- |   +----'Object'
-- |         +----'Widget'
-- |               +----'DrawingArea'
-- |                     +----GLDrawingArea
-- @

-- * Types
  GLDrawingArea,

-- * Constructors
  glDrawingAreaNew,

-- * Methods
  withGLDrawingArea,
  glDrawingAreaGetGLConfig,
  glDrawingAreaGetGLContext,
  glDrawingAreaGetGLWindow,
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.GObject			(makeNewGObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.OpenGL.Types#}
import Graphics.UI.Gtk.Misc.DrawingArea		(drawingAreaNew)
import Graphics.UI.Gtk.OpenGL.Drawable		(glDrawableGLBegin, glDrawableWaitGL, glDrawableGLEnd)
import Graphics.UI.Gtk.OpenGL.Window		()
import Graphics.UI.Gtk.OpenGL.Context		(GLRenderType(..))

{# context lib="gtkglext" prefix="gtk" #}

--------------------
-- Types

newtype GLDrawingArea = GLDrawingArea DrawingArea

instance DrawingAreaClass GLDrawingArea
instance WidgetClass GLDrawingArea
instance ObjectClass GLDrawingArea
instance GObjectClass GLDrawingArea

--------------------
-- Constructors

glDrawingAreaNew :: GLConfig -> IO GLDrawingArea
glDrawingAreaNew glconfig = do
  drawingArea <- drawingAreaNew
  widgetSetGLCapability drawingArea glconfig Nothing True RGBAType
  return (GLDrawingArea drawingArea)

--------------------
-- Methods

withGLDrawingArea :: GLDrawingArea -> (GLWindow -> IO a) -> IO a
withGLDrawingArea glDrawingArea glAction = do
  glcontext <- glDrawingAreaGetGLContext glDrawingArea
  glwindow <- glDrawingAreaGetGLWindow glDrawingArea
  glDrawableGLBegin glwindow glcontext
  result <- glAction glwindow
  glDrawableWaitGL glwindow
  glDrawableGLEnd glwindow
  return result

-- |
--
glDrawingAreaGetGLConfig :: GLDrawingArea -> IO GLConfig
glDrawingAreaGetGLConfig (GLDrawingArea widget) =
  makeNewGObject mkGLConfig $
  {# call gtk_widget_get_gl_config #}
    (toWidget widget)

-- |
--
glDrawingAreaGetGLContext :: GLDrawingArea -> IO GLContext
glDrawingAreaGetGLContext (GLDrawingArea widget) =
  makeNewGObject mkGLContext $
  {# call gtk_widget_get_gl_context #}
    (toWidget widget)

-- |
--
glDrawingAreaGetGLWindow :: GLDrawingArea -> IO GLWindow
glDrawingAreaGetGLWindow (GLDrawingArea widget) =
  makeNewGObject mkGLWindow $
  {# call gtk_widget_get_gl_window #}
    (toWidget widget)

-- |
--
widgetSetGLCapability
 :: WidgetClass widget
 => widget
 -> GLConfig
 -> Maybe GLContext
 -> Bool
 -> GLRenderType
 -> IO Bool
widgetSetGLCapability widget glconfig shareList direct renderType =
  liftM toBool $
  {# call gtk_widget_set_gl_capability #}
    (toWidget widget)
    (toGLConfig glconfig)
    (maybe (mkGLContext nullForeignPtr) toGLContext shareList)
    (fromBool direct)
    ((fromIntegral . fromEnum) renderType)


gnomevfs: use c2hs {#enum#} for FilePermissions instead of hand coding it

--  GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-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/>.
--
--  GnomeVFS, 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 GnomeVFS documentation,
--  Copyright (c) 2001 Seth Nickell <snickell@stanford.edu>. The
--  documentation is covered by the GNU Free Documentation License,
--  version 1.2.

-- #hide

-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module System.Gnome.VFS.Types (

  Handle(..),
  withHandle,

  Result(..),
  Error(..),

  OpenMode(..),
  SeekPosition(..),

  FileInfo(..),
  FileFlags(..),
  FileInfoFields(..),
  SetFileInfoMask(..),
  FileInfoOptions(..),
  FilePermissions(..),
  FileSize,
  FileOffset,
  FileType(..),
  InodeNumber,
  IDs,

  MonitorHandle(..),
  withMonitorHandle,
  MonitorCallback,
  MonitorType,
  MonitorEventType,

  URI(..),
  TextURI,
  newURI,
  withURI,
  ToplevelURI(..),
  newToplevelURI,
  withToplevelURI,
  URIHideOptions(..),

  DirectoryHandle(..),
  withDirectoryHandle,

  MakeURIDirs(..),
  DirectoryVisitOptions(..),
  DirectoryVisitCallback,
  DirectoryVisitResult(..),
  FindDirectoryKind(..),

  XferOptions(..),
  XferProgressStatus(..),
  XferOverwriteMode(..),
  XferOverwriteAction(..),
  XferErrorMode(..),
  XferErrorAction(..),
  XferPhase(..),
  XferProgressInfo(..),
  XferProgressCallback,
  XferErrorCallback,
  XferOverwriteCallback,
  XferDuplicateCallback,

  Cancellation(..),
  newCancellation,
  withCancellation,

  VolumeOpSuccessCallback,
  VolumeOpFailureCallback,
  CVolumeOpCallback,
  VolumeType(..),
  DeviceType(..),

  MIMEType,

  module System.Gnome.VFS.Hierarchy,

  DriveID,
  newDrive,
  withDrive,

  VolumeID,
  newVolume,
  withVolume,

  wrapVolumeMonitor,
  withVolumeMonitor

  ) where

import Control.Exception (assert)
import Control.Monad
import Control.Monad.Reader
import Data.ByteString (ByteString)
import Data.Typeable
import Data.Word (Word64)
import System.Glib.FFI
import System.Glib.Flags
{#import System.Glib.GObject#} (GObject(..),
                                GObjectClass,
                                toGObject,
                                unsafeCastGObject)
{#import System.Glib.GType#} (GType,
                              typeInstanceIsA)
{#import System.Gnome.VFS.Hierarchy#}

import System.Posix.Types (DeviceID, EpochTime)

--------------------------------------------------------------------

gTypeCast :: (GObjectClass obj, GObjectClass obj') => GType -> String
                                                   -> (obj ->  obj')
-- The usage of foreignPtrToPtr should be safe as the evaluation will only be
-- forced if the object is used afterwards
gTypeCast gtype objTypeName obj =
  case toGObject obj of
    gobj@(GObject objFPtr)
      | typeInstanceIsA ((unsafeForeignPtrToPtr.castForeignPtr) objFPtr) gtype
                  -> unsafeCastGObject gobj
      | otherwise -> error $ "Cannot cast object to " ++ objTypeName

--------------------------------------------------------------------

-- | The result of a file operation.
{# enum GnomeVFSResult as Result {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show, Typeable) #}

newtype Error = Error Result
                deriving (Show, Typeable)

-- | A handle to an open file
{# pointer *GnomeVFSHandle as Handle foreign newtype #}
withHandle (Handle cHandle) = withForeignPtr cHandle

-- | Specifies the start position for a seek operation.
{# enum GnomeVFSSeekPosition    as SeekPosition    {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}
{# enum GnomeVFSOpenMode        as OpenMode        {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}

--------------------------------------------------------------------

-- | A record type containing information about a file.
data FileInfo = FileInfo {
  fileInfoName        :: Maybe String,            -- ^ the name of the file,
                                                  --   without the path
  fileInfoType        :: Maybe FileType,          -- ^ the type of the file;
                                                  --   i.e. regular, directory,
                                                  --   block-device, etc.
  fileInfoPermissions :: Maybe [FilePermissions], -- ^ the permissions for the
                                                  --   file
  fileInfoFlags       :: Maybe [FileFlags],       -- ^ flags providing
                                                  --   additional information
                                                  --   about the file
  fileInfoDevice      :: Maybe DeviceID,          -- ^ the device the file
                                                  --   resides on
  fileInfoInode       :: Maybe InodeNumber,       -- ^ the inode number of the
                                                  --   file
  fileInfoLinkCount   :: Maybe Int,               -- ^ the total number of
                                                  --   hard links to the file
  fileInfoIDs         :: Maybe IDs,               -- ^ the user and group IDs
                                                  --   owning the file
  fileInfoSize        :: Maybe FileSize,          -- ^ the size of the file in
                                                  --   bytes
  fileInfoBlockCount  :: Maybe FileSize,          -- ^ the size of the file in
                                                  --   filesystem blocks
  fileInfoIOBlockSize :: Maybe FileSize,          -- ^ the optimal buffer size
                                                  --   for reading from and
                                                  --   writing to the file
  fileInfoATime       :: Maybe EpochTime,         -- ^ the time of last access
  fileInfoMTime       :: Maybe EpochTime,         -- ^ the time of last modification
  fileInfoCTime       :: Maybe EpochTime,         -- ^ the time of last attribute modification
  fileInfoSymlinkName :: Maybe String,            -- ^ the location this
                                                  --   symlink points to, if
                                                  --   @fileInfoFlags@ contains 'FileFlagsSymlink'
  fileInfoMIMEType    :: Maybe MIMEType           -- ^ the MIME-type of the
                                                  --   file
  } deriving (Eq, Show)

{# enum GnomeVFSFileInfoFields  as FileInfoFields  {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}

-- | Options for reading information from a file.
{# enum GnomeVFSFileInfoOptions as FileInfoOptions {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}

-- | Flags specifying additional information about a file.
{# enum GnomeVFSFileFlags       as FileFlags       {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}

-- | Flags specifying the attributes of a file that should be changed.
{# enum GnomeVFSSetFileInfoMask as SetFileInfoMask {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}

-- | Identifies the type of a file.
{# enum GnomeVFSFileType        as FileType        {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}

instance Flags FileInfoOptions
instance Flags FileInfoFields
instance Flags FileFlags
instance Flags SetFileInfoMask

-- | An integral type wide enough to hold the size of a file.
type FileSize        = Word64

-- | An integral type wide enough to hold an offset into a file.
type FileOffset      = Word64

-- | An integral type wide enough to hold the inode number of a file.
type InodeNumber     = Word64

-- | A pair holding the user ID and group ID of a file owner.
type IDs             = (Int, Int)

-- | UNIX-like permissions for a file.
{# enum GnomeVFSFilePermissions as FilePermissions {
    GNOME_VFS_PERM_SUID              as PermSUID,
    GNOME_VFS_PERM_SGID              as PermSGID,
    GNOME_VFS_PERM_STICKY            as PermSticky,
    GNOME_VFS_PERM_USER_READ         as PermUserRead,
    GNOME_VFS_PERM_USER_WRITE        as PermUserWrite,
    GNOME_VFS_PERM_USER_EXEC         as PermUserExec,
    GNOME_VFS_PERM_USER_ALL          as PermUserAll,
    GNOME_VFS_PERM_GROUP_READ        as PermGroupRead,
    GNOME_VFS_PERM_GROUP_WRITE       as PermGroupWrite,
    GNOME_VFS_PERM_GROUP_EXEC        as PermGroupExec,
    GNOME_VFS_PERM_GROUP_ALL         as PermGroupAll,
    GNOME_VFS_PERM_OTHER_READ        as PermOtherRead,
    GNOME_VFS_PERM_OTHER_WRITE       as PermOtherWrite,
    GNOME_VFS_PERM_OTHER_EXEC        as PermOtherExec,
    GNOME_VFS_PERM_OTHER_ALL         as PermOtherAll,
    GNOME_VFS_PERM_ACCESS_READABLE   as PermAccessReadable,
    GNOME_VFS_PERM_ACCESS_WRITABLE   as PermAccessWritable,
    GNOME_VFS_PERM_ACCESS_EXECUTABLE as PermAccessExecutable
    } deriving (Eq, Bounded, Show) #}
instance Flags FilePermissions

--------------------------------------------------------------------

-- | A 'URI' is a semi-textual representation of a uniform
--   resource identifier. It contains the information about a resource
--   location encoded as canononicalized text, but also holds extra
--   information about the context in which the URI is used.
{# pointer *GnomeVFSURI as URI foreign newtype #}

newURI :: Ptr URI
       -> IO URI
newURI cURI | cURI /= nullPtr =
    liftM URI $ newForeignPtr cURI cURIFinalizer
wrapURI :: Ptr URI
        -> IO URI
wrapURI cURI | cURI /= nullPtr =
    liftM URI $ newForeignPtr_ cURI
foreign import ccall "&gnome_vfs_uri_unref"
  cURIFinalizer :: FunPtr (Ptr URI -> IO ())

withURI (URI cURI) = withForeignPtr cURI

-- | The toplevel URI element used to access resources stored on a
--   remote server.
{# pointer *GnomeVFSToplevelURI as ToplevelURI foreign newtype #}
withToplevelURI (ToplevelURI cToplevelURI) = withForeignPtr cToplevelURI
newToplevelURI :: Ptr ToplevelURI
               -> IO ToplevelURI
newToplevelURI cToplevelURI = liftM ToplevelURI $ newForeignPtr_ cToplevelURI

-- | Flags specifying which fields of a 'URI' should be hidden when
--   converted to a string using 'uriToString'.
{# enum GnomeVFSURIHideOptions as URIHideOptions {
        GNOME_VFS_URI_HIDE_NONE as URIHideNone,
        GNOME_VFS_URI_HIDE_USER_NAME as URIHideUserName,
        GNOME_VFS_URI_HIDE_PASSWORD as URIHidePassword,
        GNOME_VFS_URI_HIDE_HOST_NAME as URIHideHostName,
        GNOME_VFS_URI_HIDE_HOST_PORT as URIHideHostPort,
        GNOME_VFS_URI_HIDE_TOPLEVEL_METHOD as URIHideToplevelMethod,
        GNOME_VFS_URI_HIDE_FRAGMENT_IDENTIFIER as URIHideFragmentIdentifier
        } deriving (Eq, Bounded, Show) #}
instance Flags URIHideOptions

-- | A string that can be passed to 'uriFromString' to create a valid
--   'URI'.
type TextURI = String

--------------------------------------------------------------------

-- | A handle to an open directory.
{# pointer *GnomeVFSDirectoryHandle as DirectoryHandle foreign newtype #}
withDirectoryHandle (DirectoryHandle cDirectoryHandle) = withForeignPtr cDirectoryHandle

-- | Options controlling the way in which a directories are visited.
{# enum GnomeVFSDirectoryVisitOptions as DirectoryVisitOptions {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}
instance Flags DirectoryVisitOptions

-- | A callback that will be called for each entry when passed to
--   'directoryVisit', 'directoryVisitURI', 'directoryVisitFiles', or
--   'directoryVisitFilesAtURI'.
type DirectoryVisitCallback =  String                  -- ^ the path of the visited file, relative to the base directory
                            -> FileInfo                -- ^ the 'FileInfo' for the visited file
                            -> Bool                    -- ^ 'True' if returning 'DirectoryVisitRecurse' will cause a loop
                            -> IO DirectoryVisitResult -- ^ the next action to be taken

-- | An enumerated value that must be returned from a
--   'DirectoryVisitCallback'. The 'directoryVisit' and related
--   functions will perform the action specified.
data DirectoryVisitResult = DirectoryVisitStop     -- ^ stop visiting files
                          | DirectoryVisitContinue -- ^ continue as normal
                          | DirectoryVisitRecurse  -- ^ recursively visit the current entry
                            deriving (Eq, Enum)

-- | Specifies which kind of directory 'findDirectory' should look for.
{# enum GnomeVFSFindDirectoryKind as FindDirectoryKind {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}

--------------------------------------------------------------------

-- | Flags that may be passed to 'makeURIFromInputWithDirs'. If the
--   path passed is non-absolute (i.e., a relative path), the
--   directories specified will be searched as well.
{# enum GnomeVFSMakeURIDirs as MakeURIDirs {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}
instance Flags MakeURIDirs

--------------------------------------------------------------------

-- | A handle to a file-system monitor.
newtype MonitorHandle = MonitorHandle (ForeignPtr MonitorHandle, {# type GnomeVFSMonitorCallback #})
withMonitorHandle (MonitorHandle (monitorHandleForeignPtr, _)) = withForeignPtr monitorHandleForeignPtr

-- | A callback that must be passed to 'monitorAdd'.  It will be
--   called any time a file or directory is changed.
type MonitorCallback =  MonitorHandle    -- ^ the handle to a filesystem monitor
                     -> TextURI          -- ^ the URI being monitored
                     -> TextURI          -- ^ the actual file that was modified
                     -> MonitorEventType -- ^ the event that occured
                     -> IO ()

-- | The type of filesystem object that is to be monitored.
{# enum GnomeVFSMonitorType      as MonitorType      {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}

-- | The type of event that caused a 'MonitorCallback' to be called.
{# enum GnomeVFSMonitorEventType as MonitorEventType {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}
wrapMonitorHandle :: (Ptr MonitorHandle, {# type GnomeVFSMonitorCallback #})
                  -> IO MonitorHandle
wrapMonitorHandle (cMonitorHandle, cMonitorCallback) =
    do monitorHandleForeignPtr <- newForeignPtr_ cMonitorHandle
       return $ MonitorHandle (monitorHandleForeignPtr, cMonitorCallback)

--------------------------------------------------------------------

-- | Options controlling how the 'System.Gnome.VFS.Xfer.xferURI' and related functions behave.
{# enum GnomeVFSXferOptions         as XferOptions         {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}
instance Flags XferOptions

{# enum GnomeVFSXferProgressStatus  as XferProgressStatus  {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}
{# enum GnomeVFSXferOverwriteMode   as XferOverwriteMode   {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}
{# enum GnomeVFSXferOverwriteAction as XferOverwriteAction {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}
{# enum GnomeVFSXferErrorMode       as XferErrorMode       {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}
{# enum GnomeVFSXferErrorAction     as XferErrorAction     {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}
{# enum GnomeVFSXferPhase           as XferPhase           {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}

data XferProgressInfo = XferProgressInfo {
    xferProgressInfoVFSStatus        :: Result,       -- ^ current VFS status
    xferProgressInfoPhase            :: XferPhase,    -- ^ phase of the transfer
    xferProgressInfoSourceName       :: Maybe String, -- ^ currently transferring source URI
    xferProgressInfoTargetName       :: Maybe String, -- ^ currently transferring target URI
    xferProgressInfoFileIndex        :: Word,         -- ^ index of the file currently being transferred
    xferProgressInfoFilesTotal       :: Word,         -- ^ total number of files being transferred
    xferProgressInfoBytesTotal       :: FileSize,     -- ^ total size of all files in bytes
    xferProgressInfoFileSize         :: FileSize,     -- ^ size of the file currently being transferred
    xferProgressInfoBytesCopied      :: FileSize,     -- ^ number of bytes already transferred in the current file
    xferProgressInfoTotalBytesCopied :: FileSize,     -- ^ total number of bytes already transferred
    xferProgressInfoTopLevelItem     :: Bool          -- ^ 'True' if the file being transferred is a top-level item;
                                                      --   'False' if it is inside a directory
    } deriving (Eq)

-- | The type of the first callback that is passed to
--   'System.Gnome.VFS.Xfer.xferURI' and related functions. This
--   callback will be called periodically during transfers that are
--   progressing normally.
type XferProgressCallback  =  XferProgressInfo -- ^ @info@ - information about the progress of the current transfer
                           -> IO Bool          -- ^ return 'Prelude.False' to abort the transfer, 'Prelude.True' otherwise.

-- | The type of the second callback that is passed to
--   'System.Gnome.VFS.Xfer.xferURI'. This callback will be called
--   whenever an error occurs.
type XferErrorCallback     =  XferProgressInfo   -- ^ @info@ - information about the progress of the current transfer
                           -> IO XferErrorAction -- ^ the action to be performed in response to the error

-- | The type of the third callback that is passed to
--   'System.Gnome.VFS.Xfer.xferURI'. This callback will be called
--   when a file would be overwritten.
type XferOverwriteCallback =  XferProgressInfo       -- ^ @info@ - information about the progress of the current transfer
                           -> IO XferOverwriteAction -- ^ the action to be performed when the target file already exists

-- | The type of the fourth callback that is passed to
--   'System.Gnome.VFS.Xfer.xferURI'. This callback will be called
--   when a duplicate filename is found.
type XferDuplicateCallback =  XferProgressInfo   -- ^ @info@ - information about the progress of the current transfer
                           -> String             -- ^ @duplicateName@ - the name of the target file
                           -> Int                -- ^ @duplicateCount@ - the number of duplicates that exist
                           -> IO (Maybe String)  -- ^ the new filename that should be used, or 'Prelude.Nothing' to abort.

--------------------------------------------------------------------

-- | An object that can be used for signalling cancellation of an
--   operation.
{# pointer *GnomeVFSCancellation as Cancellation foreign newtype #}

newCancellation :: Ptr Cancellation
                -> IO Cancellation
newCancellation cCancellationPtr | cCancellationPtr /= nullPtr =
    liftM Cancellation $ newForeignPtr cCancellationPtr cancellationFinalizer
foreign import ccall unsafe "&gnome_vfs_cancellation_destroy"
  cancellationFinalizer :: FunPtr (Ptr Cancellation -> IO ())
withCancellation (Cancellation cCancellation) = withForeignPtr cCancellation

--------------------------------------------------------------------

withVolume (Volume cVolume) = withForeignPtr cVolume
newVolume :: Ptr Volume
          -> IO Volume
newVolume cVolume | cVolume /= nullPtr =
   liftM Volume $ newForeignPtr cVolume volumeFinalizer
foreign import ccall unsafe "&gnome_vfs_volume_unref"
  volumeFinalizer :: FunPtr (Ptr Volume -> IO ())

-- | An action to be performed when a volume operation completes successfully.
type VolumeOpSuccessCallback = IO ()
-- | An action to be performed when a volume operation fails.
type VolumeOpFailureCallback =  String
                             -> String
                             -> IO ()

-- | Identifies the device type of a 'Volume' or 'Drive'.
{#enum GnomeVFSDeviceType as DeviceType {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}
-- | Identifies the type of a 'Volume'.
{#enum GnomeVFSVolumeType as VolumeType {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}

type CVolumeOpCallback =  {# type gboolean #}
                       -> CString
                       -> CString
                       -> Ptr ()
                       -> IO ()

--------------------------------------------------------------------

-- | Identifies a 'Drive'
type DriveID = {# type gulong #}

withDrive (Drive cDrive) = withForeignPtr cDrive
newDrive :: Ptr Drive
          -> IO Drive
newDrive cDrive | cDrive /= nullPtr =
   liftM Drive $ newForeignPtr cDrive driveFinalizer
foreign import ccall unsafe "&gnome_vfs_drive_unref"
  driveFinalizer :: FunPtr (Ptr Drive -> IO ())

--------------------------------------------------------------------

-- | Identifies a 'Volume'.
type VolumeID = {# type gulong #}

withVolumeMonitor (VolumeMonitor cVolumeMonitor) = withForeignPtr cVolumeMonitor
wrapVolumeMonitor :: Ptr VolumeMonitor
                  -> IO VolumeMonitor
wrapVolumeMonitor cVolumeMonitor | cVolumeMonitor /= nullPtr =
   liftM VolumeMonitor $ newForeignPtr_ cVolumeMonitor

--------------------------------------------------------------------

-- | A string that will be treated as a MIME-type.
type MIMEType = String

--  GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-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/>.
--
--  GnomeVFS, 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 GnomeVFS documentation,
--  Copyright (c) 2001 Seth Nickell <snickell@stanford.edu>. The
--  documentation is covered by the GNU Free Documentation License,
--  version 1.2.

-- #hide

-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module System.Gnome.VFS.Types (

  Handle(..),
  withHandle,

  Result(..),
  Error(..),

  OpenMode(..),
  SeekPosition(..),

  FileInfo(..),
  FileFlags(..),
  FileInfoFields(..),
  SetFileInfoMask(..),
  FileInfoOptions(..),
  FilePermissions(..),
  FileSize,
  FileOffset,
  FileType(..),
  InodeNumber,
  IDs,

  MonitorHandle(..),
  withMonitorHandle,
  MonitorCallback,
  MonitorType,
  MonitorEventType,

  URI(..),
  TextURI,
  newURI,
  withURI,
  ToplevelURI(..),
  newToplevelURI,
  withToplevelURI,
  URIHideOptions(..),

  DirectoryHandle(..),
  withDirectoryHandle,

  MakeURIDirs(..),
  DirectoryVisitOptions(..),
  DirectoryVisitCallback,
  DirectoryVisitResult(..),
  FindDirectoryKind(..),

  XferOptions(..),
  XferProgressStatus(..),
  XferOverwriteMode(..),
  XferOverwriteAction(..),
  XferErrorMode(..),
  XferErrorAction(..),
  XferPhase(..),
  XferProgressInfo(..),
  XferProgressCallback,
  XferErrorCallback,
  XferOverwriteCallback,
  XferDuplicateCallback,

  Cancellation(..),
  newCancellation,
  withCancellation,

  VolumeOpSuccessCallback,
  VolumeOpFailureCallback,
  CVolumeOpCallback,
  VolumeType(..),
  DeviceType(..),

  MIMEType,

  module System.Gnome.VFS.Hierarchy,

  DriveID,
  newDrive,
  withDrive,

  VolumeID,
  newVolume,
  withVolume,

  wrapVolumeMonitor,
  withVolumeMonitor

  ) where

import Control.Exception (assert)
import Control.Monad
import Control.Monad.Reader
import Data.ByteString (ByteString)
import Data.Typeable
import Data.Word (Word64)
import System.Glib.FFI
import System.Glib.Flags
{#import System.Glib.GObject#} (GObject(..),
                                GObjectClass,
                                toGObject,
                                unsafeCastGObject)
{#import System.Glib.GType#} (GType,
                              typeInstanceIsA)
{#import System.Gnome.VFS.Hierarchy#}

import System.Posix.Types (DeviceID, EpochTime)

--------------------------------------------------------------------

gTypeCast :: (GObjectClass obj, GObjectClass obj') => GType -> String
                                                   -> (obj ->  obj')
-- The usage of foreignPtrToPtr should be safe as the evaluation will only be
-- forced if the object is used afterwards
gTypeCast gtype objTypeName obj =
  case toGObject obj of
    gobj@(GObject objFPtr)
      | typeInstanceIsA ((unsafeForeignPtrToPtr.castForeignPtr) objFPtr) gtype
                  -> unsafeCastGObject gobj
      | otherwise -> error $ "Cannot cast object to " ++ objTypeName

--------------------------------------------------------------------

-- | The result of a file operation.
{# enum GnomeVFSResult as Result {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show, Typeable) #}

newtype Error = Error Result
                deriving (Show, Typeable)

-- | A handle to an open file
{# pointer *GnomeVFSHandle as Handle foreign newtype #}
withHandle (Handle cHandle) = withForeignPtr cHandle

-- | Specifies the start position for a seek operation.
{# enum GnomeVFSSeekPosition    as SeekPosition    {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}
{# enum GnomeVFSOpenMode        as OpenMode        {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}

--------------------------------------------------------------------

-- | A record type containing information about a file.
data FileInfo = FileInfo {
  fileInfoName        :: Maybe String,            -- ^ the name of the file,
                                                  --   without the path
  fileInfoType        :: Maybe FileType,          -- ^ the type of the file;
                                                  --   i.e. regular, directory,
                                                  --   block-device, etc.
  fileInfoPermissions :: Maybe [FilePermissions], -- ^ the permissions for the
                                                  --   file
  fileInfoFlags       :: Maybe [FileFlags],       -- ^ flags providing
                                                  --   additional information
                                                  --   about the file
  fileInfoDevice      :: Maybe DeviceID,          -- ^ the device the file
                                                  --   resides on
  fileInfoInode       :: Maybe InodeNumber,       -- ^ the inode number of the
                                                  --   file
  fileInfoLinkCount   :: Maybe Int,               -- ^ the total number of
                                                  --   hard links to the file
  fileInfoIDs         :: Maybe IDs,               -- ^ the user and group IDs
                                                  --   owning the file
  fileInfoSize        :: Maybe FileSize,          -- ^ the size of the file in
                                                  --   bytes
  fileInfoBlockCount  :: Maybe FileSize,          -- ^ the size of the file in
                                                  --   filesystem blocks
  fileInfoIOBlockSize :: Maybe FileSize,          -- ^ the optimal buffer size
                                                  --   for reading from and
                                                  --   writing to the file
  fileInfoATime       :: Maybe EpochTime,         -- ^ the time of last access
  fileInfoMTime       :: Maybe EpochTime,         -- ^ the time of last modification
  fileInfoCTime       :: Maybe EpochTime,         -- ^ the time of last attribute modification
  fileInfoSymlinkName :: Maybe String,            -- ^ the location this
                                                  --   symlink points to, if
                                                  --   @fileInfoFlags@ contains 'FileFlagsSymlink'
  fileInfoMIMEType    :: Maybe MIMEType           -- ^ the MIME-type of the
                                                  --   file
  } deriving (Eq, Show)

{# enum GnomeVFSFileInfoFields  as FileInfoFields  {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}

-- | Options for reading information from a file.
{# enum GnomeVFSFileInfoOptions as FileInfoOptions {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}

-- | Flags specifying additional information about a file.
{# enum GnomeVFSFileFlags       as FileFlags       {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}

-- | Flags specifying the attributes of a file that should be changed.
{# enum GnomeVFSSetFileInfoMask as SetFileInfoMask {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}

-- | Identifies the type of a file.
{# enum GnomeVFSFileType        as FileType        {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}

instance Flags FileInfoOptions
instance Flags FileInfoFields
instance Flags FileFlags
instance Flags SetFileInfoMask

-- | An integral type wide enough to hold the size of a file.
type FileSize        = Word64

-- | An integral type wide enough to hold an offset into a file.
type FileOffset      = Word64

-- | An integral type wide enough to hold the inode number of a file.
type InodeNumber     = Word64

-- | A pair holding the user ID and group ID of a file owner.
type IDs             = (Int, Int)

-- | UNIX-like permissions for a file.
data FilePermissions = PermSUID              -- ^ the set-user-ID bit
                     | PermSGID              -- ^ the set-group-ID bit
                     | PermSticky            -- ^ the \"sticky\" bit
                     | PermUserRead          -- ^ owner read permission
                     | PermUserWrite         -- ^ owner write permission
                     | PermUserExec          -- ^ owner execute permission
                     | PermUserAll           -- ^ equivalent to
                                             --   @['PermUserRead', 'PermUserWrite', 'PermUserExec']@
                     | PermGroupRead         -- ^ group read permission
                     | PermGroupWrite        -- ^ group write permission
                     | PermGroupExec         -- ^ group execute permission
                     | PermGroupAll          -- ^ equivalent to
                                             --   @['PermGroupRead', 'PermGroupWrite', 'PermGroupExec']@
                     | PermOtherRead         -- ^ world read permission
                     | PermOtherWrite        -- ^ world write permission
                     | PermOtherExec         -- ^ world execute permission
                     | PermOtherAll          -- ^ equivalent to
                                             --   @['PermOtherRead', 'PermOtherWrite', 'PermOtherExec']@
                     | PermAccessReadable    -- ^ readable by the current process
                     | PermAccessWritable    -- ^ writable by the current process
                     | PermAccessExecutable  -- ^ executable by the current process
                       deriving (Eq, Bounded, Show)
instance Flags FilePermissions
instance Enum FilePermissions where
    fromEnum PermSUID             =   2048
    fromEnum PermSGID             =   1024
    fromEnum PermSticky           =    512
    fromEnum PermUserRead         =    256
    fromEnum PermUserWrite        =    128
    fromEnum PermUserExec         =     64
    fromEnum PermUserAll          =    448
    fromEnum PermGroupRead        =     32
    fromEnum PermGroupWrite       =     16
    fromEnum PermGroupExec        =      8
    fromEnum PermGroupAll         =     56
    fromEnum PermOtherRead        =      4
    fromEnum PermOtherWrite       =      2
    fromEnum PermOtherExec        =      1
    fromEnum PermOtherAll         =      7
    fromEnum PermAccessReadable   =  65536
    fromEnum PermAccessWritable   = 131072
    fromEnum PermAccessExecutable = 262144

    toEnum   2048 = PermSUID
    toEnum   1024 = PermSGID
    toEnum    512 = PermSticky
    toEnum    256 = PermUserRead
    toEnum    128 = PermUserWrite
    toEnum     64 = PermUserExec
    toEnum    448 = PermUserAll
    toEnum     32 = PermGroupRead
    toEnum     16 = PermGroupWrite
    toEnum      8 = PermGroupExec
    toEnum     56 = PermGroupAll
    toEnum      4 = PermOtherRead
    toEnum      2 = PermOtherWrite
    toEnum      1 = PermOtherExec
    toEnum      7 = PermOtherAll
    toEnum  65536 = PermAccessReadable
    toEnum 131072 = PermAccessWritable
    toEnum 262144 = PermAccessExecutable

    toEnum unmatched = error ("FilePermissions.toEnum: Cannot match " ++ show unmatched)

--------------------------------------------------------------------

-- | A 'URI' is a semi-textual representation of a uniform
--   resource identifier. It contains the information about a resource
--   location encoded as canononicalized text, but also holds extra
--   information about the context in which the URI is used.
{# pointer *GnomeVFSURI as URI foreign newtype #}

newURI :: Ptr URI
       -> IO URI
newURI cURI | cURI /= nullPtr =
    liftM URI $ newForeignPtr cURI cURIFinalizer
wrapURI :: Ptr URI
        -> IO URI
wrapURI cURI | cURI /= nullPtr =
    liftM URI $ newForeignPtr_ cURI
foreign import ccall "&gnome_vfs_uri_unref"
  cURIFinalizer :: FunPtr (Ptr URI -> IO ())

withURI (URI cURI) = withForeignPtr cURI

-- | The toplevel URI element used to access resources stored on a
--   remote server.
{# pointer *GnomeVFSToplevelURI as ToplevelURI foreign newtype #}
withToplevelURI (ToplevelURI cToplevelURI) = withForeignPtr cToplevelURI
newToplevelURI :: Ptr ToplevelURI
               -> IO ToplevelURI
newToplevelURI cToplevelURI = liftM ToplevelURI $ newForeignPtr_ cToplevelURI

-- | Flags specifying which fields of a 'URI' should be hidden when
--   converted to a string using 'uriToString'.
{# enum GnomeVFSURIHideOptions as URIHideOptions {
        GNOME_VFS_URI_HIDE_NONE as URIHideNone,
        GNOME_VFS_URI_HIDE_USER_NAME as URIHideUserName,
        GNOME_VFS_URI_HIDE_PASSWORD as URIHidePassword,
        GNOME_VFS_URI_HIDE_HOST_NAME as URIHideHostName,
        GNOME_VFS_URI_HIDE_HOST_PORT as URIHideHostPort,
        GNOME_VFS_URI_HIDE_TOPLEVEL_METHOD as URIHideToplevelMethod,
        GNOME_VFS_URI_HIDE_FRAGMENT_IDENTIFIER as URIHideFragmentIdentifier
        } deriving (Eq, Bounded, Show) #}
instance Flags URIHideOptions

-- | A string that can be passed to 'uriFromString' to create a valid
--   'URI'.
type TextURI = String

--------------------------------------------------------------------

-- | A handle to an open directory.
{# pointer *GnomeVFSDirectoryHandle as DirectoryHandle foreign newtype #}
withDirectoryHandle (DirectoryHandle cDirectoryHandle) = withForeignPtr cDirectoryHandle

-- | Options controlling the way in which a directories are visited.
{# enum GnomeVFSDirectoryVisitOptions as DirectoryVisitOptions {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}
instance Flags DirectoryVisitOptions

-- | A callback that will be called for each entry when passed to
--   'directoryVisit', 'directoryVisitURI', 'directoryVisitFiles', or
--   'directoryVisitFilesAtURI'.
type DirectoryVisitCallback =  String                  -- ^ the path of the visited file, relative to the base directory
                            -> FileInfo                -- ^ the 'FileInfo' for the visited file
                            -> Bool                    -- ^ 'True' if returning 'DirectoryVisitRecurse' will cause a loop
                            -> IO DirectoryVisitResult -- ^ the next action to be taken

-- | An enumerated value that must be returned from a
--   'DirectoryVisitCallback'. The 'directoryVisit' and related
--   functions will perform the action specified.
data DirectoryVisitResult = DirectoryVisitStop     -- ^ stop visiting files
                          | DirectoryVisitContinue -- ^ continue as normal
                          | DirectoryVisitRecurse  -- ^ recursively visit the current entry
                            deriving (Eq, Enum)

-- | Specifies which kind of directory 'findDirectory' should look for.
{# enum GnomeVFSFindDirectoryKind as FindDirectoryKind {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}

--------------------------------------------------------------------

-- | Flags that may be passed to 'makeURIFromInputWithDirs'. If the
--   path passed is non-absolute (i.e., a relative path), the
--   directories specified will be searched as well.
{# enum GnomeVFSMakeURIDirs as MakeURIDirs {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}
instance Flags MakeURIDirs

--------------------------------------------------------------------

-- | A handle to a file-system monitor.
newtype MonitorHandle = MonitorHandle (ForeignPtr MonitorHandle, {# type GnomeVFSMonitorCallback #})
withMonitorHandle (MonitorHandle (monitorHandleForeignPtr, _)) = withForeignPtr monitorHandleForeignPtr

-- | A callback that must be passed to 'monitorAdd'.  It will be
--   called any time a file or directory is changed.
type MonitorCallback =  MonitorHandle    -- ^ the handle to a filesystem monitor
                     -> TextURI          -- ^ the URI being monitored
                     -> TextURI          -- ^ the actual file that was modified
                     -> MonitorEventType -- ^ the event that occured
                     -> IO ()

-- | The type of filesystem object that is to be monitored.
{# enum GnomeVFSMonitorType      as MonitorType      {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}

-- | The type of event that caused a 'MonitorCallback' to be called.
{# enum GnomeVFSMonitorEventType as MonitorEventType {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}
wrapMonitorHandle :: (Ptr MonitorHandle, {# type GnomeVFSMonitorCallback #})
                  -> IO MonitorHandle
wrapMonitorHandle (cMonitorHandle, cMonitorCallback) =
    do monitorHandleForeignPtr <- newForeignPtr_ cMonitorHandle
       return $ MonitorHandle (monitorHandleForeignPtr, cMonitorCallback)

--------------------------------------------------------------------

-- | Options controlling how the 'System.Gnome.VFS.Xfer.xferURI' and related functions behave.
{# enum GnomeVFSXferOptions         as XferOptions         {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Bounded, Show) #}
instance Flags XferOptions

{# enum GnomeVFSXferProgressStatus  as XferProgressStatus  {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}
{# enum GnomeVFSXferOverwriteMode   as XferOverwriteMode   {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}
{# enum GnomeVFSXferOverwriteAction as XferOverwriteAction {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}
{# enum GnomeVFSXferErrorMode       as XferErrorMode       {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}
{# enum GnomeVFSXferErrorAction     as XferErrorAction     {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}
{# enum GnomeVFSXferPhase           as XferPhase           {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}

data XferProgressInfo = XferProgressInfo {
    xferProgressInfoVFSStatus        :: Result,       -- ^ current VFS status
    xferProgressInfoPhase            :: XferPhase,    -- ^ phase of the transfer
    xferProgressInfoSourceName       :: Maybe String, -- ^ currently transferring source URI
    xferProgressInfoTargetName       :: Maybe String, -- ^ currently transferring target URI
    xferProgressInfoFileIndex        :: Word,         -- ^ index of the file currently being transferred
    xferProgressInfoFilesTotal       :: Word,         -- ^ total number of files being transferred
    xferProgressInfoBytesTotal       :: FileSize,     -- ^ total size of all files in bytes
    xferProgressInfoFileSize         :: FileSize,     -- ^ size of the file currently being transferred
    xferProgressInfoBytesCopied      :: FileSize,     -- ^ number of bytes already transferred in the current file
    xferProgressInfoTotalBytesCopied :: FileSize,     -- ^ total number of bytes already transferred
    xferProgressInfoTopLevelItem     :: Bool          -- ^ 'True' if the file being transferred is a top-level item;
                                                      --   'False' if it is inside a directory
    } deriving (Eq)

-- | The type of the first callback that is passed to
--   'System.Gnome.VFS.Xfer.xferURI' and related functions. This
--   callback will be called periodically during transfers that are
--   progressing normally.
type XferProgressCallback  =  XferProgressInfo -- ^ @info@ - information about the progress of the current transfer
                           -> IO Bool          -- ^ return 'Prelude.False' to abort the transfer, 'Prelude.True' otherwise.

-- | The type of the second callback that is passed to
--   'System.Gnome.VFS.Xfer.xferURI'. This callback will be called
--   whenever an error occurs.
type XferErrorCallback     =  XferProgressInfo   -- ^ @info@ - information about the progress of the current transfer
                           -> IO XferErrorAction -- ^ the action to be performed in response to the error

-- | The type of the third callback that is passed to
--   'System.Gnome.VFS.Xfer.xferURI'. This callback will be called
--   when a file would be overwritten.
type XferOverwriteCallback =  XferProgressInfo       -- ^ @info@ - information about the progress of the current transfer
                           -> IO XferOverwriteAction -- ^ the action to be performed when the target file already exists

-- | The type of the fourth callback that is passed to
--   'System.Gnome.VFS.Xfer.xferURI'. This callback will be called
--   when a duplicate filename is found.
type XferDuplicateCallback =  XferProgressInfo   -- ^ @info@ - information about the progress of the current transfer
                           -> String             -- ^ @duplicateName@ - the name of the target file
                           -> Int                -- ^ @duplicateCount@ - the number of duplicates that exist
                           -> IO (Maybe String)  -- ^ the new filename that should be used, or 'Prelude.Nothing' to abort.

--------------------------------------------------------------------

-- | An object that can be used for signalling cancellation of an
--   operation.
{# pointer *GnomeVFSCancellation as Cancellation foreign newtype #}

newCancellation :: Ptr Cancellation
                -> IO Cancellation
newCancellation cCancellationPtr | cCancellationPtr /= nullPtr =
    liftM Cancellation $ newForeignPtr cCancellationPtr cancellationFinalizer
foreign import ccall unsafe "&gnome_vfs_cancellation_destroy"
  cancellationFinalizer :: FunPtr (Ptr Cancellation -> IO ())
withCancellation (Cancellation cCancellation) = withForeignPtr cCancellation

--------------------------------------------------------------------

withVolume (Volume cVolume) = withForeignPtr cVolume
newVolume :: Ptr Volume
          -> IO Volume
newVolume cVolume | cVolume /= nullPtr =
   liftM Volume $ newForeignPtr cVolume volumeFinalizer
foreign import ccall unsafe "&gnome_vfs_volume_unref"
  volumeFinalizer :: FunPtr (Ptr Volume -> IO ())

-- | An action to be performed when a volume operation completes successfully.
type VolumeOpSuccessCallback = IO ()
-- | An action to be performed when a volume operation fails.
type VolumeOpFailureCallback =  String
                             -> String
                             -> IO ()

-- | Identifies the device type of a 'Volume' or 'Drive'.
{#enum GnomeVFSDeviceType as DeviceType {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}
-- | Identifies the type of a 'Volume'.
{#enum GnomeVFSVolumeType as VolumeType {underscoreToCase} with prefix = "GNOME_VFS" deriving (Eq, Show) #}

type CVolumeOpCallback =  {# type gboolean #}
                       -> CString
                       -> CString
                       -> Ptr ()
                       -> IO ()

--------------------------------------------------------------------

-- | Identifies a 'Drive'
type DriveID = {# type gulong #}

withDrive (Drive cDrive) = withForeignPtr cDrive
newDrive :: Ptr Drive
          -> IO Drive
newDrive cDrive | cDrive /= nullPtr =
   liftM Drive $ newForeignPtr cDrive driveFinalizer
foreign import ccall unsafe "&gnome_vfs_drive_unref"
  driveFinalizer :: FunPtr (Ptr Drive -> IO ())

--------------------------------------------------------------------

-- | Identifies a 'Volume'.
type VolumeID = {# type gulong #}

withVolumeMonitor (VolumeMonitor cVolumeMonitor) = withForeignPtr cVolumeMonitor
wrapVolumeMonitor :: Ptr VolumeMonitor
                  -> IO VolumeMonitor
wrapVolumeMonitor cVolumeMonitor | cVolumeMonitor /= nullPtr =
   liftM VolumeMonitor $ newForeignPtr_ cVolumeMonitor

--------------------------------------------------------------------

-- | A string that will be treated as a MIME-type.
type MIMEType = String