Make `unsafePerformIO` a qualified import.

{-# LANGUAGE CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables #-}
module Graphics.UI.FLTK.LowLevel.FL
    (
     Option(..),
     run,
     check,
     ready,
     option,
     addAwakeHandler,
     getAwakeHandler_,
     display,
     ownColormap,
     getSystemColors,
     foreground,
     background,
     background2,
     setScheme,
     isScheme,
     setFirstWindow,
     nextWindow,
     setGrab,
     getMouse,
     eventStates,
     extract,
     extractEventStates,
     handle,
     handle_,
     belowmouse,
     setBelowmouse,
     setPushed,
     setFocus,
     setHandler,
     paste,
     toRectangle,
     fromRectangle,
     screenBounds,
     screenDPI,
     screenWorkArea,
     setColorRgb,
     toAttribute,
     release,
     setVisibleFocus,
     visibleFocus,
     setDndTextOps,
     dndTextOps,
     deleteWidget,
     doWidgetDeletion,
     watchWidgetPointer,
     releaseWidgetPointer,
     clearWidgetPointer,
     version,
     help,
     visual,
#if !defined(__APPLE__)
     glVisual,
     glVisualWithAlist,
#endif
     scheme,
     wait,
     setWait,
     readqueue,
     addTimeout,
     repeatTimeout,
     hasTimeout,
     removeTimeout,
     addCheck,
     hasCheck,
     removeCheck,
     addIdle,
     hasIdle,
     removeIdle,
     damage,
     redraw,
     flush,
     firstWindow,
     modal,
     grab,
     getKey,
     compose,
     composeReset,
     testShortcut,
     enableIm,
     disableIm,
     pushed,
     focus,
     copy,
     copyWithDestination,
     pasteWithSource,
     dnd,
     x,
     y,
     w,
     h,
     screenCount,
     setColor,
     getColor,
     getColorRgb,
#if !defined(__APPLE__)
     removeFromColormap,
#endif
     -- * Box
     BoxtypeSpec,
     getBoxtype,
     setBoxtype,
     boxDx,
     boxDy,
     boxDw,
     boxDh,
     drawBoxActive,
     -- * Fonts
     getFontName,
     getFont,
     getFontSizes,
     setFontByString,
     setFontByFont,
     setFonts,
     setFontsWithString,
     -- * Events
     event,
     eventShift,
     eventCtrl,
     eventCommand,
     eventAlt,
     eventButtons,
     eventButton1,
     eventButton2,
     eventButton3,
     eventX,
     eventY,
     eventXRoot,
     eventYRoot,
     eventDx,
     eventDy,
     eventClicks,
     setEventClicks,
     eventIsClick,
     setEventIsClick,
     eventButton,
     eventState,
     containsEventState,
     eventKey,
     eventOriginalKey,
     eventKeyPressed,
     eventInsideRegion,
     eventInsideWidget,
     eventDispatch,
     setEventDispatch,
     eventText,
     eventLength,
    )
where
#include "Fl_C.h"
import C2HS hiding (cFromEnum, cToBool,cToEnum)
import Data.IORef
import Foreign.C.Types
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.LowLevel.Utils
import Graphics.UI.FLTK.LowLevel.Hierarchy hiding (
                                                   setVisibleFocus,
                                                   handle,
                                                   redraw,
                                                   flush,
                                                   testShortcut,
                                                   copy,
                                                   setColor,
                                                   getColor,
                                                   focus
                                                  )
import Graphics.UI.FLTK.LowLevel.Dispatch
import qualified System.IO.Unsafe as Unsafe (unsafePerformIO)
#c
 enum Option {
   ArrowFocus = OPTION_ARROW_FOCUS,
   VisibleFocus = OPTION_VISIBLE_FOCUS,
   DndText = OPTION_DND_TEXT,
   ShowTooltips = OPTION_SHOW_TOOLTIPS,
   Last = OPTION_LAST
 };
#endc

{#enum Option {} deriving (Show) #}

ptrToGlobalEventHandler :: IORef (FunPtr GlobalEventHandlerPrim)
ptrToGlobalEventHandler = Unsafe.unsafePerformIO $ do
                            initialHandler <- toGlobalEventHandlerPrim (\_ -> return (-1))
                            newIORef initialHandler

type EventDispatchPrim = (CInt ->
                          Ptr () ->
                          IO CInt)
foreign import ccall "wrapper"
        wrapEventDispatchPrim :: EventDispatchPrim ->
                                 IO (FunPtr EventDispatchPrim)
foreign import ccall "dynamic"
        unwrapEventDispatchPrim :: FunPtr EventDispatchPrim -> EventDispatchPrim

run :: IO Int
run = {#call Fl_run as fl_run #} >>= return . fromIntegral

check :: IO Int
check = {#call Fl_check as fl_check #} >>= return . fromIntegral

ready :: IO Int
ready = {#call Fl_ready as fl_ready #} >>= return . fromIntegral

option :: Option -> IO Int
option o = {#call Fl_option as fl_option #} (cFromEnum o) >>= return . fromIntegral

unsafeToCallbackPrim :: GlobalCallback -> FunPtr CallbackPrim
unsafeToCallbackPrim = (Unsafe.unsafePerformIO) . toGlobalCallbackPrim

{# fun Fl_add_awake_handler_ as addAwakeHandler'
  {id `FunPtr CallbackPrim', id `(Ptr ())'} -> `Int' #}
addAwakeHandler :: GlobalCallback -> IO Int
addAwakeHandler awakeHandler =
    do
      callbackPtr <-  toGlobalCallbackPrim awakeHandler
      addAwakeHandler' callbackPtr nullPtr

{# fun Fl_get_awake_handler_ as getAwakeHandler_'
  {id `Ptr (FunPtr CallbackPrim)', id `Ptr (Ptr ())'} -> `Int' #}
getAwakeHandler_ :: IO GlobalCallback
getAwakeHandler_ =
    alloca $ \ptrToFunPtr ->
        alloca $ \ptrToUD -> do
          _ <- getAwakeHandler_' ptrToFunPtr ptrToUD
          funPtr <- peek ptrToFunPtr
          return $ unwrapGlobalCallbackPtr $ castFunPtr funPtr

{# fun Fl_version as version
  {} -> `Double' #}
{# fun Fl_help as help
  {} -> `String' #}

display :: String -> IO ()
display text = withCString text $ \str -> {#call Fl_display as fl_display #} str
{# fun Fl_visual as visual
  {cFromEnum `Mode'} -> `Int' #}
#if !defined(__APPLE__)
{# fun Fl_gl_visual as glVisual
  {cFromEnum `Mode'} -> `Int' #}
{# fun Fl_gl_visual_with_alist as glVisualWithAlist
  {cFromEnum `Mode', id `Ptr CInt'} -> `Int' #}
#endif

ownColormap :: IO ()
ownColormap = {#call Fl_own_colormap as fl_own_colormap #}

getSystemColors :: IO ()
getSystemColors = {#call Fl_get_system_colors as fl_get_system_colors #}

foreground :: RGB -> IO ()
foreground (r,g,b) = {#call Fl_foreground as fl_foreground #}
                    (fromIntegral r)
                    (fromIntegral g)
                    (fromIntegral b)
background :: RGB -> IO ()
background (r,g,b) = {#call Fl_background as fl_background #}
                    (fromIntegral r)
                    (fromIntegral g)
                    (fromIntegral b)
background2 :: RGB -> IO ()
background2 (r,g,b) = {#call Fl_background2 as fl_background2 #}
                    (fromIntegral r)
                    (fromIntegral g)
                    (fromIntegral b)
-- | In the function below marked `pure`, c2hs uses `unsafePerformIO` unqualified causing
-- | a compile error if it imported qualifed. This is a workaround.
unsafePerformIO :: IO a -> a
unsafePerformIO = Unsafe.unsafePerformIO
{# fun pure Fl_scheme as scheme
  {} -> `String' #}
setScheme :: String -> IO Int
setScheme sch = withCString sch $ \str -> {#call Fl_set_scheme as fl_set_scheme #} str >>= return . fromIntegral
isScheme :: String -> IO Bool
isScheme sch = withCString sch $ \str -> {#call Fl_is_scheme as fl_is_scheme #} str >>= return . toBool
{# fun Fl_wait as wait
       {  } -> `Int' #}
{# fun Fl_set_wait as setWait
       { `Double' } -> `Double' #}
{# fun Fl_readqueue as readqueue
       {  } -> `Ref Widget' unsafeToRef #}
{# fun Fl_add_timeout as addTimeout
       { `Double', unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_repeat_timeout as repeatTimeout
      { `Double',unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_has_timeout as hasTimeout
       { unsafeToCallbackPrim `GlobalCallback' } -> `Int' #}
{# fun Fl_remove_timeout as removeTimeout
       { unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_add_check as addCheck
       { unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_has_check as hasCheck
       { unsafeToCallbackPrim `GlobalCallback' } -> `Int' #}
{# fun Fl_remove_check as removeCheck
       { unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_add_idle as addIdle
       { unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_has_idle as hasIdle
       { unsafeToCallbackPrim `GlobalCallback' } -> `Int' #}
{# fun Fl_remove_idle as removeIdle
       { unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_damage as damage
       {  } -> `Int' #}
{# fun Fl_redraw as redraw
       {  } -> `()' supressWarningAboutRes #}
{# fun Fl_flush as flush
       {  } -> `()' supressWarningAboutRes #}
{# fun Fl_first_window as firstWindow
       {  } -> `Ref Window' unsafeToRef #}
{# fun Fl_set_first_window as setFirstWindow'
       { id `Ptr ()' } -> `()' supressWarningAboutRes #}
setFirstWindow :: (Parent a Window) => Ref a -> IO ()
setFirstWindow wp =
    withRef wp setFirstWindow'
{# fun Fl_next_window as nextWindow'
       { id `Ptr ()' } -> `Ref Window' unsafeToRef #}
nextWindow :: (Parent a Window) => Ref a -> IO (Ref Window)
nextWindow currWindow =
    withRef currWindow nextWindow'
{# fun Fl_modal as modal
       {  } -> `Ref Window' unsafeToRef #}
{# fun Fl_grab as grab
       {  } -> `Ref Window' unsafeToRef #}
{# fun Fl_set_grab as setGrab'
       { id `Ptr ()' } -> `()' supressWarningAboutRes #}
setGrab :: (Parent a Window) => Ref a -> IO ()
setGrab wp = withRef wp setGrab'
{# fun Fl_event as event
       {  } -> `Event' cToEnum #}
{# fun Fl_event_x as eventX
       {  } -> `Int'#}
{# fun Fl_event_y as eventY
       {  } -> `Int'#}
{# fun Fl_event_x_root as eventXRoot
       {  } -> `Int' #}
{# fun Fl_event_y_root as eventYRoot
       {  } -> `Int' #}
{# fun Fl_event_dx as eventDx
       {  } -> `Int' #}
{# fun Fl_event_dy as eventDy
       {  } ->  `Int' #}
{# fun Fl_get_mouse as getMouse'
   {
     alloca- `Int' peekIntConv* ,
     alloca- `Int' peekIntConv*
   } -> `()' #}
getMouse :: IO Position
getMouse = do
  (x_pos,y_pos) <- getMouse'
  return $ (Position (X x_pos) (Y y_pos))
{# fun Fl_event_clicks as eventClicks
       {  } -> `Int'#}
{# fun Fl_set_event_clicks as setEventClicks
       { `Int' } -> `()' supressWarningAboutRes #}
{# fun Fl_event_is_click as eventIsClick
       {  } -> `Bool' toBool #}
{# fun Fl_set_event_is_click as setEventIsClick
       { `Int' } -> `()' supressWarningAboutRes #}
{# fun Fl_event_button as eventButton
       {  } -> `MouseButton' cToEnum #}
eventStates :: [EventState]
eventStates = [
               Kb_ShiftState,
               Kb_CapsLockState,
               Kb_CtrlState,
               Kb_AltState,
               Kb_NumLockState,
               Kb_MetaState,
               Kb_ScrollLockState,
               Mouse_Button1State,
               Mouse_Button2State,
               Mouse_Button3State
              ]
extractEventStates :: CInt -> [EventState]
extractEventStates = extract eventStates
-- foldModifiers :: [KeyboardCode] -> CInt
-- foldModifiers codes =
--     let validKeysyms = map cFromEnum (filter (\c -> c `elem` validKeyboardStates) codes)
--     in
--       case validKeysyms of
--         [] -> (-1)
--         (k:ks) -> foldl (\accum k' -> accum .&. k') k ks
{# fun Fl_event_state as eventState
       {  } -> `[EventState]' extractEventStates #}
{# fun Fl_contains_event_state as containsEventState
       {cFromEnum `EventState' } -> `Bool' toBool #}
{# fun Fl_event_key as eventKey
       {  } -> `KeyboardCode' cToEnum #}
{# fun Fl_event_original_key as eventOriginalKey
       {  } -> `KeyboardCode' cToEnum #}
{# fun Fl_event_key_pressed as eventKeyPressed
       {cFromEnum `KeyboardCode' } -> `Bool' toBool #}
{# fun Fl_get_key as getKey
       {cFromEnum `KeyboardCode' } -> `Bool' toBool #}
{# fun Fl_event_text as eventText
       {  } -> `String' #}
{# fun Fl_event_length as eventLength
       {  } -> `Int' #}
{# fun Fl_compose as compose
       { alloca- `Int' peekIntConv* } -> `Bool' toBool #}
{# fun Fl_compose_reset as composeReset
       {  } -> `()' supressWarningAboutRes #}
{# fun Fl_event_inside_region as eventInsideRegion'
       { `Int',`Int',`Int',`Int' } -> `Int' #}
eventInsideRegion :: Rectangle -> IO Event
eventInsideRegion (Rectangle
                   (Position
                    (X x_pos)
                    (Y y_pos))
                   (Size
                    (Width width)
                    (Height height))) =
    do
      eventNum <- eventInsideRegion' x_pos y_pos width height
      return $ toEnum eventNum
{# fun Fl_event_inside_widget as eventInsideWidget'
       { id `Ptr ()' } -> `Int' #}
eventInsideWidget :: (Parent a Widget) => Ref a -> IO Event
eventInsideWidget wp =
    withRef wp  (\ptr -> do
                      eventNum <- eventInsideWidget' (castPtr ptr)
                      return $ toEnum eventNum)
{# fun Fl_test_shortcut as testShortcut
       { id `FlShortcut' } -> `Bool' toBool #}
{# fun Fl_enable_im as enableIm
       {} -> `()' supressWarningAboutRes #}
{# fun Fl_disable_im as disableIm
       {} -> `()' supressWarningAboutRes #}
{# fun Fl_handle as handle'
       { `Int',id `Ptr ()' } -> `Int' #}
handle :: (Parent a Window) =>  Event -> Ref a -> IO Int
handle e wp =
    withRef wp (handle' (cFromEnum e))
{# fun Fl_handle_ as handle_'
       { `Int',id `Ptr ()' } -> `Int' #}
handle_ :: (Parent a Window) =>  Event -> Ref a -> IO Int
handle_ e wp =
    withRef wp (handle_' (cFromEnum e))
{# fun Fl_belowmouse as belowmouse
       {  } -> `Ref Widget' unsafeToRef #}
{# fun Fl_set_belowmouse as setBelowmouse'
       { id `Ptr ()' } -> `()' supressWarningAboutRes #}
setBelowmouse :: (Parent a Widget) => Ref a -> IO ()
setBelowmouse wp = withRef wp setBelowmouse'
{# fun Fl_pushed as pushed
       {  } -> `Ref Widget' unsafeToRef #}
{# fun Fl_set_pushed as setPushed'
       { id `Ptr ()' } -> `()' supressWarningAboutRes #}
setPushed :: (Parent a Widget) => Ref a -> IO ()
setPushed wp = withRef wp setPushed'
{# fun Fl_focus as focus
       {  } -> `Ref Widget' unsafeToRef #}
{# fun Fl_set_focus as setFocus'
       { id `Ptr ()' } -> `()' supressWarningAboutRes #}
setFocus :: (Parent a Widget) => Ref a -> IO ()
setFocus wp = withRef wp setFocus'
{# fun Fl_add_handler as addHandler'
       { id `FunPtr GlobalEventHandlerPrim' } -> `()' supressWarningAboutRes #}
{# fun Fl_remove_handler as removeHandler'
       { id `FunPtr GlobalEventHandlerPrim' } -> `()' supressWarningAboutRes #}
setHandler :: GlobalEventHandlerF -> IO ()
setHandler eh = do
  newGlobalEventHandler <- toGlobalEventHandlerPrim eh
  curr <- do
    old <- readIORef ptrToGlobalEventHandler
    writeIORef ptrToGlobalEventHandler newGlobalEventHandler
    return old
  removeHandler' curr
  addHandler' newGlobalEventHandler

{# fun Fl_set_event_dispatch as setEventDispatch'
       { id `Ptr (FunPtr EventDispatchPrim)' } -> `()' supressWarningAboutRes #}
{# fun Fl_event_dispatch as eventDispatch'
       {  } -> `FunPtr EventDispatchPrim' id #}
eventDispatch :: (Parent a Widget) => IO (Event -> Ref a -> IO (Int))
eventDispatch =
    do
      funPtr <- eventDispatch'
      return (\e window ->
                  withRef
                   window
                    (\ptr ->
                         let eventNum = fromIntegral (fromEnum e)
                             fun = unwrapEventDispatchPrim funPtr
                         in fun eventNum (castPtr ptr) >>=
                            return . fromIntegral
                    )
             )

setEventDispatch :: (Parent a Widget) => (Event -> Ref a -> IO Int) -> IO ()
setEventDispatch ed = do
    do
      let toPrim = (\e ptr ->
                      let eventEnum = toEnum $ fromIntegral e
                      in do
                      obj <- toRef ptr
                      result <- ed eventEnum obj
                      return $ fromIntegral result
                    )
      callbackPtr <-  wrapEventDispatchPrim toPrim
      ptrToCallbackPtr <- new callbackPtr
      poke ptrToCallbackPtr callbackPtr
      setEventDispatch' ptrToCallbackPtr
{# fun Fl_copy as copy
       { `String',`Int' } -> `()' supressWarningAboutRes #}
{# fun Fl_copy_with_destination as copyWithDestination
       { `String',`Int',`Int' } -> `()' supressWarningAboutRes #}
{# fun Fl_paste_with_source as pasteWithSource
       { id `Ptr ()',`Int' } -> `()' supressWarningAboutRes #}
paste :: (Parent a Widget) => Ref a -> Maybe Int -> IO ()
paste widget (Just clipboard) = withRef widget ((flip pasteWithSource) clipboard)
paste widget Nothing          = withRef widget ((flip pasteWithSource) 0)

{# fun Fl_dnd as dnd
       {  } -> `Int' #}
{# fun Fl_x as x
       {  } -> `Int' #}
{# fun Fl_y as y
       {  } -> `Int' #}
{# fun Fl_w as w
       {  } -> `Int' #}
{# fun Fl_h as h
       {  } -> `Int' #}
{# fun Fl_screen_count as screenCount
       {  } -> `Int' #}

{# fun Fl_screen_xywh as screenXYWH
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv*
       } -> `()'  #}
{# fun Fl_screen_xywh_with_mxmy as screenXYWYWithMXMY
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         `Int',
         `Int'
       } -> `()'  #}
{# fun Fl_screen_xywh_with_n as screenXYWNWithN
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         `Int'
       } -> `()'  #}
{# fun Fl_screen_xywh_with_mxmymwmh as screenXYWHWithNMXMYMWMH
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         `Int',
         `Int',
         `Int',
         `Int'
       } -> `()' #}

screenBounds :: Maybe ScreenLocation -> IO Rectangle
screenBounds location =
    case location of
      (Just (Intersect (Rectangle (Position (X x_pos) (Y y_pos)) (Size (Width width) (Height height))))) ->
          screenXYWHWithNMXMYMWMH x_pos y_pos width height >>= return . toRectangle
      (Just (ScreenPosition (Position (X x_pos) (Y y_pos)))) ->
          screenXYWYWithMXMY x_pos y_pos >>= return . toRectangle
      (Just (ScreenNumber n)) ->
          screenXYWNWithN n >>= return . toRectangle
      Nothing ->
          screenXYWH >>= return . toRectangle

{# fun Fl_screen_dpi as screenDpi'
       { alloca- `Float' peekFloatConv*,
         alloca- `Float' peekFloatConv* }
           -> `()' #}
{# fun Fl_screen_dpi_with_n as screenDpiWithN'
       { alloca- `Float' peekFloatConv*,
         alloca- `Float' peekFloatConv*,
                 `Int' }
           -> `()' #}

screenDPI :: Maybe Int -> IO DPI
screenDPI (Just n) = do
  (dpiX, dpiY) <- screenDpiWithN' n
  return $ DPI dpiX dpiY
screenDPI Nothing = do
  (dpiX, dpiY) <- screenDpi'
  return $ DPI dpiX dpiY

{# fun Fl_screen_work_area_with_mx_my as screenWorkAreaWithMXMY'
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         `Int',
         `Int'
       }
         -> `()' #}
{# fun Fl_screen_work_area_with_n as screenWorkAreaWithN'
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         `Int'
       }
        -> `()' #}
{# fun Fl_screen_work_area as screenWorkArea'
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv*
       }
        -> `()' id- #}
screenWorkArea :: Maybe ScreenLocation -> IO Rectangle
screenWorkArea location =
    case location of
      (Just (Intersect (Rectangle (Position (X x_pos) (Y y_pos)) _))) ->
          screenWorkAreaWithMXMY' x_pos y_pos >>= return . toRectangle
      (Just (ScreenPosition (Position (X x_pos) (Y y_pos)))) ->
          screenWorkAreaWithMXMY' x_pos y_pos >>= return . toRectangle
      (Just (ScreenNumber n)) ->
          screenWorkAreaWithN' n >>= return . toRectangle
      Nothing ->
          screenWorkArea' >>= return . toRectangle

setColorRgb :: Color -> Int -> Int -> Int -> IO ()
setColorRgb c r g b = {#call Fl_set_color_rgb as fl_set_color_rgb #}
                        (cFromColor c)
                        (fromIntegral r)
                        (fromIntegral g)
                        (fromIntegral b)
{# fun Fl_set_color as setColor
       { cFromColor `Color',`Int' } -> `()' supressWarningAboutRes #}
{# fun Fl_get_color as getColor
       { cFromColor `Color' } -> `Int' #}
{# fun Fl_get_color_rgb as getColorRgb
       {
         cFromColor `Color',
         alloca- `Word8' peekIntConv*,
         alloca- `Word8' peekIntConv*,
         alloca- `Word8' peekIntConv*
       } -> `()' supressWarningAboutRes #}

#if !defined(__APPLE__)
{# fun Fl_free_color as freeColor'
      { cFromColor `Color' } -> `()' supressWarningAboutRes #}
{# fun Fl_free_color_with_overlay as freeColorWithOverlay'
       { cFromColor `Color', `Int' } -> `()' supressWarningAboutRes #}
removeFromColormap :: Maybe Int -> Color -> IO ()
removeFromColormap (Just overlay) c = freeColorWithOverlay' c overlay
removeFromColormap Nothing c = freeColor' c
#endif
{# fun Fl_get_font as getFont
       { cFromFont `Font' } -> `String' #}
{# fun Fl_get_font_name_with_attributes as getFontNameWithAttributes'
       { cFromFont `Font', alloca- `Maybe FontAttribute' toAttribute* } -> `String' #}
toAttribute :: Ptr CInt -> IO (Maybe FontAttribute)
toAttribute ptr =
        do
          attributeCode <- peekIntConv ptr
          return $ cToFontAttribute attributeCode
getFontName :: Font -> IO (String, Maybe FontAttribute)
getFontName f = getFontNameWithAttributes' f
{# fun Fl_get_font_sizes as getFontSizes
       { cFromFont `Font', alloca- `Int' peekIntConv* } -> `Int' #}
{# fun Fl_set_font_by_string as setFontByString
       { cFromFont `Font',`String' } -> `()' supressWarningAboutRes #}
{# fun Fl_set_font_by_font as setFontByFont
       { cFromFont `Font',cFromFont `Font' } -> `()' supressWarningAboutRes #}
{# fun Fl_set_fonts as setFonts
       {  } -> `Font' cToFont #}
{# fun Fl_set_fonts_with_string as setFontsWithString
       { `String' } -> `Font' cToFont #}
{# fun Fl_get_boxtype as getBoxtype'
       { cFromEnum `Boxtype' } -> `FunPtr BoxDrawFPrim' id #}

getBoxtype :: Boxtype -> IO BoxDrawF
getBoxtype bt = do
  wrappedFunPtr <- getBoxtype' bt
  let boxDrawPrim = unwrapBoxDrawFPrim wrappedFunPtr
  return $ toBoxDrawF boxDrawPrim

{# fun Fl_set_boxtype as setBoxtype'
       {
         cFromEnum `Boxtype',
         id `FunPtr BoxDrawFPrim',
         `Word8',
         `Word8',
         `Word8',
         `Word8'
       } -> `()' supressWarningAboutRes #}
{# fun Fl_set_boxtype_by_boxtype as setBoxtypeByBoxtype'
       {
         cFromEnum `Boxtype',
         cFromEnum `Boxtype'
       } -> `()' supressWarningAboutRes #}

data BoxtypeSpec = FromSpec BoxDrawF Word8 Word8 Word8 Word8
                 | FromBoxtype Boxtype
setBoxtype :: Boxtype -> BoxtypeSpec -> IO ()
setBoxtype bt (FromSpec f dx dy dw dh) =
    do
      funPtr <- wrapBoxDrawFPrim (toBoxDrawFPrim f)
      setBoxtype' bt funPtr dx dy dw dh
setBoxtype bt (FromBoxtype template) =
    setBoxtypeByBoxtype' bt template

{# fun Fl_box_dx as boxDx
       { cFromEnum `Boxtype' } -> `Int' #}
{# fun Fl_box_dy as boxDy
       { cFromEnum `Boxtype' } -> `Int' #}
{# fun Fl_box_dw as boxDw
       { cFromEnum `Boxtype' } -> `Int' #}
{# fun Fl_box_dh as boxDh
       { cFromEnum `Boxtype' } -> `Int' #}
{# fun Fl_draw_box_active as drawBoxActive
       {  } -> `Bool' toBool #}
{# fun Fl_event_shift as eventShift
       {  } -> `Bool' toBool #}
{# fun Fl_event_ctrl as eventCtrl
       {  } -> `Bool' toBool #}
{# fun Fl_event_command as eventCommand
       {  } -> `Bool' toBool #}
{# fun Fl_event_alt as eventAlt
       {  } -> `Bool' toBool #}
{# fun Fl_event_buttons as eventButtons
       {  } -> `Bool' toBool #}
{# fun Fl_event_button1 as eventButton1
       {  } -> `Bool' toBool #}
{# fun Fl_event_button2 as eventButton2
       {  } -> `Bool' toBool #}
{# fun Fl_event_button3 as eventButton3
      {  } -> `Bool' toBool #}
release :: IO ()
release = {#call Fl_release as fl_release #}
setVisibleFocus :: Int -> IO ()
setVisibleFocus = {#call Fl_set_visible_focus as fl_set_visible_focus #} . fromIntegral
visibleFocus :: IO Int
visibleFocus = {#call Fl_visible_focus as fl_visible_focus #} >>= return . fromIntegral
setDndTextOps :: Bool -> IO ()
setDndTextOps =  {#call Fl_set_dnd_text_ops as fl_set_dnd_text_ops #} . fromBool
dndTextOps :: IO Option
dndTextOps = {#call Fl_dnd_text_ops as fl_dnd_text_ops #} >>= return . cToEnum
deleteWidget :: (Parent a Widget) => Ref a -> IO ()
deleteWidget wptr =
  swapRef wptr $ \ptr -> do
    {#call Fl_delete_widget as fl_delete_widget #} ptr
    return nullPtr
doWidgetDeletion :: IO ()
doWidgetDeletion = {#call Fl_do_widget_deletion as fl_do_widget_deletion #}
watchWidgetPointer :: (Parent a Widget) => Ref a -> IO ()
watchWidgetPointer wp = withRef wp {#call Fl_watch_widget_pointer as fl_Watch_widget_Pointer #}
releaseWidgetPointer :: (Parent a Widget) => Ref a -> IO ()
releaseWidgetPointer wp = withRef wp {#call Fl_release_widget_pointer as fl_release_widget_pointer #}
clearWidgetPointer :: (Parent a Widget) => Ref a -> IO ()
clearWidgetPointer wp = withRef wp {#call Fl_clear_widget_pointer as fl_Clear_Widget_Pointer #}

{-# LANGUAGE CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables #-}
module Graphics.UI.FLTK.LowLevel.FL
    (
     Option(..),
     run,
     check,
     ready,
     option,
     addAwakeHandler,
     getAwakeHandler_,
     display,
     ownColormap,
     getSystemColors,
     foreground,
     background,
     background2,
     setScheme,
     isScheme,
     setFirstWindow,
     nextWindow,
     setGrab,
     getMouse,
     eventStates,
     extract,
     extractEventStates,
     handle,
     handle_,
     belowmouse,
     setBelowmouse,
     setPushed,
     setFocus,
     setHandler,
     paste,
     toRectangle,
     fromRectangle,
     screenBounds,
     screenDPI,
     screenWorkArea,
     setColorRgb,
     toAttribute,
     release,
     setVisibleFocus,
     visibleFocus,
     setDndTextOps,
     dndTextOps,
     deleteWidget,
     doWidgetDeletion,
     watchWidgetPointer,
     releaseWidgetPointer,
     clearWidgetPointer,
     version,
     help,
     visual,
#if !defined(__APPLE__)
     glVisual,
     glVisualWithAlist,
#endif
     scheme,
     wait,
     setWait,
     readqueue,
     addTimeout,
     repeatTimeout,
     hasTimeout,
     removeTimeout,
     addCheck,
     hasCheck,
     removeCheck,
     addIdle,
     hasIdle,
     removeIdle,
     damage,
     redraw,
     flush,
     firstWindow,
     modal,
     grab,
     getKey,
     compose,
     composeReset,
     testShortcut,
     enableIm,
     disableIm,
     pushed,
     focus,
     copy,
     copyWithDestination,
     pasteWithSource,
     dnd,
     x,
     y,
     w,
     h,
     screenCount,
     setColor,
     getColor,
     getColorRgb,
#if !defined(__APPLE__)
     removeFromColormap,
#endif
     -- * Box
     BoxtypeSpec,
     getBoxtype,
     setBoxtype,
     boxDx,
     boxDy,
     boxDw,
     boxDh,
     drawBoxActive,
     -- * Fonts
     getFontName,
     getFont,
     getFontSizes,
     setFontByString,
     setFontByFont,
     setFonts,
     setFontsWithString,
     -- * Events
     event,
     eventShift,
     eventCtrl,
     eventCommand,
     eventAlt,
     eventButtons,
     eventButton1,
     eventButton2,
     eventButton3,
     eventX,
     eventY,
     eventXRoot,
     eventYRoot,
     eventDx,
     eventDy,
     eventClicks,
     setEventClicks,
     eventIsClick,
     setEventIsClick,
     eventButton,
     eventState,
     containsEventState,
     eventKey,
     eventOriginalKey,
     eventKeyPressed,
     eventInsideRegion,
     eventInsideWidget,
     eventDispatch,
     setEventDispatch,
     eventText,
     eventLength,
    )
where
#include "Fl_C.h"
import C2HS hiding (cFromEnum, cToBool,cToEnum)
import Data.IORef
import Foreign.C.Types
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.LowLevel.Utils
import Graphics.UI.FLTK.LowLevel.Hierarchy hiding (
                                                   setVisibleFocus,
                                                   handle,
                                                   redraw,
                                                   flush,
                                                   testShortcut,
                                                   copy,
                                                   setColor,
                                                   getColor,
                                                   focus
                                                  )
import Graphics.UI.FLTK.LowLevel.Dispatch
import System.IO.Unsafe (unsafePerformIO)
#c
 enum Option {
   ArrowFocus = OPTION_ARROW_FOCUS,
   VisibleFocus = OPTION_VISIBLE_FOCUS,
   DndText = OPTION_DND_TEXT,
   ShowTooltips = OPTION_SHOW_TOOLTIPS,
   Last = OPTION_LAST
 };
#endc

{#enum Option {} deriving (Show) #}

ptrToGlobalEventHandler :: IORef (FunPtr GlobalEventHandlerPrim)
ptrToGlobalEventHandler = unsafePerformIO $ do
                            initialHandler <- toGlobalEventHandlerPrim (\_ -> return (-1))
                            newIORef initialHandler

type EventDispatchPrim = (CInt ->
                          Ptr () ->
                          IO CInt)
foreign import ccall "wrapper"
        wrapEventDispatchPrim :: EventDispatchPrim ->
                                 IO (FunPtr EventDispatchPrim)
foreign import ccall "dynamic"
        unwrapEventDispatchPrim :: FunPtr EventDispatchPrim -> EventDispatchPrim

run :: IO Int
run = {#call Fl_run as fl_run #} >>= return . fromIntegral

check :: IO Int
check = {#call Fl_check as fl_check #} >>= return . fromIntegral

ready :: IO Int
ready = {#call Fl_ready as fl_ready #} >>= return . fromIntegral

option :: Option -> IO Int
option o = {#call Fl_option as fl_option #} (cFromEnum o) >>= return . fromIntegral

unsafeToCallbackPrim :: GlobalCallback -> FunPtr CallbackPrim
unsafeToCallbackPrim = unsafePerformIO . toGlobalCallbackPrim

{# fun Fl_add_awake_handler_ as addAwakeHandler'
  {id `FunPtr CallbackPrim', id `(Ptr ())'} -> `Int' #}
addAwakeHandler :: GlobalCallback -> IO Int
addAwakeHandler awakeHandler =
    do
      callbackPtr <-  toGlobalCallbackPrim awakeHandler
      addAwakeHandler' callbackPtr nullPtr

{# fun Fl_get_awake_handler_ as getAwakeHandler_'
  {id `Ptr (FunPtr CallbackPrim)', id `Ptr (Ptr ())'} -> `Int' #}
getAwakeHandler_ :: IO GlobalCallback
getAwakeHandler_ =
    alloca $ \ptrToFunPtr ->
        alloca $ \ptrToUD -> do
          _ <- getAwakeHandler_' ptrToFunPtr ptrToUD
          funPtr <- peek ptrToFunPtr
          return $ unwrapGlobalCallbackPtr $ castFunPtr funPtr

{# fun Fl_version as version
  {} -> `Double' #}
{# fun Fl_help as help
  {} -> `String' #}

display :: String -> IO ()
display text = withCString text $ \str -> {#call Fl_display as fl_display #} str
{# fun Fl_visual as visual
  {cFromEnum `Mode'} -> `Int' #}
#if !defined(__APPLE__)
{# fun Fl_gl_visual as glVisual
  {cFromEnum `Mode'} -> `Int' #}
{# fun Fl_gl_visual_with_alist as glVisualWithAlist
  {cFromEnum `Mode', id `Ptr CInt'} -> `Int' #}
#endif

ownColormap :: IO ()
ownColormap = {#call Fl_own_colormap as fl_own_colormap #}

getSystemColors :: IO ()
getSystemColors = {#call Fl_get_system_colors as fl_get_system_colors #}

foreground :: RGB -> IO ()
foreground (r,g,b) = {#call Fl_foreground as fl_foreground #}
                    (fromIntegral r)
                    (fromIntegral g)
                    (fromIntegral b)
background :: RGB -> IO ()
background (r,g,b) = {#call Fl_background as fl_background #}
                    (fromIntegral r)
                    (fromIntegral g)
                    (fromIntegral b)
background2 :: RGB -> IO ()
background2 (r,g,b) = {#call Fl_background2 as fl_background2 #}
                    (fromIntegral r)
                    (fromIntegral g)
                    (fromIntegral b)
{# fun pure Fl_scheme as scheme
  {} -> `String' #}
setScheme :: String -> IO Int
setScheme sch = withCString sch $ \str -> {#call Fl_set_scheme as fl_set_scheme #} str >>= return . fromIntegral
isScheme :: String -> IO Bool
isScheme sch = withCString sch $ \str -> {#call Fl_is_scheme as fl_is_scheme #} str >>= return . toBool
{# fun Fl_wait as wait
       {  } -> `Int' #}
{# fun Fl_set_wait as setWait
       { `Double' } -> `Double' #}
{# fun Fl_readqueue as readqueue
       {  } -> `Ref Widget' unsafeToRef #}
{# fun Fl_add_timeout as addTimeout
       { `Double', unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_repeat_timeout as repeatTimeout
      { `Double',unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_has_timeout as hasTimeout
       { unsafeToCallbackPrim `GlobalCallback' } -> `Int' #}
{# fun Fl_remove_timeout as removeTimeout
       { unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_add_check as addCheck
       { unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_has_check as hasCheck
       { unsafeToCallbackPrim `GlobalCallback' } -> `Int' #}
{# fun Fl_remove_check as removeCheck
       { unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_add_idle as addIdle
       { unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_has_idle as hasIdle
       { unsafeToCallbackPrim `GlobalCallback' } -> `Int' #}
{# fun Fl_remove_idle as removeIdle
       { unsafeToCallbackPrim `GlobalCallback' } -> `()' supressWarningAboutRes #}
{# fun Fl_damage as damage
       {  } -> `Int' #}
{# fun Fl_redraw as redraw
       {  } -> `()' supressWarningAboutRes #}
{# fun Fl_flush as flush
       {  } -> `()' supressWarningAboutRes #}
{# fun Fl_first_window as firstWindow
       {  } -> `Ref Window' unsafeToRef #}
{# fun Fl_set_first_window as setFirstWindow'
       { id `Ptr ()' } -> `()' supressWarningAboutRes #}
setFirstWindow :: (Parent a Window) => Ref a -> IO ()
setFirstWindow wp =
    withRef wp setFirstWindow'
{# fun Fl_next_window as nextWindow'
       { id `Ptr ()' } -> `Ref Window' unsafeToRef #}
nextWindow :: (Parent a Window) => Ref a -> IO (Ref Window)
nextWindow currWindow =
    withRef currWindow nextWindow'
{# fun Fl_modal as modal
       {  } -> `Ref Window' unsafeToRef #}
{# fun Fl_grab as grab
       {  } -> `Ref Window' unsafeToRef #}
{# fun Fl_set_grab as setGrab'
       { id `Ptr ()' } -> `()' supressWarningAboutRes #}
setGrab :: (Parent a Window) => Ref a -> IO ()
setGrab wp = withRef wp setGrab'
{# fun Fl_event as event
       {  } -> `Event' cToEnum #}
{# fun Fl_event_x as eventX
       {  } -> `Int'#}
{# fun Fl_event_y as eventY
       {  } -> `Int'#}
{# fun Fl_event_x_root as eventXRoot
       {  } -> `Int' #}
{# fun Fl_event_y_root as eventYRoot
       {  } -> `Int' #}
{# fun Fl_event_dx as eventDx
       {  } -> `Int' #}
{# fun Fl_event_dy as eventDy
       {  } ->  `Int' #}
{# fun Fl_get_mouse as getMouse'
   {
     alloca- `Int' peekIntConv* ,
     alloca- `Int' peekIntConv*
   } -> `()' #}
getMouse :: IO Position
getMouse = do
  (x_pos,y_pos) <- getMouse'
  return $ (Position (X x_pos) (Y y_pos))
{# fun Fl_event_clicks as eventClicks
       {  } -> `Int'#}
{# fun Fl_set_event_clicks as setEventClicks
       { `Int' } -> `()' supressWarningAboutRes #}
{# fun Fl_event_is_click as eventIsClick
       {  } -> `Bool' toBool #}
{# fun Fl_set_event_is_click as setEventIsClick
       { `Int' } -> `()' supressWarningAboutRes #}
{# fun Fl_event_button as eventButton
       {  } -> `MouseButton' cToEnum #}
eventStates :: [EventState]
eventStates = [
               Kb_ShiftState,
               Kb_CapsLockState,
               Kb_CtrlState,
               Kb_AltState,
               Kb_NumLockState,
               Kb_MetaState,
               Kb_ScrollLockState,
               Mouse_Button1State,
               Mouse_Button2State,
               Mouse_Button3State
              ]
extractEventStates :: CInt -> [EventState]
extractEventStates = extract eventStates
-- foldModifiers :: [KeyboardCode] -> CInt
-- foldModifiers codes =
--     let validKeysyms = map cFromEnum (filter (\c -> c `elem` validKeyboardStates) codes)
--     in
--       case validKeysyms of
--         [] -> (-1)
--         (k:ks) -> foldl (\accum k' -> accum .&. k') k ks
{# fun Fl_event_state as eventState
       {  } -> `[EventState]' extractEventStates #}
{# fun Fl_contains_event_state as containsEventState
       {cFromEnum `EventState' } -> `Bool' toBool #}
{# fun Fl_event_key as eventKey
       {  } -> `KeyboardCode' cToEnum #}
{# fun Fl_event_original_key as eventOriginalKey
       {  } -> `KeyboardCode' cToEnum #}
{# fun Fl_event_key_pressed as eventKeyPressed
       {cFromEnum `KeyboardCode' } -> `Bool' toBool #}
{# fun Fl_get_key as getKey
       {cFromEnum `KeyboardCode' } -> `Bool' toBool #}
{# fun Fl_event_text as eventText
       {  } -> `String' #}
{# fun Fl_event_length as eventLength
       {  } -> `Int' #}
{# fun Fl_compose as compose
       { alloca- `Int' peekIntConv* } -> `Bool' toBool #}
{# fun Fl_compose_reset as composeReset
       {  } -> `()' supressWarningAboutRes #}
{# fun Fl_event_inside_region as eventInsideRegion'
       { `Int',`Int',`Int',`Int' } -> `Int' #}
eventInsideRegion :: Rectangle -> IO Event
eventInsideRegion (Rectangle
                   (Position
                    (X x_pos)
                    (Y y_pos))
                   (Size
                    (Width width)
                    (Height height))) =
    do
      eventNum <- eventInsideRegion' x_pos y_pos width height
      return $ toEnum eventNum
{# fun Fl_event_inside_widget as eventInsideWidget'
       { id `Ptr ()' } -> `Int' #}
eventInsideWidget :: (Parent a Widget) => Ref a -> IO Event
eventInsideWidget wp =
    withRef wp  (\ptr -> do
                      eventNum <- eventInsideWidget' (castPtr ptr)
                      return $ toEnum eventNum)
{# fun Fl_test_shortcut as testShortcut
       { id `FlShortcut' } -> `Bool' toBool #}
{# fun Fl_enable_im as enableIm
       {} -> `()' supressWarningAboutRes #}
{# fun Fl_disable_im as disableIm
       {} -> `()' supressWarningAboutRes #}
{# fun Fl_handle as handle'
       { `Int',id `Ptr ()' } -> `Int' #}
handle :: (Parent a Window) =>  Event -> Ref a -> IO Int
handle e wp =
    withRef wp (handle' (cFromEnum e))
{# fun Fl_handle_ as handle_'
       { `Int',id `Ptr ()' } -> `Int' #}
handle_ :: (Parent a Window) =>  Event -> Ref a -> IO Int
handle_ e wp =
    withRef wp (handle_' (cFromEnum e))
{# fun Fl_belowmouse as belowmouse
       {  } -> `Ref Widget' unsafeToRef #}
{# fun Fl_set_belowmouse as setBelowmouse'
       { id `Ptr ()' } -> `()' supressWarningAboutRes #}
setBelowmouse :: (Parent a Widget) => Ref a -> IO ()
setBelowmouse wp = withRef wp setBelowmouse'
{# fun Fl_pushed as pushed
       {  } -> `Ref Widget' unsafeToRef #}
{# fun Fl_set_pushed as setPushed'
       { id `Ptr ()' } -> `()' supressWarningAboutRes #}
setPushed :: (Parent a Widget) => Ref a -> IO ()
setPushed wp = withRef wp setPushed'
{# fun Fl_focus as focus
       {  } -> `Ref Widget' unsafeToRef #}
{# fun Fl_set_focus as setFocus'
       { id `Ptr ()' } -> `()' supressWarningAboutRes #}
setFocus :: (Parent a Widget) => Ref a -> IO ()
setFocus wp = withRef wp setFocus'
{# fun Fl_add_handler as addHandler'
       { id `FunPtr GlobalEventHandlerPrim' } -> `()' supressWarningAboutRes #}
{# fun Fl_remove_handler as removeHandler'
       { id `FunPtr GlobalEventHandlerPrim' } -> `()' supressWarningAboutRes #}
setHandler :: GlobalEventHandlerF -> IO ()
setHandler eh = do
  newGlobalEventHandler <- toGlobalEventHandlerPrim eh
  curr <- do
    old <- readIORef ptrToGlobalEventHandler
    writeIORef ptrToGlobalEventHandler newGlobalEventHandler
    return old
  removeHandler' curr
  addHandler' newGlobalEventHandler

{# fun Fl_set_event_dispatch as setEventDispatch'
       { id `Ptr (FunPtr EventDispatchPrim)' } -> `()' supressWarningAboutRes #}
{# fun Fl_event_dispatch as eventDispatch'
       {  } -> `FunPtr EventDispatchPrim' id #}
eventDispatch :: (Parent a Widget) => IO (Event -> Ref a -> IO (Int))
eventDispatch =
    do
      funPtr <- eventDispatch'
      return (\e window ->
                  withRef
                   window
                    (\ptr ->
                         let eventNum = fromIntegral (fromEnum e)
                             fun = unwrapEventDispatchPrim funPtr
                         in fun eventNum (castPtr ptr) >>=
                            return . fromIntegral
                    )
             )

setEventDispatch :: (Parent a Widget) => (Event -> Ref a -> IO Int) -> IO ()
setEventDispatch ed = do
    do
      let toPrim = (\e ptr ->
                      let eventEnum = toEnum $ fromIntegral e
                      in do
                      obj <- toRef ptr
                      result <- ed eventEnum obj
                      return $ fromIntegral result
                    )
      callbackPtr <-  wrapEventDispatchPrim toPrim
      ptrToCallbackPtr <- new callbackPtr
      poke ptrToCallbackPtr callbackPtr
      setEventDispatch' ptrToCallbackPtr
{# fun Fl_copy as copy
       { `String',`Int' } -> `()' supressWarningAboutRes #}
{# fun Fl_copy_with_destination as copyWithDestination
       { `String',`Int',`Int' } -> `()' supressWarningAboutRes #}
{# fun Fl_paste_with_source as pasteWithSource
       { id `Ptr ()',`Int' } -> `()' supressWarningAboutRes #}
paste :: (Parent a Widget) => Ref a -> Maybe Int -> IO ()
paste widget (Just clipboard) = withRef widget ((flip pasteWithSource) clipboard)
paste widget Nothing          = withRef widget ((flip pasteWithSource) 0)

{# fun Fl_dnd as dnd
       {  } -> `Int' #}
{# fun Fl_x as x
       {  } -> `Int' #}
{# fun Fl_y as y
       {  } -> `Int' #}
{# fun Fl_w as w
       {  } -> `Int' #}
{# fun Fl_h as h
       {  } -> `Int' #}
{# fun Fl_screen_count as screenCount
       {  } -> `Int' #}

{# fun Fl_screen_xywh as screenXYWH
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv*
       } -> `()'  #}
{# fun Fl_screen_xywh_with_mxmy as screenXYWYWithMXMY
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         `Int',
         `Int'
       } -> `()'  #}
{# fun Fl_screen_xywh_with_n as screenXYWNWithN
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         `Int'
       } -> `()'  #}
{# fun Fl_screen_xywh_with_mxmymwmh as screenXYWHWithNMXMYMWMH
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         `Int',
         `Int',
         `Int',
         `Int'
       } -> `()' #}

screenBounds :: Maybe ScreenLocation -> IO Rectangle
screenBounds location =
    case location of
      (Just (Intersect (Rectangle (Position (X x_pos) (Y y_pos)) (Size (Width width) (Height height))))) ->
          screenXYWHWithNMXMYMWMH x_pos y_pos width height >>= return . toRectangle
      (Just (ScreenPosition (Position (X x_pos) (Y y_pos)))) ->
          screenXYWYWithMXMY x_pos y_pos >>= return . toRectangle
      (Just (ScreenNumber n)) ->
          screenXYWNWithN n >>= return . toRectangle
      Nothing ->
          screenXYWH >>= return . toRectangle

{# fun Fl_screen_dpi as screenDpi'
       { alloca- `Float' peekFloatConv*,
         alloca- `Float' peekFloatConv* }
           -> `()' #}
{# fun Fl_screen_dpi_with_n as screenDpiWithN'
       { alloca- `Float' peekFloatConv*,
         alloca- `Float' peekFloatConv*,
                 `Int' }
           -> `()' #}

screenDPI :: Maybe Int -> IO DPI
screenDPI (Just n) = do
  (dpiX, dpiY) <- screenDpiWithN' n
  return $ DPI dpiX dpiY
screenDPI Nothing = do
  (dpiX, dpiY) <- screenDpi'
  return $ DPI dpiX dpiY

{# fun Fl_screen_work_area_with_mx_my as screenWorkAreaWithMXMY'
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         `Int',
         `Int'
       }
         -> `()' #}
{# fun Fl_screen_work_area_with_n as screenWorkAreaWithN'
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         `Int'
       }
        -> `()' #}
{# fun Fl_screen_work_area as screenWorkArea'
       {
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv* ,
         alloca- `Int' peekIntConv*
       }
        -> `()' id- #}
screenWorkArea :: Maybe ScreenLocation -> IO Rectangle
screenWorkArea location =
    case location of
      (Just (Intersect (Rectangle (Position (X x_pos) (Y y_pos)) _))) ->
          screenWorkAreaWithMXMY' x_pos y_pos >>= return . toRectangle
      (Just (ScreenPosition (Position (X x_pos) (Y y_pos)))) ->
          screenWorkAreaWithMXMY' x_pos y_pos >>= return . toRectangle
      (Just (ScreenNumber n)) ->
          screenWorkAreaWithN' n >>= return . toRectangle
      Nothing ->
          screenWorkArea' >>= return . toRectangle

setColorRgb :: Color -> Int -> Int -> Int -> IO ()
setColorRgb c r g b = {#call Fl_set_color_rgb as fl_set_color_rgb #}
                        (cFromColor c)
                        (fromIntegral r)
                        (fromIntegral g)
                        (fromIntegral b)
{# fun Fl_set_color as setColor
       { cFromColor `Color',`Int' } -> `()' supressWarningAboutRes #}
{# fun Fl_get_color as getColor
       { cFromColor `Color' } -> `Int' #}
{# fun Fl_get_color_rgb as getColorRgb
       {
         cFromColor `Color',
         alloca- `Word8' peekIntConv*,
         alloca- `Word8' peekIntConv*,
         alloca- `Word8' peekIntConv*
       } -> `()' supressWarningAboutRes #}

#if !defined(__APPLE__)
{# fun Fl_free_color as freeColor'
      { cFromColor `Color' } -> `()' supressWarningAboutRes #}
{# fun Fl_free_color_with_overlay as freeColorWithOverlay'
       { cFromColor `Color', `Int' } -> `()' supressWarningAboutRes #}
removeFromColormap :: Maybe Int -> Color -> IO ()
removeFromColormap (Just overlay) c = freeColorWithOverlay' c overlay
removeFromColormap Nothing c = freeColor' c
#endif
{# fun Fl_get_font as getFont
       { cFromFont `Font' } -> `String' #}
{# fun Fl_get_font_name_with_attributes as getFontNameWithAttributes'
       { cFromFont `Font', alloca- `Maybe FontAttribute' toAttribute* } -> `String' #}
toAttribute :: Ptr CInt -> IO (Maybe FontAttribute)
toAttribute ptr =
        do
          attributeCode <- peekIntConv ptr
          return $ cToFontAttribute attributeCode
getFontName :: Font -> IO (String, Maybe FontAttribute)
getFontName f = getFontNameWithAttributes' f
{# fun Fl_get_font_sizes as getFontSizes
       { cFromFont `Font', alloca- `Int' peekIntConv* } -> `Int' #}
{# fun Fl_set_font_by_string as setFontByString
       { cFromFont `Font',`String' } -> `()' supressWarningAboutRes #}
{# fun Fl_set_font_by_font as setFontByFont
       { cFromFont `Font',cFromFont `Font' } -> `()' supressWarningAboutRes #}
{# fun Fl_set_fonts as setFonts
       {  } -> `Font' cToFont #}
{# fun Fl_set_fonts_with_string as setFontsWithString
       { `String' } -> `Font' cToFont #}
{# fun Fl_get_boxtype as getBoxtype'
       { cFromEnum `Boxtype' } -> `FunPtr BoxDrawFPrim' id #}

getBoxtype :: Boxtype -> IO BoxDrawF
getBoxtype bt = do
  wrappedFunPtr <- getBoxtype' bt
  let boxDrawPrim = unwrapBoxDrawFPrim wrappedFunPtr
  return $ toBoxDrawF boxDrawPrim

{# fun Fl_set_boxtype as setBoxtype'
       {
         cFromEnum `Boxtype',
         id `FunPtr BoxDrawFPrim',
         `Word8',
         `Word8',
         `Word8',
         `Word8'
       } -> `()' supressWarningAboutRes #}
{# fun Fl_set_boxtype_by_boxtype as setBoxtypeByBoxtype'
       {
         cFromEnum `Boxtype',
         cFromEnum `Boxtype'
       } -> `()' supressWarningAboutRes #}

data BoxtypeSpec = FromSpec BoxDrawF Word8 Word8 Word8 Word8
                 | FromBoxtype Boxtype
setBoxtype :: Boxtype -> BoxtypeSpec -> IO ()
setBoxtype bt (FromSpec f dx dy dw dh) =
    do
      funPtr <- wrapBoxDrawFPrim (toBoxDrawFPrim f)
      setBoxtype' bt funPtr dx dy dw dh
setBoxtype bt (FromBoxtype template) =
    setBoxtypeByBoxtype' bt template

{# fun Fl_box_dx as boxDx
       { cFromEnum `Boxtype' } -> `Int' #}
{# fun Fl_box_dy as boxDy
       { cFromEnum `Boxtype' } -> `Int' #}
{# fun Fl_box_dw as boxDw
       { cFromEnum `Boxtype' } -> `Int' #}
{# fun Fl_box_dh as boxDh
       { cFromEnum `Boxtype' } -> `Int' #}
{# fun Fl_draw_box_active as drawBoxActive
       {  } -> `Bool' toBool #}
{# fun Fl_event_shift as eventShift
       {  } -> `Bool' toBool #}
{# fun Fl_event_ctrl as eventCtrl
       {  } -> `Bool' toBool #}
{# fun Fl_event_command as eventCommand
       {  } -> `Bool' toBool #}
{# fun Fl_event_alt as eventAlt
       {  } -> `Bool' toBool #}
{# fun Fl_event_buttons as eventButtons
       {  } -> `Bool' toBool #}
{# fun Fl_event_button1 as eventButton1
       {  } -> `Bool' toBool #}
{# fun Fl_event_button2 as eventButton2
       {  } -> `Bool' toBool #}
{# fun Fl_event_button3 as eventButton3
      {  } -> `Bool' toBool #}
release :: IO ()
release = {#call Fl_release as fl_release #}
setVisibleFocus :: Int -> IO ()
setVisibleFocus = {#call Fl_set_visible_focus as fl_set_visible_focus #} . fromIntegral
visibleFocus :: IO Int
visibleFocus = {#call Fl_visible_focus as fl_visible_focus #} >>= return . fromIntegral
setDndTextOps :: Bool -> IO ()
setDndTextOps =  {#call Fl_set_dnd_text_ops as fl_set_dnd_text_ops #} . fromBool
dndTextOps :: IO Option
dndTextOps = {#call Fl_dnd_text_ops as fl_dnd_text_ops #} >>= return . cToEnum
deleteWidget :: (Parent a Widget) => Ref a -> IO ()
deleteWidget wptr =
  swapRef wptr $ \ptr -> do
    {#call Fl_delete_widget as fl_delete_widget #} ptr
    return nullPtr
doWidgetDeletion :: IO ()
doWidgetDeletion = {#call Fl_do_widget_deletion as fl_do_widget_deletion #}
watchWidgetPointer :: (Parent a Widget) => Ref a -> IO ()
watchWidgetPointer wp = withRef wp {#call Fl_watch_widget_pointer as fl_Watch_widget_Pointer #}
releaseWidgetPointer :: (Parent a Widget) => Ref a -> IO ()
releaseWidgetPointer wp = withRef wp {#call Fl_release_widget_pointer as fl_release_widget_pointer #}
clearWidgetPointer :: (Parent a Widget) => Ref a -> IO ()
clearWidgetPointer wp = withRef wp {#call Fl_clear_widget_pointer as fl_Clear_Widget_Pointer #}


Add function sourceCompletionGetInfoWindow

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceCompletion
--
--  Author : Andy Stewart
--
--  Created: 08 Aug 2010
--
--  Copyright (C) 2010 Andy Stewart
--
--  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.SourceView.SourceCompletion (
-- * Types
    SourceCompletion,
    SourceCompletionClass,

-- * Methods
    sourceCompletionAddProvider,
    sourceCompletionRemoveProvider,
    sourceCompletionGetProviders,
    -- sourceCompletionShow,
    sourceCompletionHide,
    sourceCompletionGetInfoWindow,
    sourceCompletionMoveWindow,
    sourceCompletionBlockInteractive,
    sourceCompletionUnblockInteractive,

-- * Attributes
    sourceCompletionAccelerators,
    sourceCompletionAutoCompleteDelay,
    sourceCompletionProposalPageSize,
    sourceCompletionProviderPageSize,
    sourceCompletionRememberInfoVisibility,
    sourceCompletionSelectOnShow,
    sourceCompletionShowHeaders,
    sourceCompletionShowIcons,
    sourceCompletionView,

-- * Signals
    sourceCompletionActivateProposal,
    sourceCompletionHideSignal,
    sourceCompletionMoveCursor,
    sourceCompletionMovePage,
    -- sourceCompletionPopulateContext,
    sourceCompletionShowSignal,
) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject	(makeNewGObject)
import System.Glib.Attributes
import System.Glib.Properties
import System.Glib.GError
import System.Glib.GList		(fromGList, withGList)
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
import Graphics.UI.Gtk.Multiline.TextView (TextWindowType (..))
import Graphics.UI.Gtk.General.Enums (ScrollStep (..))
{#import Graphics.UI.Gtk.SourceView.Signals#}
{#import Graphics.UI.Gtk.SourceView.Types#}

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

-- | Add a new 'SourceCompletionProvider' to the completion object. This will add a reference provider,
-- so make sure to unref your own copy when you no longer need it.
sourceCompletionAddProvider :: SourceCompletionClass sc => sc
                            -> SourceCompletionProvider
                            -> IO Bool -- ^ returns    'True' if provider was successfully added, otherwise if error is provided, it will be set with the error and
sourceCompletionAddProvider sc provider =
  liftM toBool $
  propagateGError $ \gErrorPtr ->
      {# call gtk_source_completion_add_provider #}
          (toSourceCompletion sc)
          provider
          gErrorPtr

-- | Remove provider from the completion.
sourceCompletionRemoveProvider :: SourceCompletionClass sc => sc
                               -> SourceCompletionProvider
                               -> IO Bool  -- ^ returns    'True' if provider was successfully removed, otherwise if error is provided, it will be set with the error and
sourceCompletionRemoveProvider sc provider =
  liftM toBool $
  propagateGError $ \gErrorPtr ->
      {#call gtk_source_completion_remove_provider #}
         (toSourceCompletion sc)
         provider
         gErrorPtr

-- | Get list of providers registered on completion. The returned list is owned by the completion and
-- should not be freed.
sourceCompletionGetProviders :: SourceCompletionClass sc => sc -> IO [SourceCompletionProvider]
sourceCompletionGetProviders sc = do
  glist <- {#call gtk_source_completion_get_providers #} (toSourceCompletion sc)
  glistPtrs <- fromGList glist
  mapM (makeNewGObject mkSourceCompletionProvider . return) glistPtrs

-- | Starts a new completion with the specified 'SourceCompletionContext' and a list of potential
-- candidate providers for completion.
-- sourceCompletionShow :: SourceCompletionClass sc => sc
--                      -> [SourceCompletionProvider]
--                      ->

-- | Hides the completion if it is active (visible).
sourceCompletionHide :: SourceCompletionClass sc => sc -> IO ()
sourceCompletionHide sc =
  {#call gtk_source_completion_hide #} (toSourceCompletion sc)

-- | The info widget is the window where the completion displays optional extra information of the
-- proposal.
sourceCompletionGetInfoWindow :: SourceCompletionClass sc => sc -> IO SourceCompletionInfo
sourceCompletionGetInfoWindow sc =
  makeNewObject mkSourceCompletionInfo $
  {#call gtk_source_completion_get_info_window #}
    (toSourceCompletion sc)

-- | Move the completion window to a specific iter.
sourceCompletionMoveWindow :: SourceCompletionClass sc => sc
                           -> TextIter
                           -> IO ()
sourceCompletionMoveWindow sc iter =
  {#call gtk_source_completion_move_window #}
    (toSourceCompletion sc)
    iter

-- | Block interactive completion. This can be used to disable interactive completion when inserting or
-- deleting text from the buffer associated with the completion. Use
-- 'sourceCompletionUnblockInteractive' to enable interactive completion again.
sourceCompletionBlockInteractive :: SourceCompletionClass sc => sc -> IO ()
sourceCompletionBlockInteractive sc =
  {#call gtk_source_completion_block_interactive #}
     (toSourceCompletion sc)

-- | Unblock interactive completion. This can be used after using 'sourceCompletionBlockInteractive'
-- to enable interactive completion again.
sourceCompletionUnblockInteractive :: SourceCompletionClass sc => sc -> IO ()
sourceCompletionUnblockInteractive sc =
  {#call gtk_source_completion_unblock_interactive #}
     (toSourceCompletion sc)

-- | Number of accelerators to show for the first proposals.
--
-- Allowed values: <= 10
--
-- Default value: 5
--
sourceCompletionAccelerators :: SourceCompletionClass sc => Attr sc Int
sourceCompletionAccelerators = newAttrFromIntProperty "accelerators"

-- | Determines the popup delay (in milliseconds) at which the completion will be shown for interactive
-- completion.
--
-- Default value: 250
--
sourceCompletionAutoCompleteDelay :: SourceCompletionClass sc => Attr sc Int
sourceCompletionAutoCompleteDelay = newAttrFromIntProperty "auto-complete-delay"

-- | The scroll page size of the proposals in the completion window.
--
-- Allowed values: >= 1
--
-- Default value: 5
--
sourceCompletionProposalPageSize :: SourceCompletionClass sc => Attr sc Int
sourceCompletionProposalPageSize = newAttrFromIntProperty "proposal-page-size"

-- | The scroll page size of the provider pages in the completion window.
--
-- Allowed values: >= 1
--
-- Default value: 5
--
sourceCompletionProviderPageSize :: SourceCompletionClass sc => Attr sc Int
sourceCompletionProviderPageSize = newAttrFromIntProperty "provider-page-size"

-- | Determines whether the visibility of the info window should be saved when the completion is hidden,
-- and restored when the completion is shown again.
--
-- Default value: 'False'
--
sourceCompletionRememberInfoVisibility :: SourceCompletionClass sc => Attr sc Bool
sourceCompletionRememberInfoVisibility = newAttrFromBoolProperty "remember-info-visibility"

-- | Determines whether the first proposal should be selected when the completion is first shown.
--
-- Default value: 'True'
--
sourceCompletionSelectOnShow :: SourceCompletionClass sc => Attr sc Bool
sourceCompletionSelectOnShow = newAttrFromBoolProperty "select-on-show"

-- | Determines whether provider headers should be shown in the proposal list if there is more than one
-- provider with proposals.
--
-- Default value: 'True'
sourceCompletionShowHeaders :: SourceCompletionClass sc => Attr sc Bool
sourceCompletionShowHeaders = newAttrFromBoolProperty "show-headers"

-- | Determines whether provider and proposal icons should be shown in the completion popup.
--
-- Default value: 'True'
--
sourceCompletionShowIcons :: SourceCompletionClass sc => Attr sc Bool
sourceCompletionShowIcons = newAttrFromBoolProperty "show-icons"

-- | The 'SourceView' bound to the completion object.
--
sourceCompletionView :: SourceCompletionClass sc => Attr sc SourceView
sourceCompletionView = newAttrFromObjectProperty "view"
                       {#call pure unsafe gtk_source_view_get_type #}

-- | The 'activateProposal' signal is a keybinding signal which gets emitted when the user initiates a
-- proposal activation.
--
-- Applications should not connect to it, but may emit it with @gSignalEmitByName@ if they need to
-- control the proposal activation programmatically.
sourceCompletionActivateProposal :: SourceCompletionClass sc => Signal sc (IO ())
sourceCompletionActivateProposal =
  Signal $ connect_NONE__NONE "activate_proposal"

-- | Emitted when the completion window is hidden. The default handler will actually hide the window.
sourceCompletionHideSignal :: SourceCompletionClass sc => Signal sc (IO ())
sourceCompletionHideSignal =
  Signal $ connect_NONE__NONE "hide"

-- | The 'moveCursor' signal is a keybinding signal which gets emitted when the user initiates a cursor
-- movement.
--
-- Applications should not connect to it, but may emit it with @gSignalEmitByName@ if they need to
-- control the cursor programmatically.
sourceCompletionMoveCursor :: SourceCompletionClass sc => Signal sc (ScrollStep -> Int -> IO ())
sourceCompletionMoveCursor =
  Signal $ connect_ENUM_INT__NONE "move_cursor"

-- | The 'movePage' signal is a keybinding signal which gets emitted when the user initiates a page
-- movement (i.e. switches between provider pages).
--
-- Applications should not connect to it, but may emit it with @gSignalEmitByName@ if they need to
-- control the page selection programmatically.
sourceCompletionMovePage :: SourceCompletionClass sc => Signal sc (ScrollStep -> Int -> IO ())
sourceCompletionMovePage =
  Signal $ connect_ENUM_INT__NONE "move_page"

-- | Emitted when the completion window is shown. The default handler will actually show the window.
sourceCompletionShowSignal :: SourceCompletionClass sc => Signal sc (IO ())
sourceCompletionShowSignal =
  Signal $ connect_NONE__NONE "show"

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceCompletion
--
--  Author : Andy Stewart
--
--  Created: 08 Aug 2010
--
--  Copyright (C) 2010 Andy Stewart
--
--  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.SourceView.SourceCompletion (
-- * Types
    SourceCompletion,
    SourceCompletionClass,

-- * Methods
    sourceCompletionAddProvider,
    sourceCompletionRemoveProvider,
    sourceCompletionGetProviders,
    -- sourceCompletionShow,
    sourceCompletionHide,
    sourceCompletionMoveWindow,
    sourceCompletionBlockInteractive,
    sourceCompletionUnblockInteractive,

-- * Attributes
    sourceCompletionAccelerators,
    sourceCompletionAutoCompleteDelay,
    sourceCompletionProposalPageSize,
    sourceCompletionProviderPageSize,
    sourceCompletionRememberInfoVisibility,
    sourceCompletionSelectOnShow,
    sourceCompletionShowHeaders,
    sourceCompletionShowIcons,
    sourceCompletionView,

-- * Signals
    sourceCompletionActivateProposal,
    sourceCompletionHideSignal,
    sourceCompletionMoveCursor,
    sourceCompletionMovePage,
    -- sourceCompletionPopulateContext,
    sourceCompletionShowSignal,
) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject	(makeNewGObject)
import System.Glib.Attributes
import System.Glib.Properties
import System.Glib.GError
import System.Glib.GList		(fromGList, withGList)
import Graphics.UI.Gtk.Multiline.TextView (TextWindowType (..))
import Graphics.UI.Gtk.General.Enums (ScrollStep (..))
{#import Graphics.UI.Gtk.SourceView.Signals#}
{#import Graphics.UI.Gtk.SourceView.Types#}

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

-- | Add a new 'SourceCompletionProvider' to the completion object. This will add a reference provider,
-- so make sure to unref your own copy when you no longer need it.
sourceCompletionAddProvider :: SourceCompletionClass sc => sc
                            -> SourceCompletionProvider
                            -> IO Bool -- ^ returns    'True' if provider was successfully added, otherwise if error is provided, it will be set with the error and
sourceCompletionAddProvider sc provider =
  liftM toBool $
  propagateGError $ \gErrorPtr ->
      {# call gtk_source_completion_add_provider #}
          (toSourceCompletion sc)
          provider
          gErrorPtr

-- | Remove provider from the completion.
sourceCompletionRemoveProvider :: SourceCompletionClass sc => sc
                               -> SourceCompletionProvider
                               -> IO Bool  -- ^ returns    'True' if provider was successfully removed, otherwise if error is provided, it will be set with the error and
sourceCompletionRemoveProvider sc provider =
  liftM toBool $
  propagateGError $ \gErrorPtr ->
      {#call gtk_source_completion_remove_provider #}
         (toSourceCompletion sc)
         provider
         gErrorPtr

-- | Get list of providers registered on completion. The returned list is owned by the completion and
-- should not be freed.
sourceCompletionGetProviders :: SourceCompletionClass sc => sc -> IO [SourceCompletionProvider]
sourceCompletionGetProviders sc = do
  glist <- {#call gtk_source_completion_get_providers #} (toSourceCompletion sc)
  glistPtrs <- fromGList glist
  mapM (makeNewGObject mkSourceCompletionProvider . return) glistPtrs

-- | Starts a new completion with the specified 'SourceCompletionContext' and a list of potential
-- candidate providers for completion.
-- sourceCompletionShow :: SourceCompletionClass sc => sc
--                      -> [SourceCompletionProvider]
--                      ->

-- | Hides the completion if it is active (visible).
sourceCompletionHide :: SourceCompletionClass sc => sc -> IO ()
sourceCompletionHide sc =
  {#call gtk_source_completion_hide #} (toSourceCompletion sc)

-- | Move the completion window to a specific iter.
sourceCompletionMoveWindow :: SourceCompletionClass sc => sc
                           -> TextIter
                           -> IO ()
sourceCompletionMoveWindow sc iter =
  {#call gtk_source_completion_move_window #}
    (toSourceCompletion sc)
    iter

-- | Block interactive completion. This can be used to disable interactive completion when inserting or
-- deleting text from the buffer associated with the completion. Use
-- 'sourceCompletionUnblockInteractive' to enable interactive completion again.
sourceCompletionBlockInteractive :: SourceCompletionClass sc => sc -> IO ()
sourceCompletionBlockInteractive sc =
  {#call gtk_source_completion_block_interactive #}
     (toSourceCompletion sc)

-- | Unblock interactive completion. This can be used after using 'sourceCompletionBlockInteractive'
-- to enable interactive completion again.
sourceCompletionUnblockInteractive :: SourceCompletionClass sc => sc -> IO ()
sourceCompletionUnblockInteractive sc =
  {#call gtk_source_completion_unblock_interactive #}
     (toSourceCompletion sc)

-- | Number of accelerators to show for the first proposals.
--
-- Allowed values: <= 10
--
-- Default value: 5
--
sourceCompletionAccelerators :: SourceCompletionClass sc => Attr sc Int
sourceCompletionAccelerators = newAttrFromIntProperty "accelerators"

-- | Determines the popup delay (in milliseconds) at which the completion will be shown for interactive
-- completion.
--
-- Default value: 250
--
sourceCompletionAutoCompleteDelay :: SourceCompletionClass sc => Attr sc Int
sourceCompletionAutoCompleteDelay = newAttrFromIntProperty "auto-complete-delay"

-- | The scroll page size of the proposals in the completion window.
--
-- Allowed values: >= 1
--
-- Default value: 5
--
sourceCompletionProposalPageSize :: SourceCompletionClass sc => Attr sc Int
sourceCompletionProposalPageSize = newAttrFromIntProperty "proposal-page-size"

-- | The scroll page size of the provider pages in the completion window.
--
-- Allowed values: >= 1
--
-- Default value: 5
--
sourceCompletionProviderPageSize :: SourceCompletionClass sc => Attr sc Int
sourceCompletionProviderPageSize = newAttrFromIntProperty "provider-page-size"

-- | Determines whether the visibility of the info window should be saved when the completion is hidden,
-- and restored when the completion is shown again.
--
-- Default value: 'False'
--
sourceCompletionRememberInfoVisibility :: SourceCompletionClass sc => Attr sc Bool
sourceCompletionRememberInfoVisibility = newAttrFromBoolProperty "remember-info-visibility"

-- | Determines whether the first proposal should be selected when the completion is first shown.
--
-- Default value: 'True'
--
sourceCompletionSelectOnShow :: SourceCompletionClass sc => Attr sc Bool
sourceCompletionSelectOnShow = newAttrFromBoolProperty "select-on-show"

-- | Determines whether provider headers should be shown in the proposal list if there is more than one
-- provider with proposals.
--
-- Default value: 'True'
sourceCompletionShowHeaders :: SourceCompletionClass sc => Attr sc Bool
sourceCompletionShowHeaders = newAttrFromBoolProperty "show-headers"

-- | Determines whether provider and proposal icons should be shown in the completion popup.
--
-- Default value: 'True'
--
sourceCompletionShowIcons :: SourceCompletionClass sc => Attr sc Bool
sourceCompletionShowIcons = newAttrFromBoolProperty "show-icons"

-- | The 'SourceView' bound to the completion object.
--
sourceCompletionView :: SourceCompletionClass sc => Attr sc SourceView
sourceCompletionView = newAttrFromObjectProperty "view"
                       {#call pure unsafe gtk_source_view_get_type #}

-- | The 'activateProposal' signal is a keybinding signal which gets emitted when the user initiates a
-- proposal activation.
--
-- Applications should not connect to it, but may emit it with @gSignalEmitByName@ if they need to
-- control the proposal activation programmatically.
sourceCompletionActivateProposal :: SourceCompletionClass sc => Signal sc (IO ())
sourceCompletionActivateProposal =
  Signal $ connect_NONE__NONE "activate_proposal"

-- | Emitted when the completion window is hidden. The default handler will actually hide the window.
sourceCompletionHideSignal :: SourceCompletionClass sc => Signal sc (IO ())
sourceCompletionHideSignal =
  Signal $ connect_NONE__NONE "hide"

-- | The 'moveCursor' signal is a keybinding signal which gets emitted when the user initiates a cursor
-- movement.
--
-- Applications should not connect to it, but may emit it with @gSignalEmitByName@ if they need to
-- control the cursor programmatically.
sourceCompletionMoveCursor :: SourceCompletionClass sc => Signal sc (ScrollStep -> Int -> IO ())
sourceCompletionMoveCursor =
  Signal $ connect_ENUM_INT__NONE "move_cursor"

-- | The 'movePage' signal is a keybinding signal which gets emitted when the user initiates a page
-- movement (i.e. switches between provider pages).
--
-- Applications should not connect to it, but may emit it with @gSignalEmitByName@ if they need to
-- control the page selection programmatically.
sourceCompletionMovePage :: SourceCompletionClass sc => Signal sc (ScrollStep -> Int -> IO ())
sourceCompletionMovePage =
  Signal $ connect_ENUM_INT__NONE "move_page"

-- | Emitted when the completion window is shown. The default handler will actually show the window.
sourceCompletionShowSignal :: SourceCompletionClass sc => Signal sc (IO ())
sourceCompletionShowSignal =
  Signal $ connect_NONE__NONE "show"


Added SKIPDATA mode, fixed use-after-free

{-# LANGUAGE ForeignFunctionInterface #-}
module Hapstone.Internal.Capstone
    ( Csh
    , CsArch(..)
    , CsSupport(..)
    , CsMode(..)
    , CsOption(..)
    , CsOptionState(..)
    , CsOperand(..)
    , CsGroup(..)
    , CsSkipdataCallback
    , CsSkipdataStruct(..)
    , CsDetail(..)
    , peekDetail
    , CsInsn(..)
    , csInsnOffset
    , CsErr(..)
    , csSupport
    , csOpen
    , csClose
    , csOption
    , csErrno
    , csStrerror
    , csDisasm
    , csFree
    , csMalloc
    , csRegName
    , csInsnName
    , csGroupName
    , csInsnGroup
    , csRegRead
    , csRegWrite
    , csOpCount
    , csOpIndex
    ) where

{-
A few notes on API design

This is just a roughly 1:1 translation of the capstone C headers to Haskell.
Obviously, it isn't a very pleasant experience to use, so a higher-level API
is needed. The approach there would be like follows:
* determine the common workflows with capstone (this is easy)
* write wrappers around those workflows

The most notorious issues:
* wrap allocation and deallocation of structs, so that each pure function is
  a no-op to the runtime's state
* wrap datatype conversion between architecture specific enumerations and
  interger types. This is best done via typeclasses or type families.
* wrap instruction structures to provide better architecture separation

Those should be less straightforward to handle and require some more work, a
few drafts should be easy to write, however.

-}

#include <capstone/capstone.h>

{#context lib = "capstone"#}

import Control.Monad (join)

import Foreign
import Foreign.C.Types
import Foreign.C.String (CString, peekCString, newCString)
import Foreign.Marshal.Array (peekArray, pokeArray)
import Foreign.Ptr

import Hapstone.Internal.Util
import qualified Hapstone.Internal.Arm64 as Arm64
import qualified Hapstone.Internal.Arm as Arm
import qualified Hapstone.Internal.Mips as Mips
import qualified Hapstone.Internal.Ppc as Ppc
import qualified Hapstone.Internal.Sparc as Sparc
import qualified Hapstone.Internal.SystemZ as SystemZ
import qualified Hapstone.Internal.X86 as X86
import qualified Hapstone.Internal.XCore as XCore

import System.IO.Unsafe (unsafePerformIO)

-- capstone's weird^M^M^M^M^Mopaque handle type
type Csh = CSize
{#typedef csh Csh#}

-- supported architectures
{#enum cs_arch as CsArch {underscoreToCase} deriving (Show)#}

-- support constants
{#enum define CsSupport
    { CS_SUPPORT_DIET as CsSupportDiet
    , CS_SUPPORT_X86_REDUCE as CsSupportX86Reduce} deriving (Show)#}

-- work modes
{#enum cs_mode as CsMode {underscoreToCase} deriving (Show)#}

-- TODO: we will skip user defined dynamic memory routines for now

-- options are, interestingly, represented by different types
{#enum cs_opt_type as CsOption {underscoreToCase} deriving (Show)#}
{#enum cs_opt_value as CsOptionState {underscoreToCase} deriving (Show)#}

-- arch-uniting operand type
{#enum cs_op_type as CsOperand {underscoreToCase} deriving (Show)#}

-- arch-uniting instruction group type
{#enum cs_group_type as CsGroup {underscoreToCase} deriving (Show)#}

-- callback type for user-defined SKIPDATA work
type CsSkipdataCallback =
    FunPtr (Ptr Word8 -> CSize -> CSize -> Ptr () -> IO CSize)

-- user-defined SKIPDATA setup
data CsSkipdataStruct = CsSkipdataStruct String CsSkipdataCallback (Ptr ())

instance Storable CsSkipdataStruct where
    sizeOf _ = {#sizeof cs_opt_skipdata#}
    alignment _ = {#alignof cs_opt_skipdata#}
    peek p = CsSkipdataStruct
        <$> (peekCString =<< {#get cs_opt_skipdata->mnemonic#} p)
        <*> (castFunPtr <$> {#get cs_opt_skipdata->callback#} p)
        <*> {#get cs_opt_skipdata->user_data#} p
    poke p (CsSkipdataStruct s c d) = do
        newCString s >>= {#set cs_opt_skipdata->mnemonic#} p
        {#set cs_opt_skipdata->callback#} p (castFunPtr c)
        {#set cs_opt_skipdata->user_data#} p d

csSetSkipdata :: Csh -> Maybe CsSkipdataStruct -> IO CsErr
csSetSkipdata h Nothing = csOption h CsOptSkipdata CsOptOff
csSetSkipdata h (Just s) =
    with s (csOption h CsOptSkipdata . fromIntegral . ptrToWordPtr)

-- architecture specific information
data ArchInfo
    = X86 X86.CsX86
    | Arm64 Arm64.CsArm64
    | Arm Arm.CsArm
    | Mips Mips.CsMips
    | Ppc Ppc.CsPpc
    | Sparc Sparc.CsSparc
    | SysZ SystemZ.CsSysZ
    | XCore XCore.CsXCore
    deriving Show

-- instruction information
data CsDetail = CsDetail
    { regsRead :: [Word8]
    , regsWrite :: [Word8]
    , groups :: [Word8]
    , archInfo :: Maybe ArchInfo
    } deriving Show

-- the union holding architecture-specific info is not tagged. Thus, we have
-- no way to determine what kind of data is stored in it without resorting to
-- some kind of context lookup, as the C code would do. Thus, the
-- peek-inmplementation does not get architecture information, use peekDetail
-- for that.
instance Storable CsDetail where
    sizeOf _ = {#sizeof cs_detail#}
    alignment _ = {#alignof cs_detail#}
    peek p = CsDetail
        <$> do num <- fromIntegral <$> {#get cs_detail->regs_read_count#} p
               let ptr = plusPtr p {#offsetof cs_detail.regs_read#}
               peekArray num ptr
        <*> do num <- fromIntegral <$> {#get cs_detail->regs_write_count#} p
               let ptr = plusPtr p {#offsetof cs_detail.regs_write#}
               peekArray num ptr
        <*> do num <- fromIntegral <$> {#get cs_detail->groups_count#} p
               let ptr = plusPtr p {#offsetof cs_detail.groups#}
               peekArray num ptr
        <*> pure Nothing
    poke p (CsDetail rR rW g a) = do
        {#set cs_detail->regs_read_count#} p (fromIntegral $ length rR)
        if length rR > 12
           then error "regs_read overflew 12 bytes"
           else pokeArray (plusPtr p {#offsetof cs_detail.regs_read#}) rR
        {#set cs_detail->regs_write_count#} p (fromIntegral $ length rW)
        if length rW > 20
           then error "regs_write overflew 20 bytes"
           else pokeArray (plusPtr p {#offsetof cs_detail.regs_write#}) rW
        {#set cs_detail->groups_count#} p (fromIntegral $ length g)
        if length g > 8
           then error "groups overflew 8 bytes"
           else pokeArray (plusPtr p {#offsetof cs_detail.groups#}) g
        let bP = plusPtr p ({#offsetof cs_detail.groups_count#} + 1)
        case a of
          Just (X86 x) -> poke bP x
          Just (Arm64 x) -> poke bP x
          Just (Arm x) -> poke bP x
          Just (Mips x) -> poke bP x
          Just (Ppc x) -> poke bP x
          Just (Sparc x) -> poke bP x
          Just (SysZ x) -> poke bP x
          Just (XCore x) -> poke bP x
          Nothing -> return ()

-- an arch-sensitive peek for cs_detail
peekDetail :: CsArch -> Ptr CsDetail -> IO CsDetail
peekDetail arch p = do
    detail <- peek p
    let bP = plusPtr p ({#offsetof cs_detail.groups_count#} + 1)
    aI <- case arch of
            CsArchX86 -> X86 <$> peek (castPtr p)
            CsArchArm64 -> Arm64 <$> peek (castPtr p)
            CsArchArm -> Arm <$> peek (castPtr p)
            CsArchMips -> Mips <$> peek (castPtr p)
            CsArchPpc -> Ppc <$> peek (castPtr p)
            CsArchSparc -> Sparc <$> peek (castPtr p)
            CsArchSysz -> SysZ <$> peek (castPtr p)
            CsArchXcore -> XCore <$> peek (castPtr p)
    return detail { archInfo = Just aI }

-- instructions
data CsInsn = CsInsn
    { insnId :: Word32
    , address :: Word64
    , bytes :: [Word8]
    , mnemonic :: String
    , opStr :: String
    , detail :: CsDetail
    } deriving Show

-- The untagged-union-problem propagates here as well
instance Storable CsInsn where
    sizeOf _ = {#sizeof cs_insn#}
    alignment _ = {#alignof cs_insn#}
    peek p = CsInsn
        <$> (fromIntegral <$> {#get cs_insn->id#} p)
        <*> (fromIntegral <$> {#get cs_insn->address#} p)
        <*> do num <- fromIntegral <$> {#get cs_insn->size#} p
               let ptr = plusPtr p {#offsetof cs_insn->bytes#}
               peekArray num ptr
        <*> (peekCString =<< {#get cs_insn->mnemonic#} p)
        <*> (peekCString =<< {#get cs_insn->op_str#} p)
        <*> (castPtr <$> {#get cs_insn->detail#} p >>= peek)
    poke p (CsInsn i a b m o d) = do
        {#set cs_insn->id#} p (fromIntegral i)
        {#set cs_insn->address#} p (fromIntegral a)
        {#set cs_insn->size#} p (fromIntegral $ length b)
        if length b > 16
           then error "bytes overflew 16 bytes"
           else pokeArray (plusPtr p {#offsetof cs_insn.bytes#}) b
        if length m >= 32
           then error "mnemonic overflew 32 bytes"
           else newCString m >>= {#set cs_insn->mnemonic#} p
        if length o >= 160
           then error "op_str overflew 160 bytes"
           else newCString o >>= {#set cs_insn->op_str#} p
        csDetailPtr <- castPtr <$> ({#get cs_insn->detail#} p)
        poke csDetailPtr d

-- our own port of the CS_INSN_OFFSET macro
csInsnOffset :: Ptr CsInsn -> Int -> Int
csInsnOffset p n = unsafePerformIO $
    (-) <$> getAddr (plusPtr p (n * {#sizeof cs_insn#})) <*> getAddr p
    where getAddr p = fromIntegral <$> {#get cs_insn->address#} p

-- possible error conditions
{#enum cs_err as CsErr {underscoreToCase} deriving (Show)#}

-- get the library version
{#fun pure cs_version as ^
    {alloca- `Int' peekNum*, alloca- `Int' peekNum*} -> `Int'#}

-- get information on supported features
foreign import ccall "capstone/capstone.h cs_support"
    csSupport' :: CInt -> Bool
csSupport :: Enum a => a -> Bool
csSupport = csSupport' . fromIntegral . fromEnum

-- open a new disassembly handle
{#fun cs_open as ^
    {`CsArch', combine `[CsMode]', alloca- `Csh' peek*} -> `CsErr'#}

-- close a handle obtained by cs_open/csOpen
{#fun cs_close as ^ {id `Ptr Csh'} -> `CsErr'#}

-- set an option on a handle
{#fun cs_option as ^ `Enum a' =>
    {`Csh', `CsOption', getCULongFromEnum `a'} -> `CsErr'#}

-- get the last error from a handle
{#fun cs_errno as ^ {`Csh'} -> `CsErr'#}

-- get the description of an error
{#fun cs_strerror as ^ {`CsErr'} -> `String'#}

-- disassemble a buffer
foreign import ccall "capstone/capstone.h cs_disasm"
    csDisasm' :: Csh -- handle
              -> Ptr CUChar -> CSize -- buffer to disassemble
              -> CULong -- address to start at
              -> CSize -- number of instructins to disassemble
              -> Ptr (Ptr CsInsn) -- where to put the instructions
              -> IO CSize -- number of succesfully disassembled instructions

csDisasm :: Csh -> [Word8] -> Word64 -> Int -> IO [CsInsn]
csDisasm handle bytes addr num = do
    array <- newArray $ map fromIntegral bytes
    passedPtr <- malloc :: IO (Ptr (Ptr CsInsn))
    resNum <- fromIntegral <$> csDisasm' handle array
        (fromIntegral $ length bytes) (fromIntegral addr)
        (fromIntegral num) passedPtr
    resPtr <- peek passedPtr
    free passedPtr
    res <- mapM (peek . plusPtr resPtr . ({#sizeof cs_insn#} *)) [0..resNum]
    csFree resPtr resNum
    return res

-- free an instruction struct array
{#fun cs_free as ^ {castPtr `Ptr CsInsn', `Int'} -> `()'#}

-- allocate space for an instruction struct
{#fun cs_malloc as ^ {`Csh'} -> `Ptr CsInsn' castPtr#}

-- TODO: decide whether we want cs_disasm_iter

-- get a register's name as a String
{#fun pure cs_reg_name as csRegName' {`Csh', `Int'} -> `CString'#}
csRegName :: Enum e => Csh -> e -> Maybe String
csRegName h = stringLookup . csRegName' h . fromEnum

-- get a instruction's name as a String
{#fun pure cs_insn_name as csInsnName' {`Csh', `Int'} -> `CString'#}
csInsnName :: Enum e => Csh -> e -> Maybe String
csInsnName h = stringLookup . csInsnName' h . fromEnum

-- get a instruction group's name as a String
{#fun pure cs_group_name as csGroupName' {`Csh', `Int'} -> `CString'#}
csGroupName :: Enum e => Csh -> e -> Maybe String
csGroupName h = stringLookup . csGroupName' h . fromEnum

-- check whether an instruction is member of a group
foreign import ccall "capstone/capstone.h cs_insn_group"
    csInsnGroup' :: Csh -> Ptr CsInsn -> IO Bool
csInsnGroup :: Csh -> CsInsn -> Bool
csInsnGroup h i = unsafePerformIO . withCast i $ csInsnGroup' h

-- check whether an instruction reads from a register
foreign import ccall "capstone/capstone.h cs_reg_read"
    csRegRead' :: Csh -> Ptr CsInsn -> CUInt -> IO Bool
csRegRead :: Csh -> CsInsn -> Int -> Bool
csRegRead h i =
    unsafePerformIO . withCast i . flip (csRegRead' h) . fromIntegral

-- check whether an instruction writes to a register
foreign import ccall "capstone/capstone.h cs_reg_write"
    csRegWrite' :: Csh -> Ptr CsInsn -> CUInt -> IO Bool
csRegWrite :: Csh -> CsInsn -> Int -> Bool
csRegWrite h i =
    unsafePerformIO . withCast i . flip (csRegWrite' h) . fromIntegral

-- return the number of operands of given type an instruction has
{#fun pure cs_op_count as ^
    {`Csh', withCast* `CsInsn', `Int'} -> `Int'#}

-- return the position of the first operand of given type an instruction has,
-- given an inclusive search range
{#fun pure cs_op_index as ^
    {`Csh', withCast* `CsInsn', `Int', `Int'} -> `Int'#}

{-# LANGUAGE ForeignFunctionInterface #-}
module Hapstone.Internal.Capstone
    ( Csh
    , CsArch(..)
    , CsSupport(..)
    , CsMode(..)
    , CsOption(..)
    , CsOptionState(..)
    , CsOperand(..)
    , CsGroup(..)
    , CsDetail(..)
    , peekDetail
    , CsInsn(..)
    , csInsnOffset
    , CsErr(..)
    , csSupport
    , csOpen
    , csClose
    , csOption
    , csErrno
    , csStrerror
    , csDisasm
    , csFree
    , csMalloc
    , csRegName
    , csInsnName
    , csGroupName
    , csInsnGroup
    , csRegRead
    , csRegWrite
    , csOpCount
    , csOpIndex
    ) where

{-
A few notes on API design

This is just a roughly 1:1 translation of the capstone C headers to Haskell.
Obviously, it isn't a very pleasant experience to use, so a higher-level API
is needed. The approach there would be like follows:
* determine the common workflows with capstone (this is easy)
* write wrappers around those workflows

The most notorious issues:
* wrap allocation and deallocation of structs, so that each pure function is
  a no-op to the runtime
* wrap datatype conversion between architecture specific enumerations and
  interger types. This is best done via typeclasses or type families.
* wrap instruction structures to provide better architecture separation

Those should be less straightforward to handle and require some more work, a
few drafts should be easy to write, however.

-}

#include <capstone/capstone.h>

{#context lib = "capstone"#}

import Control.Monad (join)

import Foreign
import Foreign.C.Types
import Foreign.C.String (CString, peekCString, withCString)
import Foreign.Marshal.Array (peekArray, pokeArray)
import Foreign.Ptr

import Hapstone.Internal.Util
import qualified Hapstone.Internal.Arm64 as Arm64
import qualified Hapstone.Internal.Arm as Arm
import qualified Hapstone.Internal.Mips as Mips
import qualified Hapstone.Internal.Ppc as Ppc
import qualified Hapstone.Internal.Sparc as Sparc
import qualified Hapstone.Internal.SystemZ as SystemZ
import qualified Hapstone.Internal.X86 as X86
import qualified Hapstone.Internal.XCore as XCore

import System.IO.Unsafe (unsafePerformIO)

-- capstone's weird^M^M^M^M^Mopaque handle type
type Csh = CSize
{#typedef csh Csh#}

-- supported architectures
{#enum cs_arch as CsArch {underscoreToCase} deriving (Show)#}

-- support constants
{#enum define CsSupport
    { CS_SUPPORT_DIET as CsSupportDiet
    , CS_SUPPORT_X86_REDUCE as CsSupportX86Reduce} deriving (Show)#}

-- work modes
{#enum cs_mode as CsMode {underscoreToCase} deriving (Show)#}

-- TODO: we will skip user defined dynamic memory routines for now

-- options are, interestingly, represented by different types
{#enum cs_opt_type as CsOption {underscoreToCase} deriving (Show)#}
{#enum cs_opt_value as CsOptionState {underscoreToCase} deriving (Show)#}

-- arch-uniting operand type
{#enum cs_op_type as CsOperand {underscoreToCase} deriving (Show)#}

-- arch-uniting instruction group type
{#enum cs_group_type as CsGroup {underscoreToCase} deriving (Show)#}

-- TODO: what is this SKIPDATA business whose callback function
-- we happily omitted?

-- architecture specific information
data ArchInfo
    = X86 X86.CsX86
    | Arm64 Arm64.CsArm64
    | Arm Arm.CsArm
    | Mips Mips.CsMips
    | Ppc Ppc.CsPpc
    | Sparc Sparc.CsSparc
    | SysZ SystemZ.CsSysZ
    | XCore XCore.CsXCore
    deriving Show

-- instruction information
data CsDetail = CsDetail
    { regsRead :: [Word8]
    , regsWrite :: [Word8]
    , groups :: [Word8]
    , archInfo :: Maybe ArchInfo
    } deriving Show

-- the union holding architecture-specific info is not tagged. Thus, we have
-- no way to determine what kind of data is stored in it without resorting to
-- some kind of context lookup, as the C code would do. Thus, the
-- peek-inmplementation does not get architecture information, use peekDetail
-- for that.
instance Storable CsDetail where
    sizeOf _ = {#sizeof cs_detail#}
    alignment _ = {#alignof cs_detail#}
    peek p = CsDetail
        <$> do num <- fromIntegral <$> {#get cs_detail->regs_read_count#} p
               let ptr = plusPtr p {#offsetof cs_detail.regs_read#}
               peekArray num ptr
        <*> do num <- fromIntegral <$> {#get cs_detail->regs_write_count#} p
               let ptr = plusPtr p {#offsetof cs_detail.regs_write#}
               peekArray num ptr
        <*> do num <- fromIntegral <$> {#get cs_detail->groups_count#} p
               let ptr = plusPtr p {#offsetof cs_detail.groups#}
               peekArray num ptr
        <*> pure Nothing
    poke p (CsDetail rR rW g a) = do
        {#set cs_detail->regs_read_count#} p (fromIntegral $ length rR)
        if length rR > 12
           then error "regs_read overflew 12 bytes"
           else pokeArray (plusPtr p {#offsetof cs_detail.regs_read#}) rR
        {#set cs_detail->regs_write_count#} p (fromIntegral $ length rW)
        if length rW > 20
           then error "regs_write overflew 20 bytes"
           else pokeArray (plusPtr p {#offsetof cs_detail.regs_write#}) rW
        {#set cs_detail->groups_count#} p (fromIntegral $ length g)
        if length g > 8
           then error "groups overflew 8 bytes"
           else pokeArray (plusPtr p {#offsetof cs_detail.groups#}) g
        let bP = plusPtr p ({#offsetof cs_detail.groups_count#} + 1)
        case a of
          Just (X86 x) -> poke bP x
          Just (Arm64 x) -> poke bP x
          Just (Arm x) -> poke bP x
          Just (Mips x) -> poke bP x
          Just (Ppc x) -> poke bP x
          Just (Sparc x) -> poke bP x
          Just (SysZ x) -> poke bP x
          Just (XCore x) -> poke bP x
          Nothing -> return ()

-- an arch-sensitive peek for cs_detail
peekDetail :: CsArch -> Ptr CsDetail -> IO CsDetail
peekDetail arch p = do
    detail <- peek p
    let bP = plusPtr p ({#offsetof cs_detail.groups_count#} + 1)
    aI <- case arch of
            CsArchX86 -> X86 <$> peek (castPtr p)
            CsArchArm64 -> Arm64 <$> peek (castPtr p)
            CsArchArm -> Arm <$> peek (castPtr p)
            CsArchMips -> Mips <$> peek (castPtr p)
            CsArchPpc -> Ppc <$> peek (castPtr p)
            CsArchSparc -> Sparc <$> peek (castPtr p)
            CsArchSysz -> SysZ <$> peek (castPtr p)
            CsArchXcore -> XCore <$> peek (castPtr p)
    return detail { archInfo = Just aI }

-- instructions
data CsInsn = CsInsn
    { insnId :: Word32
    , address :: Word64
    , bytes :: [Word8]
    , mnemonic :: String
    , opStr :: String
    , detail :: CsDetail
    } deriving Show

-- The untagged-union-problem propagates here as well
instance Storable CsInsn where
    sizeOf _ = {#sizeof cs_insn#}
    alignment _ = {#alignof cs_insn#}
    peek p = CsInsn
        <$> (fromIntegral <$> {#get cs_insn->id#} p)
        <*> (fromIntegral <$> {#get cs_insn->address#} p)
        <*> do num <- fromIntegral <$> {#get cs_insn->size#} p
               let ptr = plusPtr p {#offsetof cs_insn->bytes#}
               peekArray num ptr
        <*> (peekCString =<< {#get cs_insn->mnemonic#} p)
        <*> (peekCString =<< {#get cs_insn->op_str#} p)
        <*> (castPtr <$> {#get cs_insn->detail#} p >>= peek)
    poke p (CsInsn i a b m o d) = do
        {#set cs_insn->id#} p (fromIntegral i)
        {#set cs_insn->address#} p (fromIntegral a)
        {#set cs_insn->size#} p (fromIntegral $ length b)
        if length b > 16
           then error "bytes overflew 16 bytes"
           else pokeArray (plusPtr p {#offsetof cs_insn.bytes#}) b
        if length m >= 32
           then error "mnemonic overflew 32 bytes"
           else withCString m ({#set cs_insn->mnemonic#} p)
        if length o >= 160
           then error "op_str overflew 160 bytes"
           else withCString o ({#set cs_insn->op_str#} p)
        csDetailPtr <- castPtr <$> ({#get cs_insn->detail#} p)
        poke csDetailPtr d

-- our own port of the CS_INSN_OFFSET macro
csInsnOffset :: Ptr CsInsn -> Int -> Int
csInsnOffset p n = unsafePerformIO $
    (-) <$> getAddr (plusPtr p (n * {#sizeof cs_insn#})) <*> getAddr p
    where getAddr p = fromIntegral <$> {#get cs_insn->address#} p

-- possible error conditions
{#enum cs_err as CsErr {underscoreToCase} deriving (Show)#}

-- get the library version
{#fun pure cs_version as ^
    {alloca- `Int' peekNum*, alloca- `Int' peekNum*} -> `Int'#}

-- get information on supported features
foreign import ccall "capstone/capstone.h cs_support"
    csSupport' :: CInt -> Bool
csSupport :: Enum a => a -> Bool
csSupport = csSupport' . fromIntegral . fromEnum

-- open a new disassembly handle
{#fun cs_open as ^
    {`CsArch', combine `[CsMode]', alloca- `Csh' peek*} -> `CsErr'#}

-- close a handle obtained by cs_open/csOpen
{#fun cs_close as ^ {id `Ptr Csh'} -> `CsErr'#}

-- set an option on a handle
{#fun cs_option as ^ `Enum a' =>
    {`Csh', `CsOption', getCULongFromEnum `a'} -> `CsErr'#}

-- get the last error from a handle
{#fun cs_errno as ^ {`Csh'} -> `CsErr'#}

-- get the description of an error
{#fun cs_strerror as ^ {`CsErr'} -> `String'#}

-- disassemble a buffer
foreign import ccall "capstone/capstone.h cs_disasm"
    csDisasm' :: Csh -- handle
              -> Ptr CUChar -> CSize -- buffer to disassemble
              -> CULong -- address to start at
              -> CSize -- number of instructins to disassemble
              -> Ptr (Ptr CsInsn) -- where to put the instructions
              -> IO CSize -- number of succesfully disassembled instructions

csDisasm :: Csh -> [Word8] -> Word64 -> Int -> IO [CsInsn]
csDisasm handle bytes addr num = do
    array <- newArray $ map fromIntegral bytes
    passedPtr <- malloc :: IO (Ptr (Ptr CsInsn))
    resNum <- fromIntegral <$> csDisasm' handle array
        (fromIntegral $ length bytes) (fromIntegral addr)
        (fromIntegral num) passedPtr
    resPtr <- peek passedPtr
    free passedPtr
    res <- mapM (peek . plusPtr resPtr . ({#sizeof cs_insn#} *)) [0..resNum]
    csFree resPtr resNum
    return res

-- free an instruction struct array
{#fun cs_free as ^ {castPtr `Ptr CsInsn', `Int'} -> `()'#}

-- allocate space for an instruction struct
{#fun cs_malloc as ^ {`Csh'} -> `Ptr CsInsn' castPtr#}

-- TODO: decide whether we want cs_disasm_iter

-- get a register's name as a String
{#fun pure cs_reg_name as csRegName' {`Csh', `Int'} -> `CString'#}
csRegName :: Enum e => Csh -> e -> Maybe String
csRegName h = stringLookup . csRegName' h . fromEnum

-- get a instruction's name as a String
{#fun pure cs_insn_name as csInsnName' {`Csh', `Int'} -> `CString'#}
csInsnName :: Enum e => Csh -> e -> Maybe String
csInsnName h = stringLookup . csInsnName' h . fromEnum

-- get a instruction group's name as a String
{#fun pure cs_group_name as csGroupName' {`Csh', `Int'} -> `CString'#}
csGroupName :: Enum e => Csh -> e -> Maybe String
csGroupName h = stringLookup . csGroupName' h . fromEnum

-- check whether an instruction is member of a group
foreign import ccall "capstone/capstone.h cs_insn_group"
    csInsnGroup' :: Csh -> Ptr CsInsn -> IO Bool
csInsnGroup :: Csh -> CsInsn -> Bool
csInsnGroup h i = unsafePerformIO . withCast i $ csInsnGroup' h

-- check whether an instruction reads from a register
foreign import ccall "capstone/capstone.h cs_reg_read"
    csRegRead' :: Csh -> Ptr CsInsn -> CUInt -> IO Bool
csRegRead :: Csh -> CsInsn -> Int -> Bool
csRegRead h i =
    unsafePerformIO . withCast i . flip (csRegRead' h) . fromIntegral

-- check whether an instruction writes to a register
foreign import ccall "capstone/capstone.h cs_reg_write"
    csRegWrite' :: Csh -> Ptr CsInsn -> CUInt -> IO Bool
csRegWrite :: Csh -> CsInsn -> Int -> Bool
csRegWrite h i =
    unsafePerformIO . withCast i . flip (csRegWrite' h) . fromIntegral

-- return the number of operands of given type an instruction has
{#fun pure cs_op_count as ^
    {`Csh', withCast* `CsInsn', `Int'} -> `Int'#}

-- return the position of the first operand of given type an instruction has,
-- given an inclusive search range
{#fun pure cs_op_index as ^
    {`Csh', withCast* `CsInsn', `Int', `Int'} -> `Int'#}