Scaffold out more stuff in the new knot tying function

{-# LANGUAGE ForeignFunctionInterface, RankNTypes #-}
module Data.LLVM.Private.Unmarshal where

#include "c++/marshal.h"

import Control.Applicative
import Control.Monad.State
import Data.Array.Storable
import Data.HashMap.Strict ( HashMap )
import qualified Data.HashMap.Strict as M
import Foreign.C
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable

import Data.LLVM.Private.C2HS
import Data.LLVM.Types

{#enum CmpPredicate {underscoreToCase} deriving (Show, Eq) #}
{#enum CallingConvention {} deriving (Show, Eq) #}
{#enum TypeTag {} deriving (Show, Eq) #}
{#enum ValueTag {underscoreToCase} deriving (Show, Eq) #}
{#enum LinkageType {} deriving (Show, Eq) #}
{#enum VisibilityType {} deriving (Show, Eq) #}

data CModule
{#pointer *CModule as ModulePtr -> CModule #}

cModuleIdentifier :: ModulePtr -> IO String
cModuleIdentifier m = ({#get CModule->moduleIdentifier#} m) >>= peekCString

cModuleDataLayout :: ModulePtr -> IO String
cModuleDataLayout m = ({#get CModule->moduleDataLayout#} m) >>= peekCString

cModuleTargetTriple :: ModulePtr -> IO String
cModuleTargetTriple m = ({#get CModule->targetTriple#} m) >>= peekCString

cModuleInlineAsm :: ModulePtr -> IO String
cModuleInlineAsm m = ({#get CModule->moduleInlineAsm#} m) >>= peekCString

cModuleHasError :: ModulePtr -> IO Bool
cModuleHasError m = cToBool <$> ({#get CModule->hasError#} m)

cModuleErrorMessage :: ModulePtr -> IO String
cModuleErrorMessage m = ({#get CModule->errMsg#} m) >>= peekCString

cModuleLittleEndian :: ModulePtr -> IO Bool
cModuleLittleEndian m = cToBool <$> ({#get CModule->littleEndian#} m)

cModulePointerSize :: ModulePtr -> IO Int
cModulePointerSize m = cIntConv <$> ({#get CModule->pointerSize#} m)

cModuleGlobalVariables :: ModulePtr -> IO (StorableArray Int ValuePtr)
cModuleGlobalVariables m =
  peekArray m {#get CModule->globalVariables#} {#get CModule->numGlobalVariables#}

cModuleGlobalAliases :: ModulePtr -> IO (StorableArray Int ValuePtr)
cModuleGlobalAliases m =
  peekArray m ({#get CModule->globalAliases#}) ({#get CModule->numGlobalAliases#})

cModuleFunctions :: ModulePtr -> IO (StorableArray Int ValuePtr)
cModuleFunctions m =
  peekArray m ({#get CModule->functions#}) ({#get CModule->numFunctions#})

peekArray :: forall a b c i e . (Ix i, Integral i, Integral c) =>
             a -> (a -> IO (Ptr b)) -> (a -> IO c) -> IO (StorableArray i e)
peekArray obj arrAccessor sizeAccessor = do
  nElts <- sizeAccessor obj
  arrPtr <- arrAccessor obj
  fArrPtr <- newForeignPtr_ (castPtr arrPtr)
  unsafeForeignPtrToStorableArray fArrPtr (1, cIntConv nElts)

data CType = CType TypeTag Int Bool Bool (Ptr TypePtr) Int TypePtr String
{#pointer *CType as TypePtr -> CType #}

data CValue = CValue ValueTag TypePtr String (Ptr ()) (Ptr ())
{#pointer *CValue as ValuePtr -> CValue #}

{#fun marshalLLVM { `String' } -> `ModulePtr' id #}
{#fun disposeCModule { id `ModulePtr' } -> `()' #}

data KnotState = KnotState { valueMap :: HashMap Int Int }

translate :: FilePath -> IO (Either String Module)
translate bitcodefile = do
  m <- marshalLLVM bitcodefile
  let initialState = KnotState { valueMap = M.empty }

  hasError <- cModuleHasError m
  case hasError of
    True -> do
      err <- cModuleErrorMessage m
      disposeCModule m
      return $! Left err
    False -> do
      (ir, _) <- evalStateT (mfix (tieKnot m)) initialState

      disposeCModule m
      return $! Right ir

type KnotMonad = StateT KnotState IO

tieKnot :: ModulePtr -> (Module, KnotState) -> KnotMonad (Module, KnotState)
tieKnot m (_, finalState) = do
  s <- get
  return (undefined, s)

{-# LANGUAGE ForeignFunctionInterface, RankNTypes #-}
module Data.LLVM.Private.Unmarshal where

#include "c++/marshal.h"

import Control.Applicative
import Control.Monad.State
import Data.Array.Storable
import Data.HashMap.Strict ( HashMap )
import qualified Data.HashMap.Strict as M
import Foreign.C
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable
import Data.LLVM.Private.C2HS

{#enum CmpPredicate {underscoreToCase} deriving (Show, Eq) #}
{#enum CallingConvention {} deriving (Show, Eq) #}
{#enum TypeTag {} deriving (Show, Eq) #}
{#enum ValueTag {underscoreToCase} deriving (Show, Eq) #}
{#enum LinkageType {} deriving (Show, Eq) #}
{#enum VisibilityType {} deriving (Show, Eq) #}

data CModule
{#pointer *CModule as ModulePtr -> CModule #}

cModuleIdentifier :: ModulePtr -> IO String
cModuleIdentifier m = ({#get CModule->moduleIdentifier#} m) >>= peekCString

cModuleDataLayout :: ModulePtr -> IO String
cModuleDataLayout m = ({#get CModule->moduleDataLayout#} m) >>= peekCString

cModuleTargetTriple :: ModulePtr -> IO String
cModuleTargetTriple m = ({#get CModule->targetTriple#} m) >>= peekCString

cModuleInlineAsm :: ModulePtr -> IO String
cModuleInlineAsm m = ({#get CModule->moduleInlineAsm#} m) >>= peekCString

cModuleHasError :: ModulePtr -> IO Bool
cModuleHasError m = cToBool <$> ({#get CModule->hasError#} m)

cModuleErrorMessage :: ModulePtr -> IO String
cModuleErrorMessage m = ({#get CModule->errMsg#} m) >>= peekCString

cModuleLittleEndian :: ModulePtr -> IO Bool
cModuleLittleEndian m = cToBool <$> ({#get CModule->littleEndian#} m)

cModulePointerSize :: ModulePtr -> IO Int
cModulePointerSize m = cIntConv <$> ({#get CModule->pointerSize#} m)

cModuleGlobalVariables :: ModulePtr -> IO (StorableArray Int ValuePtr)
cModuleGlobalVariables m =
  peekArray m {#get CModule->globalVariables#} {#get CModule->numGlobalVariables#}

cModuleGlobalAliases :: ModulePtr -> IO (StorableArray Int ValuePtr)
cModuleGlobalAliases m =
  peekArray m ({#get CModule->globalAliases#}) ({#get CModule->numGlobalAliases#})

cModuleFunctions :: ModulePtr -> IO (StorableArray Int ValuePtr)
cModuleFunctions m =
  peekArray m ({#get CModule->functions#}) ({#get CModule->numFunctions#})

peekArray :: forall a b c i e . (Ix i, Integral i, Integral c) =>
             a -> (a -> IO (Ptr b)) -> (a -> IO c) -> IO (StorableArray i e)
peekArray obj arrAccessor sizeAccessor = do
  nElts <- sizeAccessor obj
  arrPtr <- arrAccessor obj
  fArrPtr <- newForeignPtr_ (castPtr arrPtr)
  unsafeForeignPtrToStorableArray fArrPtr (1, cIntConv nElts)

data CType = CType TypeTag Int Bool Bool (Ptr TypePtr) Int TypePtr String
{#pointer *CType as TypePtr -> CType #}

data CValue = CValue ValueTag TypePtr String (Ptr ()) (Ptr ())
{#pointer *CValue as ValuePtr -> CValue #}

{#fun marshalLLVM { `String' } -> `ModulePtr' id #}
{#fun disposeCModule { id `ModulePtr' } -> `()' #}

data KnotState = KnotState { valueMap :: HashMap Int Int }

translate bitcodefile = do
  m <- marshalLLVM bitcodefile

  let initialState = KnotState { valueMap = M.empty }
  (ir, finalState) <- evalStateT (mfix (tieKnot m)) initialState

  disposeCModule m
  return ir

tieKnot m (_, finalState) = return (undefined, finalState)


Fix types, remove key binding signals.

Fix types, remove key binding signals.

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Dialog
--
--  Author : Axel Simon, Andy Stewart
--
--  Created: 23 May 2001
--
--  Copyright (C) 1999-2005 Axel Simon
--  Copyright (C) 2009 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)
--
-- Create popup windows
--
-- NOTE:
--     Now FFI haven't support variadic function `gtk_dialog_set_alternative_button_order`
--
module Graphics.UI.Gtk.Windows.Dialog (
-- * Detail
--
-- | Dialog boxes are a convenient way to prompt the user for a small amount
-- of input, e.g. to display a message, ask a question, or anything else that
-- does not require extensive effort on the user's part.
--
-- Gtk+ treats a dialog as a window split vertically. The top section is a
-- 'VBox', and is where widgets such as a 'Label' or a 'Entry' should be
-- packed. The bottom area is known as the action_area. This is generally used
-- for packing buttons into the dialog which may perform functions such as
-- cancel, ok, or apply. The two areas are separated by a 'HSeparator'.
--
-- 'Dialog' boxes are created with a call to 'dialogNew' or
-- 'dialogNewWithButtons'. 'dialogNewWithButtons' is recommended; it allows you
-- to set the dialog title, some convenient flags, and add simple buttons.
--
-- If \'dialog\' is a newly created dialog, the two primary areas of the
-- window can be accessed using 'dialogGetUpper' and
-- 'dialogGetActionArea'.
--
-- A \'modal\' dialog (that is, one which freezes the rest of the
-- application from user input), can be created by calling 'windowSetModal' on
-- the dialog. When using 'dialogNewWithButtons' you can also
-- pass the 'DialogModal' flag to make a dialog modal.
--
-- If you add buttons to 'Dialog' using 'dialogNewWithButtons',
-- 'dialogAddButton', 'dialogAddButtons', or 'dialogAddActionWidget', clicking
-- the button will emit a signal called \"response\" with a response ID that
-- you specified. Gtk+ will never assign a meaning to positive response IDs;
-- these are entirely user-defined. But for convenience, you can use the
-- response IDs in the 'ResponseType' enumeration (these all have values less
-- than zero). If a dialog receives a delete event, the \"response\" signal
-- will be emitted with a response ID of 'ResponseNone'.
--
-- If you want to block waiting for a dialog to return before returning
-- control flow to your code, you can call 'dialogRun'. This function enters a
-- recursive main loop and waits for the user to respond to the dialog,
-- returning the response ID corresponding to the button the user clicked.
--
-- For a simple message box, you probably want to use
-- 'Graphics.UI.Gtk.Windows.MessageDialog.MessageDialog' which provides
-- convenience functions
-- for creating standard dialogs containing simple messages to inform
-- or ask the user.

-- * Class Hierarchy
-- |
-- @
-- |  'GObject'
-- |   +----'Object'
-- |         +----'Widget'
-- |               +----'Container'
-- |                     +----'Bin'
-- |                           +----'Window'
-- |                                 +----Dialog
-- |                                       +----'AboutDialog'
-- |                                       +----'ColorSelectionDialog'
-- |                                       +----'FileChooserDialog'
-- |                                       +----'FileSelection'
-- |                                       +----'FontSelectionDialog'
-- |                                       +----'InputDialog'
-- |                                       +----'MessageDialog'
-- @

-- * Types
  Dialog,
  DialogClass,
  castToDialog,
  toDialog,

-- * Constructors
  dialogNew,

-- * Methods
  dialogGetUpper,
  dialogGetActionArea,
  dialogRun,
  dialogResponse,
  ResponseId(..),
  dialogAddButton,
  dialogAddActionWidget,
  dialogGetHasSeparator,
  dialogSetDefaultResponse,
  dialogSetHasSeparator,
  dialogSetResponseSensitive,
  dialogGetResponseForWidget,
  dialogAlternativeDialogButtonOrder,
  dialogSetAlternativeButtonOrderFromArray,

-- * Attributes
  dialogHasSeparator,
  dialogActionAreaBorder,
  dialogButtonSpacing,
  dialogContentAreaBorder,
  dialogContentAreaSpacing,

-- * Signals
  response,

-- * Deprecated
#ifndef DISABLE_DEPRECATED
  onResponse,
  afterResponse,
#endif
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.Attributes
import System.Glib.Properties
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}
import Graphics.UI.Gtk.General.Structs	(dialogGetUpper, dialogGetActionArea,
					ResponseId(..), fromResponse, toResponse)

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

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

-- | Creates a new dialog box. Widgets should not be packed into this 'Window'
-- directly, but into the \"upper\" and \"action area\", which are obtained
-- using 'dialogGetUpper' and 'dialogGetActionArea'.
--
dialogNew :: IO Dialog
dialogNew =
  makeNewObject mkDialog $
  liftM (castPtr :: Ptr Widget -> Ptr Dialog) $
  {# call unsafe dialog_new #}

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

-- | Blocks in a recursive main loop until the dialog either emits the
-- response signal, or is destroyed. If the dialog is destroyed during the call
-- to 'dialogRun', it returns 'ResponseNone'. Otherwise, it returns the
-- response ID from the \"response\" signal emission. Before entering the
-- recursive main loop, 'dialogRun' calls 'widgetShow' on the dialog for you.
-- Note that you still need to show any children of the dialog yourself.
--
-- During 'dialogRun', the default behavior of \"delete_event\" is disabled;
-- if the dialog receives \"delete_event\", it will not be destroyed as windows
-- usually are, and 'dialogRun' will return 'ResponseDeleteEvent'. Also, during
-- 'dialogRun' the dialog will be modal. You can force 'dialogRun' to return at
-- any time by calling 'dialogResponse' to emit the \"response\" signal.
-- Destroying the dialog during 'dialogRun' is a very bad idea, because your
-- post-run code won't know whether the dialog was destroyed or not.
-- Hence, you should not call 'Graphics.UI.Gtk.Abstract.widgetDestroy'
-- before 'dialogRun' has returned.
--
-- After 'dialogRun' returns, you are responsible for hiding or destroying
-- the dialog if you wish to do so.
--
-- Note that even though the recursive main loop gives the effect of a modal
-- dialog (it prevents the user from interacting with other windows while the
-- dialog is run), callbacks such as timeouts, IO channel watches, DND drops,
-- etc, /will/ be triggered during a 'dialogRun' call.
--
dialogRun :: DialogClass self => self
 -> IO ResponseId
dialogRun self =
  liftM toResponse $
  {# call dialog_run #}
    (toDialog self)

-- | Emits the \"response\" signal with the given response ID. Used to
-- indicate that the user has responded to the dialog in some way; typically
-- either you or 'dialogRun' will be monitoring the \"response\" signal and
-- take appropriate action.
--
-- This function can be used to add a custom widget to the action area that
-- should close the dialog when activated or to close the dialog otherwise.
--
dialogResponse :: DialogClass self => self
 -> ResponseId
 -> IO ()
dialogResponse self responseId =
  {# call dialog_response #}
    (toDialog self)
    (fromResponse responseId)

-- | Adds a button with the given text (or a stock button, if @buttonText@ is
-- a stock ID) and sets things up so that clicking the button will emit the
-- \"response\" signal with the given @responseId@. The button is appended to
-- the end of the dialog's action area. The button widget is returned, but
-- usually you don't need it.
--
dialogAddButton :: DialogClass self => self
 -> String     -- ^ @buttonText@ - text of button, or stock ID
 -> ResponseId -- ^ @responseId@ - response ID for the button
 -> IO Button  -- ^ returns the button widget that was added
dialogAddButton self buttonText responseId =
  makeNewObject mkButton $ liftM castPtr $
  withUTFString buttonText $ \buttonTextPtr ->
  {# call dialog_add_button #}
    (toDialog self)
    buttonTextPtr
    (fromResponse responseId)

-- | Adds an activatable widget to the action area of a 'Dialog', connecting a
-- signal handler that will emit the \"response\" signal on the dialog when the
-- widget is activated. The widget is appended to the end of the dialog's
-- action area. If you want to add a non-activatable widget, simply pack it
-- into the action area.
--
dialogAddActionWidget :: (DialogClass self, WidgetClass child) => self
 -> child      -- ^ @child@ - an activatable widget
 -> ResponseId -- ^ @responseId@ - response ID for @child@
 -> IO ()
dialogAddActionWidget self child responseId =
  {# call dialog_add_action_widget #}
    (toDialog self)
    (toWidget child)
    (fromResponse responseId)

-- | Query if the dialog has a visible horizontal separator.
--
dialogGetHasSeparator :: DialogClass self => self -> IO Bool
dialogGetHasSeparator self =
  liftM toBool $
  {# call unsafe dialog_get_has_separator #}
    (toDialog self)

-- | Sets the last widget in the dialog's action area with the given
-- 'ResponseId' as the default widget for the dialog. Pressing \"Enter\"
-- normally activates the default widget.
--
-- * The default response is reset once it is triggered. Hence, if you
--   hide the dialog (rather than closing it) and re-display it later,
--   you need to call this function again.
--
dialogSetDefaultResponse :: DialogClass self => self
 -> ResponseId
 -> IO ()
dialogSetDefaultResponse self responseId =
  {# call dialog_set_default_response #}
    (toDialog self)
    (fromResponse responseId)

-- | Sets whether the dialog has a separator above the buttons. @True@ by
-- default.
--
dialogSetHasSeparator :: DialogClass self => self -> Bool -> IO ()
dialogSetHasSeparator self setting =
  {# call dialog_set_has_separator #}
    (toDialog self)
    (fromBool setting)

-- | Calls @'widgetSetSensitive' widget setting@ for each widget in the
-- dialog's action area with the given @responseId@. A convenient way to
-- sensitize\/desensitize dialog buttons.
--
dialogSetResponseSensitive :: DialogClass self => self
 -> ResponseId -- ^ @responseId@ - a response ID
 -> Bool       -- ^ @setting@ - @True@ for sensitive
 -> IO ()
dialogSetResponseSensitive self responseId setting =
  {# call dialog_set_response_sensitive #}
    (toDialog self)
    (fromResponse responseId)
    (fromBool setting)

-- | Gets the response id of a widget in the action area of a dialog.
dialogGetResponseForWidget :: (DialogClass self, WidgetClass widget) => self
 -> widget  -- ^ @widget@ - a widget in the action area of dialog
 -> IO ResponseId  -- ^ return the response id of widget, or 'ResponseNone' if widget doesn't have a response id set.
dialogGetResponseForWidget self widget = liftM toResponse $
  {# call dialog_get_response_for_widget #}
    (toDialog self)
    (toWidget widget)

-- | Returns @True@ if dialogs are expected to use an alternative button order on the screen screen.
-- See 'dialogSetAlternativeButtonOrder' for more details about alternative button order.
--
-- If you need to use this function, you should probably connect to the 'alternativeButtonOrder' signal on the GtkSettings object associated to  screen, in order to be notified if the button order setting changes.
--
-- * Available since Gtk+ version 2.6
--
dialogAlternativeDialogButtonOrder ::
   Maybe Screen  -- ^ @screen@ - a 'Screen', or @Nothing@ to use the default screen
 -> IO Bool   -- ^ returns whether the alternative button order should be used
dialogAlternativeDialogButtonOrder (Just screen) = liftM toBool $
  {# call alternative_dialog_button_order #} screen
dialogAlternativeDialogButtonOrder Nothing = liftM toBool $
  {# call alternative_dialog_button_order #} (Screen nullForeignPtr)

-- | Sets an alternative button order.
--
-- If the 'alternativeButtonOrder' setting is set to @True@, the dialog
-- buttons are reordered according to the order of the response ids in
-- @newOrder@.
--
-- See 'dialogSetAlternativeButtonOrder' for more information.
--
-- This function is for use by language bindings.
--
-- * Available since Gtk+ version 2.6
--
dialogSetAlternativeButtonOrderFromArray :: DialogClass self => self
 -> [ResponseId]  -- ^ @newOrder@ - an array of response ids of dialog's buttons
 -> IO ()
dialogSetAlternativeButtonOrderFromArray self newOrder =
  withArray (map fromResponse newOrder) $ \newOrderPtr ->
  {# call dialog_set_alternative_button_order_from_array #}
    (toDialog self)
    (fromIntegral (length newOrder))
    newOrderPtr

--------------------
-- Attributes

-- | The dialog has a separator bar above its buttons.
--
-- Default value: @True@
--
dialogHasSeparator :: DialogClass self => Attr self Bool
dialogHasSeparator = newAttr
  dialogGetHasSeparator
  dialogSetHasSeparator

-- | Width of border around the button area at the bottom of the dialog.
--
-- Allowed values: >= 0
--
-- Default value: 5
--
dialogActionAreaBorder :: DialogClass self => ReadAttr self Int
dialogActionAreaBorder = readAttrFromIntProperty "action-area-border"

-- | Spacing between buttons.
--
-- Allowed values: >= 0
--
-- Default value: 6
--
dialogButtonSpacing :: DialogClass self => ReadAttr self Int
dialogButtonSpacing = readAttrFromIntProperty "button-spacing"

-- | Width of border around the main dialog area.
--
-- Allowed values: >= 0
--
-- Default value: 2
--
dialogContentAreaBorder :: DialogClass self => ReadAttr self Int
dialogContentAreaBorder = readAttrFromIntProperty "content-area-border"

-- | The default spacing used between elements of the content area of the dialog,
-- as returned by 'dialogSetContentArea', unless 'boxSetSpacing' was called on that widget directly.
--
-- Allowed values: >= 0
--
-- Default value: 0
--
-- * Available since Gtk+ version 2.16
--
dialogContentAreaSpacing :: DialogClass self => ReadAttr self Int
dialogContentAreaSpacing = readAttrFromIntProperty "content-area-spacing"

--------------------
-- Signals

-- | Emitted when an action widget is clicked, the dialog receives a delete
-- event, or the application programmer calls 'dialogResponse'. On a delete
-- event, the response ID is 'ResponseNone'. Otherwise, it depends on which
-- action widget was clicked.
--
response :: DialogClass self => Signal self (ResponseId -> IO ())
response = Signal (\after obj fun ->
                   connect_INT__NONE "response" after obj (\i -> fun (toResponse i)))

-- * Deprecated
#ifndef DISABLE_DEPRECATED
-- | Emitted when an action widget is clicked, the dialog receives a delete
-- event, or the application programmer calls 'dialogResponse'. On a delete
-- event, the response ID is 'ResponseNone'. Otherwise, it depends on which
-- action widget was clicked.
--
onResponse, afterResponse :: DialogClass self => self
 -> (ResponseId -> IO ())
 -> IO (ConnectId self)
onResponse dia act = connect_INT__NONE "response" False dia (act . toResponse)
afterResponse dia act = connect_INT__NONE "response" True dia (act . toResponse)
#endif

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Dialog
--
--  Author : Axel Simon, Andy Stewart
--
--  Created: 23 May 2001
--
--  Copyright (C) 1999-2005 Axel Simon
--  Copyright (C) 2009 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)
--
-- Create popup windows
--
-- NOTE:
--     Now FFI haven't support variadic function `gtk_dialog_set_alternative_button_order`
--
module Graphics.UI.Gtk.Windows.Dialog (
-- * Detail
--
-- | Dialog boxes are a convenient way to prompt the user for a small amount
-- of input, e.g. to display a message, ask a question, or anything else that
-- does not require extensive effort on the user's part.
--
-- Gtk+ treats a dialog as a window split vertically. The top section is a
-- 'VBox', and is where widgets such as a 'Label' or a 'Entry' should be
-- packed. The bottom area is known as the action_area. This is generally used
-- for packing buttons into the dialog which may perform functions such as
-- cancel, ok, or apply. The two areas are separated by a 'HSeparator'.
--
-- 'Dialog' boxes are created with a call to 'dialogNew' or
-- 'dialogNewWithButtons'. 'dialogNewWithButtons' is recommended; it allows you
-- to set the dialog title, some convenient flags, and add simple buttons.
--
-- If \'dialog\' is a newly created dialog, the two primary areas of the
-- window can be accessed using 'dialogGetUpper' and
-- 'dialogGetActionArea'.
--
-- A \'modal\' dialog (that is, one which freezes the rest of the
-- application from user input), can be created by calling 'windowSetModal' on
-- the dialog. When using 'dialogNewWithButtons' you can also
-- pass the 'DialogModal' flag to make a dialog modal.
--
-- If you add buttons to 'Dialog' using 'dialogNewWithButtons',
-- 'dialogAddButton', 'dialogAddButtons', or 'dialogAddActionWidget', clicking
-- the button will emit a signal called \"response\" with a response ID that
-- you specified. Gtk+ will never assign a meaning to positive response IDs;
-- these are entirely user-defined. But for convenience, you can use the
-- response IDs in the 'ResponseType' enumeration (these all have values less
-- than zero). If a dialog receives a delete event, the \"response\" signal
-- will be emitted with a response ID of 'ResponseNone'.
--
-- If you want to block waiting for a dialog to return before returning
-- control flow to your code, you can call 'dialogRun'. This function enters a
-- recursive main loop and waits for the user to respond to the dialog,
-- returning the response ID corresponding to the button the user clicked.
--
-- For a simple message box, you probably want to use
-- 'Graphics.UI.Gtk.Windows.MessageDialog.MessageDialog' which provides
-- convenience functions
-- for creating standard dialogs containing simple messages to inform
-- or ask the user.

-- * Class Hierarchy
-- |
-- @
-- |  'GObject'
-- |   +----'Object'
-- |         +----'Widget'
-- |               +----'Container'
-- |                     +----'Bin'
-- |                           +----'Window'
-- |                                 +----Dialog
-- |                                       +----'AboutDialog'
-- |                                       +----'ColorSelectionDialog'
-- |                                       +----'FileChooserDialog'
-- |                                       +----'FileSelection'
-- |                                       +----'FontSelectionDialog'
-- |                                       +----'InputDialog'
-- |                                       +----'MessageDialog'
-- @

-- * Types
  Dialog,
  DialogClass,
  castToDialog,
  toDialog,

-- * Constructors
  dialogNew,

-- * Methods
  dialogGetUpper,
  dialogGetActionArea,
  dialogRun,
  dialogResponse,
  ResponseId(..),
  dialogAddButton,
  dialogAddActionWidget,
  dialogGetHasSeparator,
  dialogSetDefaultResponse,
  dialogSetHasSeparator,
  dialogSetResponseSensitive,
  dialogGetResponseForWidget,
  alternativeDialogButtonOrder,
  dialogSetAlternativeButtonOrderFromArray,

-- * Attributes
  dialogHasSeparator,
  dialogActionAreaBorder,
  dialogButtonSpacing,
  dialogContentAreaBorder,
  dialogContentAreaSpacing,

-- * Signals
  close,
  response,

-- * Deprecated
#ifndef DISABLE_DEPRECATED
  onResponse,
  afterResponse,
#endif
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.Attributes
import System.Glib.Properties
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}
import Graphics.UI.Gtk.General.Structs	(dialogGetUpper, dialogGetActionArea,
					ResponseId(..), fromResponse, toResponse)

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

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

-- | Creates a new dialog box. Widgets should not be packed into this 'Window'
-- directly, but into the \"upper\" and \"action area\", which are obtained
-- using 'dialogGetUpper' and 'dialogGetActionArea'.
--
dialogNew :: IO Dialog
dialogNew =
  makeNewObject mkDialog $
  liftM (castPtr :: Ptr Widget -> Ptr Dialog) $
  {# call unsafe dialog_new #}

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

-- | Blocks in a recursive main loop until the dialog either emits the
-- response signal, or is destroyed. If the dialog is destroyed during the call
-- to 'dialogRun', it returns 'ResponseNone'. Otherwise, it returns the
-- response ID from the \"response\" signal emission. Before entering the
-- recursive main loop, 'dialogRun' calls 'widgetShow' on the dialog for you.
-- Note that you still need to show any children of the dialog yourself.
--
-- During 'dialogRun', the default behavior of \"delete_event\" is disabled;
-- if the dialog receives \"delete_event\", it will not be destroyed as windows
-- usually are, and 'dialogRun' will return 'ResponseDeleteEvent'. Also, during
-- 'dialogRun' the dialog will be modal. You can force 'dialogRun' to return at
-- any time by calling 'dialogResponse' to emit the \"response\" signal.
-- Destroying the dialog during 'dialogRun' is a very bad idea, because your
-- post-run code won't know whether the dialog was destroyed or not.
-- Hence, you should not call 'Graphics.UI.Gtk.Abstract.widgetDestroy'
-- before 'dialogRun' has returned.
--
-- After 'dialogRun' returns, you are responsible for hiding or destroying
-- the dialog if you wish to do so.
--
-- Note that even though the recursive main loop gives the effect of a modal
-- dialog (it prevents the user from interacting with other windows while the
-- dialog is run), callbacks such as timeouts, IO channel watches, DND drops,
-- etc, /will/ be triggered during a 'dialogRun' call.
--
dialogRun :: DialogClass self => self
 -> IO ResponseId
dialogRun self =
  liftM toResponse $
  {# call dialog_run #}
    (toDialog self)

-- | Emits the \"response\" signal with the given response ID. Used to
-- indicate that the user has responded to the dialog in some way; typically
-- either you or 'dialogRun' will be monitoring the \"response\" signal and
-- take appropriate action.
--
-- This function can be used to add a custom widget to the action area that
-- should close the dialog when activated or to close the dialog otherwise.
--
dialogResponse :: DialogClass self => self
 -> ResponseId
 -> IO ()
dialogResponse self responseId =
  {# call dialog_response #}
    (toDialog self)
    (fromResponse responseId)

-- | Adds a button with the given text (or a stock button, if @buttonText@ is
-- a stock ID) and sets things up so that clicking the button will emit the
-- \"response\" signal with the given @responseId@. The button is appended to
-- the end of the dialog's action area. The button widget is returned, but
-- usually you don't need it.
--
dialogAddButton :: DialogClass self => self
 -> String     -- ^ @buttonText@ - text of button, or stock ID
 -> ResponseId -- ^ @responseId@ - response ID for the button
 -> IO Button  -- ^ returns the button widget that was added
dialogAddButton self buttonText responseId =
  makeNewObject mkButton $ liftM castPtr $
  withUTFString buttonText $ \buttonTextPtr ->
  {# call dialog_add_button #}
    (toDialog self)
    buttonTextPtr
    (fromResponse responseId)

-- | Adds an activatable widget to the action area of a 'Dialog', connecting a
-- signal handler that will emit the \"response\" signal on the dialog when the
-- widget is activated. The widget is appended to the end of the dialog's
-- action area. If you want to add a non-activatable widget, simply pack it
-- into the action area.
--
dialogAddActionWidget :: (DialogClass self, WidgetClass child) => self
 -> child      -- ^ @child@ - an activatable widget
 -> ResponseId -- ^ @responseId@ - response ID for @child@
 -> IO ()
dialogAddActionWidget self child responseId =
  {# call dialog_add_action_widget #}
    (toDialog self)
    (toWidget child)
    (fromResponse responseId)

-- | Query if the dialog has a visible horizontal separator.
--
dialogGetHasSeparator :: DialogClass self => self -> IO Bool
dialogGetHasSeparator self =
  liftM toBool $
  {# call unsafe dialog_get_has_separator #}
    (toDialog self)

-- | Sets the last widget in the dialog's action area with the given
-- 'ResponseId' as the default widget for the dialog. Pressing \"Enter\"
-- normally activates the default widget.
--
-- * The default response is reset once it is triggered. Hence, if you
--   hide the dialog (rather than closing it) and re-display it later,
--   you need to call this function again.
--
dialogSetDefaultResponse :: DialogClass self => self
 -> ResponseId
 -> IO ()
dialogSetDefaultResponse self responseId =
  {# call dialog_set_default_response #}
    (toDialog self)
    (fromResponse responseId)

-- | Sets whether the dialog has a separator above the buttons. @True@ by
-- default.
--
dialogSetHasSeparator :: DialogClass self => self -> Bool -> IO ()
dialogSetHasSeparator self setting =
  {# call dialog_set_has_separator #}
    (toDialog self)
    (fromBool setting)

-- | Calls @'widgetSetSensitive' widget setting@ for each widget in the
-- dialog's action area with the given @responseId@. A convenient way to
-- sensitize\/desensitize dialog buttons.
--
dialogSetResponseSensitive :: DialogClass self => self
 -> ResponseId -- ^ @responseId@ - a response ID
 -> Bool       -- ^ @setting@ - @True@ for sensitive
 -> IO ()
dialogSetResponseSensitive self responseId setting =
  {# call dialog_set_response_sensitive #}
    (toDialog self)
    (fromResponse responseId)
    (fromBool setting)

-- | Gets the response id of a widget in the action area of a dialog.
dialogGetResponseForWidget :: (DialogClass self, WidgetClass widget) => self
 -> widget  -- ^ @widget@ - a widget in the action area of dialog
 -> IO Int  -- ^ return the response id of widget, or 'ResponseNone' if widget doesn't have a response id set.
dialogGetResponseForWidget self widget = liftM fromIntegral $
  {# call dialog_get_response_for_widget #}
    (toDialog self)
    (toWidget widget)

-- | Returns @True@ if dialogs are expected to use an alternative button order on the screen screen.
-- See 'dialogSetAlternativeButtonOrder' for more details about alternative button order.
--
-- If you need to use this function, you should probably connect to the 'alternativeButtonOrder' signal on the GtkSettings object associated to  screen, in order to be notified if the button order setting changes.
--
-- * Available since Gtk+ version 2.6
--
alternativeDialogButtonOrder ::
   Maybe Screen  -- ^ @screen@ - a 'Screen', or @Nothing@ to use the default screen
 -> IO Bool   -- ^ return Whether the alternative button order should be used
alternativeDialogButtonOrder (Just screen) = liftM toBool $
  {# call alternative_dialog_button_order #} screen
alternativeDialogButtonOrder Nothing = liftM toBool $
  {# call alternative_dialog_button_order #} (Screen nullForeignPtr)

-- | Sets an alternative button order.
-- If the 'alternativeButtonOrder' setting is set to @True@, the dialog buttons are reordered according to the order of the response ids in new_order.
--
-- See 'dialogSetAlternativeButtonOrder' for more information.
--
-- This function is for use by language bindings.
--
-- * Available since Gtk+ version 2.6
--
dialogSetAlternativeButtonOrderFromArray :: DialogClass self => self
 -> Int  -- ^ @nParams@ - the number of response ids in new_order
 -> [Int]  -- ^ @newOrder@ - an array of response ids of dialog's buttons
 -> IO ()
dialogSetAlternativeButtonOrderFromArray self nParams newOrder =
  withArray (map fromIntegral newOrder) $ \newOrderPtr ->
  {# call dialog_set_alternative_button_order_from_array #}
    (toDialog self)
    (fromIntegral nParams)
    newOrderPtr

--------------------
-- Attributes

-- | The dialog has a separator bar above its buttons.
--
-- Default value: @True@
--
dialogHasSeparator :: DialogClass self => Attr self Bool
dialogHasSeparator = newAttr
  dialogGetHasSeparator
  dialogSetHasSeparator

-- | Width of border around the button area at the bottom of the dialog.
--
-- Allowed values: >= 0
--
-- Default value: 5
--
dialogActionAreaBorder :: DialogClass self => ReadAttr self Int
dialogActionAreaBorder = readAttrFromIntProperty "action-area-border"

-- | Spacing between buttons.
--
-- Allowed values: >= 0
--
-- Default value: 6
--
dialogButtonSpacing :: DialogClass self => ReadAttr self Int
dialogButtonSpacing = readAttrFromIntProperty "button-spacing"

-- | Width of border around the main dialog area.
--
-- Allowed values: >= 0
--
-- Default value: 2
--
dialogContentAreaBorder :: DialogClass self => ReadAttr self Int
dialogContentAreaBorder = readAttrFromIntProperty "content-area-border"

-- | The default spacing used between elements of the content area of the dialog,
-- as returned by 'dialogSetContentArea', unless 'boxSetSpacing' was called on that widget directly.
--
-- Allowed values: >= 0
--
-- Default value: 0
--
-- * Available since Gtk+ version 2.16
--
dialogContentAreaSpacing :: DialogClass self => ReadAttr self Int
dialogContentAreaSpacing = readAttrFromIntProperty "content-area-spacing"

--------------------
-- Signals
close :: DialogClass self => Signal self (IO ())
close = Signal (connect_NONE__NONE "close")

response :: DialogClass self => Signal self (Int -> IO ())
response = Signal (connect_INT__NONE "response")

-- * Deprecated
#ifndef DISABLE_DEPRECATED
-- | Emitted when an action widget is clicked, the dialog receives a delete
-- event, or the application programmer calls 'dialogResponse'. On a delete
-- event, the response ID is 'ResponseNone'. Otherwise, it depends on which
-- action widget was clicked.
--
onResponse, afterResponse :: DialogClass self => self
 -> (ResponseId -> IO ())
 -> IO (ConnectId self)
onResponse dia act = connect_INT__NONE "response" False dia (act . toResponse)
afterResponse dia act = connect_INT__NONE "response" True dia (act . toResponse)
#endif


Add explicit export list for Error module

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE DeriveDataTypeable       #-}
{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Error
-- Copyright : [2009..2014] Trevor L. McDonell
-- License   : BSD
--
-- Error handling
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Error (

  -- * CUDA Errors
  Status(..), CUDAException(..),
  describe,
  cudaError, requireSDK,
  resultIfOk, nothingIfOk,

) where

-- Friends
import Foreign.CUDA.Internal.C2HS

-- System
import Control.Exception
import Control.Monad
import Data.Typeable
import Foreign.C
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import Language.Haskell.TH
import System.IO.Unsafe
import Text.Printf

#include "cbits/stubs.h"
{# context lib="cuda" #}

--------------------------------------------------------------------------------
-- Return Status
--------------------------------------------------------------------------------

--
-- Error Codes
--
{# enum CUresult as Status
    { underscoreToCase
    , CUDA_SUCCESS                      as Success
    , CUDA_ERROR_NO_BINARY_FOR_GPU      as NoBinaryForGPU
    , CUDA_ERROR_INVALID_PTX            as InvalidPTX
    , CUDA_ERROR_INVALID_PC             as InvalidPC
    }
    with prefix="CUDA_ERROR" deriving (Eq, Show) #}

-- |
-- Return a descriptive error string associated with a particular error code
--
describe :: Status -> String
#if CUDA_VERSION >= 6000
describe status
  = unsafePerformIO $ resultIfOk =<< cuGetErrorString status

{# fun unsafe cuGetErrorString
    { cFromEnum `Status'
    , alloca-   `String' ppeek* } -> `Status' cToEnum #}
    where
      ppeek = peek >=> peekCString

#else
describe Success                        = "no error"
describe InvalidValue                   = "invalid argument"
describe OutOfMemory                    = "out of memory"
describe NotInitialized                 = "driver not initialised"
describe Deinitialized                  = "driver deinitialised"
describe NoDevice                       = "no CUDA-capable device is available"
describe InvalidDevice                  = "invalid device ordinal"
describe InvalidImage                   = "invalid kernel image"
describe InvalidContext                 = "invalid context handle"
describe ContextAlreadyCurrent          = "context already current"
describe MapFailed                      = "map failed"
describe UnmapFailed                    = "unmap failed"
describe ArrayIsMapped                  = "array is mapped"
describe AlreadyMapped                  = "already mapped"
describe NoBinaryForGPU                 = "no binary available for this GPU"
describe AlreadyAcquired                = "resource already acquired"
describe NotMapped                      = "not mapped"
describe InvalidSource                  = "invalid source"
describe FileNotFound                   = "file not found"
describe InvalidHandle                  = "invalid handle"
describe NotFound                       = "not found"
describe NotReady                       = "device not ready"
describe LaunchFailed                   = "unspecified launch failure"
describe LaunchOutOfResources           = "too many resources requested for launch"
describe LaunchTimeout                  = "the launch timed out and was terminated"
describe LaunchIncompatibleTexturing    = "launch with incompatible texturing"
#if CUDA_VERSION >= 3000
describe NotMappedAsArray               = "mapped resource not available for access as an array"
describe NotMappedAsPointer             = "mapped resource not available for access as a pointer"
describe EccUncorrectable               = "uncorrectable ECC error detected"
#endif
#if CUDA_VERSION >= 3000 && CUDA_VERSION < 3020
describe PointerIs64bit                 = "attempt to retrieve a 64-bit pointer via a 32-bit API function"
describe SizeIs64bit                    = "attempt to retrieve 64-bit size via a 32-bit API function"
#endif
#if CUDA_VERSION >= 3010
describe UnsupportedLimit               = "limits not supported by device"
describe SharedObjectSymbolNotFound     = "link to a shared object failed to resolve"
describe SharedObjectInitFailed         = "shared object initialisation failed"
#endif
#if CUDA_VERSION >= 3020
describe OperatingSystem                = "operating system call failed"
#endif
#if CUDA_VERSION >= 4000
describe ProfilerDisabled               = "profiling APIs disabled: application running with visual profiler"
describe ProfilerNotInitialized         = "profiler not initialised"
describe ProfilerAlreadyStarted         = "profiler already started"
describe ProfilerAlreadyStopped         = "profiler already stopped"
describe ContextAlreadyInUse            = "context is already bound to a thread and in use"
describe PeerAccessAlreadyEnabled       = "peer access already enabled"
describe PeerAccessNotEnabled           = "peer access has not been enabled"
describe PrimaryContextActive           = "primary context for this device has already been initialised"
describe ContextIsDestroyed             = "context already destroyed"
#endif
#if CUDA_VERSION >= 4010
describe Assert                         = "device-side assert triggered"
describe TooManyPeers                   = "peer mapping resources exhausted"
describe HostMemoryAlreadyRegistered    = "part or all of the requested memory range is already mapped"
describe HostMemoryNotRegistered        = "pointer does not correspond to a registered memory region"
#endif
#if CUDA_VERSION >= 5000
describe PeerAccessUnsupported          = "peer access is not supported across the given devices"
describe NotPermitted                   = "not permitted"
describe NotSupported                   = "not supported"
#endif
describe Unknown                        = "unknown error"
#endif

--------------------------------------------------------------------------------
-- Exceptions
--------------------------------------------------------------------------------

data CUDAException
  = ExitCode Status
  | UserError String
  deriving Typeable

instance Exception CUDAException

instance Show CUDAException where
  showsPrec _ (ExitCode  s) = showString ("CUDA Exception: " ++ describe s)
  showsPrec _ (UserError s) = showString ("CUDA Exception: " ++ s)

-- |
-- Raise a CUDAException in the IO Monad
--
cudaError :: String -> IO a
cudaError s = throwIO (UserError s)

-- |
-- A specially formatted error message
--
requireSDK :: Name -> Double -> IO a
requireSDK n v = cudaError $ printf "'%s' requires at least cuda-%3.1f\n" (show n) v

--------------------------------------------------------------------------------
-- Helper Functions
--------------------------------------------------------------------------------

-- |
-- Return the results of a function on successful execution, otherwise throw an
-- exception with an error string associated with the return code
--
{-# INLINE resultIfOk #-}
resultIfOk :: (Status, a) -> IO a
resultIfOk (status, !result) =
    case status of
        Success -> return  result
        _       -> throwIO (ExitCode status)

-- |
-- Throw an exception with an error string associated with an unsuccessful
-- return code, otherwise return unit.
--
{-# INLINE nothingIfOk #-}
nothingIfOk :: Status -> IO ()
nothingIfOk status =
    case status of
        Success -> return  ()
        _       -> throwIO (ExitCode status)

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE DeriveDataTypeable       #-}
{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Error
-- Copyright : [2009..2014] Trevor L. McDonell
-- License   : BSD
--
-- Error handling
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Error
  where

-- Friends
import Foreign.CUDA.Internal.C2HS

-- System
import Control.Exception
import Control.Monad
import Data.Typeable
import Foreign.C
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import Language.Haskell.TH
import System.IO.Unsafe
import Text.Printf

#include "cbits/stubs.h"
{# context lib="cuda" #}

--------------------------------------------------------------------------------
-- Return Status
--------------------------------------------------------------------------------

--
-- Error Codes
--
{# enum CUresult as Status
    { underscoreToCase
    , CUDA_SUCCESS                      as Success
    , CUDA_ERROR_NO_BINARY_FOR_GPU      as NoBinaryForGPU
    , CUDA_ERROR_INVALID_PTX            as InvalidPTX
    , CUDA_ERROR_INVALID_PC             as InvalidPC
    }
    with prefix="CUDA_ERROR" deriving (Eq, Show) #}

-- |
-- Return a descriptive error string associated with a particular error code
--
describe :: Status -> String
#if CUDA_VERSION >= 6000
describe status
  = unsafePerformIO $ resultIfOk =<< cuGetErrorString status

{# fun unsafe cuGetErrorString
    { cFromEnum `Status'
    , alloca-   `String' ppeek* } -> `Status' cToEnum #}
    where
      ppeek = peek >=> peekCString

#else
describe Success                        = "no error"
describe InvalidValue                   = "invalid argument"
describe OutOfMemory                    = "out of memory"
describe NotInitialized                 = "driver not initialised"
describe Deinitialized                  = "driver deinitialised"
describe NoDevice                       = "no CUDA-capable device is available"
describe InvalidDevice                  = "invalid device ordinal"
describe InvalidImage                   = "invalid kernel image"
describe InvalidContext                 = "invalid context handle"
describe ContextAlreadyCurrent          = "context already current"
describe MapFailed                      = "map failed"
describe UnmapFailed                    = "unmap failed"
describe ArrayIsMapped                  = "array is mapped"
describe AlreadyMapped                  = "already mapped"
describe NoBinaryForGPU                 = "no binary available for this GPU"
describe AlreadyAcquired                = "resource already acquired"
describe NotMapped                      = "not mapped"
describe InvalidSource                  = "invalid source"
describe FileNotFound                   = "file not found"
describe InvalidHandle                  = "invalid handle"
describe NotFound                       = "not found"
describe NotReady                       = "device not ready"
describe LaunchFailed                   = "unspecified launch failure"
describe LaunchOutOfResources           = "too many resources requested for launch"
describe LaunchTimeout                  = "the launch timed out and was terminated"
describe LaunchIncompatibleTexturing    = "launch with incompatible texturing"
#if CUDA_VERSION >= 3000
describe NotMappedAsArray               = "mapped resource not available for access as an array"
describe NotMappedAsPointer             = "mapped resource not available for access as a pointer"
describe EccUncorrectable               = "uncorrectable ECC error detected"
#endif
#if CUDA_VERSION >= 3000 && CUDA_VERSION < 3020
describe PointerIs64bit                 = "attempt to retrieve a 64-bit pointer via a 32-bit API function"
describe SizeIs64bit                    = "attempt to retrieve 64-bit size via a 32-bit API function"
#endif
#if CUDA_VERSION >= 3010
describe UnsupportedLimit               = "limits not supported by device"
describe SharedObjectSymbolNotFound     = "link to a shared object failed to resolve"
describe SharedObjectInitFailed         = "shared object initialisation failed"
#endif
#if CUDA_VERSION >= 3020
describe OperatingSystem                = "operating system call failed"
#endif
#if CUDA_VERSION >= 4000
describe ProfilerDisabled               = "profiling APIs disabled: application running with visual profiler"
describe ProfilerNotInitialized         = "profiler not initialised"
describe ProfilerAlreadyStarted         = "profiler already started"
describe ProfilerAlreadyStopped         = "profiler already stopped"
describe ContextAlreadyInUse            = "context is already bound to a thread and in use"
describe PeerAccessAlreadyEnabled       = "peer access already enabled"
describe PeerAccessNotEnabled           = "peer access has not been enabled"
describe PrimaryContextActive           = "primary context for this device has already been initialised"
describe ContextIsDestroyed             = "context already destroyed"
#endif
#if CUDA_VERSION >= 4010
describe Assert                         = "device-side assert triggered"
describe TooManyPeers                   = "peer mapping resources exhausted"
describe HostMemoryAlreadyRegistered    = "part or all of the requested memory range is already mapped"
describe HostMemoryNotRegistered        = "pointer does not correspond to a registered memory region"
#endif
#if CUDA_VERSION >= 5000
describe PeerAccessUnsupported          = "peer access is not supported across the given devices"
describe NotPermitted                   = "not permitted"
describe NotSupported                   = "not supported"
#endif
describe Unknown                        = "unknown error"
#endif

--------------------------------------------------------------------------------
-- Exceptions
--------------------------------------------------------------------------------

data CUDAException
  = ExitCode Status
  | UserError String
  deriving Typeable

instance Exception CUDAException

instance Show CUDAException where
  showsPrec _ (ExitCode  s) = showString ("CUDA Exception: " ++ describe s)
  showsPrec _ (UserError s) = showString ("CUDA Exception: " ++ s)

-- |
-- Raise a CUDAException in the IO Monad
--
cudaError :: String -> IO a
cudaError s = throwIO (UserError s)

-- |
-- A specially formatted error message
--
requireSDK :: Name -> Double -> IO a
requireSDK n v = cudaError $ printf "'%s' requires at least cuda-%3.1f\n" (show n) v

--------------------------------------------------------------------------------
-- Helper Functions
--------------------------------------------------------------------------------

-- |
-- Return the results of a function on successful execution, otherwise throw an
-- exception with an error string associated with the return code
--
{-# INLINE resultIfOk #-}
resultIfOk :: (Status, a) -> IO a
resultIfOk (status, !result) =
    case status of
        Success -> return  result
        _       -> throwIO (ExitCode status)

-- |
-- Throw an exception with an error string associated with an unsuccessful
-- return code, otherwise return unit.
--
{-# INLINE nothingIfOk #-}
nothingIfOk :: Status -> IO ()
nothingIfOk status =
    case status of
        Success -> return  ()
        _       -> throwIO (ExitCode status)


Implement pageGetAnnotMapping

Implement pageGetAnnotMapping

{-# LANGUAGE CPP, DeriveDataTypeable #-}
--  GIMP Toolkit (GTK) Binding for Haskell: binding to poppler -*-haskell-*-
--
--  Author : Andy Stewart
--  Created: 18-Jun-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 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  POPPLER, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original POPPLER documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module Graphics.UI.Gtk.Poppler.Page (
-- * Types
    Cairo,
    PopplerRectangle (..),
    PopplerColor (..),
    ImageMapping,
    PageTransition,
    LinkMapping,
    FormFieldMapping,
    AnnotMapping,
-- * Enums
    SelectionStyle (..),

-- * Methods
    pageRender,
    -- pageRenderToPixbuf,
    pageGetSize,
    pageGetIndex,
    pageGetThumbnail,
    pageGetThumbnailSize,
    pageRenderToPs,
    pageFindText,
    pageGetText,
    pageGetDuration,
    pageGetTransition,
    pageGetLinkMapping,
    pageGetImageMapping,
    pageGetFormFieldMapping,
    pageGetSelectionRegion,
    pageRenderSelection,
    pageAddAnnot,
    pageRemoveAnnot,
    pageRectangleNew
    -- pageRenderSelectionToPixbuf,
    ) where

import Control.Monad
import Data.Typeable
import System.Glib.FFI
import System.Glib.Flags
import System.Glib.GError
import System.Glib.GObject
import System.Glib.GList
import System.Glib.UTFString
import Graphics.UI.Gtk.Poppler.Enums
import Graphics.UI.Gtk.Abstract.Widget (Rectangle (..), Color (..))
{#import Graphics.UI.GtkInternals#}
{#import Graphics.Rendering.Cairo.Types#}
{#import Graphics.UI.Gtk.Poppler.Types#}
import Graphics.UI.Gtk.Poppler.Structs
import Control.Monad.Reader (ReaderT(runReaderT), ask, MonadIO, liftIO)
import Graphics.Rendering.Cairo.Internal (Render(..), bracketR)

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

-- | Render the page to the given cairo context. This function is for rendering a page that will be
-- displayed. If you want to render a page that will be printed use 'pageRenderForPrinting'
-- instead
pageRender :: PageClass page => page
 -> Render ()
pageRender page =
  ask >>= \ x -> liftIO ({#call poppler_page_render #} (toPage page) x)

-- | First scale the document to match the specified pixels per point, then render the rectangle given by
-- the upper left corner at (@srcX@, @srcY@) and @srcWidth@ and @srcHeight@. This function is for rendering
-- a page that will be displayed. If you want to render a page that will be printed use
-- 'pageRenderToPixbufForPrinting' instead
{- pageRenderToPixbuf :: PageClass page => page
 -> Rectangle -- ^ @rect@      rectangle to render
 -> Double -- ^ @scale@      scale specified as pixels per point
 -> Int -- ^ @rotation@   rotate the document by the specified degree
 -> Pixbuf -- ^ @pixbuf@     pixbuf to render into
 -> IO ()
pageRenderToPixbuf page (Rectangle x y width height) scale rotation pixbuf =
  {#call poppler_page_render_to_pixbuf #}
    (toPage page)
    (fromIntegral x)
    (fromIntegral y)
    (fromIntegral width)
    (fromIntegral height)
    (realToFrac scale)
    (fromIntegral rotation)
    pixbuf
-}

-- | Gets the size of page at the current scale and rotation.
pageGetSize :: PageClass page => page
 -> IO (Double, Double)
pageGetSize page =
  alloca $ \ widthPtr ->
  alloca $ \ heightPtr -> do
      {#call poppler_page_get_size #}
        (toPage page)
        widthPtr
        heightPtr
      width <- peek widthPtr
      height <- peek heightPtr
      return (realToFrac width, realToFrac height)

-- | Returns the index of page
pageGetIndex :: PageClass page => page
 -> IO Int  -- ^ returns index value of page
pageGetIndex page =
  liftM fromIntegral $
  {#call poppler_page_get_index #} (toPage page)

-- | Get the embedded thumbnail for the specified page. If the document doesn't have an embedded
-- thumbnail for the page, this function returns 'Nothing'.
pageGetThumbnail :: PageClass page => page
 -> IO (Maybe Surface) -- ^ returns the tumbnail as a @cairoSurfaceT@ or 'Nothing' if the document doesn't have a thumbnail for this page.
pageGetThumbnail page = do
  surfacePtr <- {#call poppler_page_get_thumbnail #} (toPage page)
  if surfacePtr == nullPtr
     then return Nothing
     else liftM Just (mkSurface surfacePtr)

-- | Returns 'True' if page has a thumbnail associated with it. It also fills in width and height with the
-- width and height of the thumbnail. The values of width and height are not changed if no appropriate
-- thumbnail exists.
pageGetThumbnailSize :: PageClass page => page
 -> IO (Maybe (Int, Int))
pageGetThumbnailSize page =
  alloca $ \ widthPtr ->
  alloca $ \ heightPtr -> do
    success <- liftM toBool $
                {#call poppler_page_get_thumbnail_size #}
                  (toPage page)
                  widthPtr
                  heightPtr
    if success
       then do
         width  <- peek widthPtr
         height <- peek heightPtr
         return $ Just (fromIntegral width, fromIntegral height)
       else return Nothing

-- | Render the page on a postscript file
pageRenderToPs :: (PageClass page, PSFileClass psFile) => page -> psFile -> IO ()
pageRenderToPs page psFile =
  {#call poppler_page_render_to_ps #} (toPage page) (toPSFile psFile)

-- | A GList of rectangles for each occurance of the text on the page. The coordinates are in PDF points.
pageFindText :: PageClass page => page
 -> String  -- ^ @text@    the text to search for (UTF-8 encoded)
 -> IO [PopplerRectangle]
pageFindText page text =
  withUTFString text $ \ textPtr -> do
    glistPtr <- {#call poppler_page_find_text #} (toPage page) textPtr
    list <- fromGList glistPtr
    mapM peekPopplerRectangle list

-- | Retrieves the contents of the specified selection as text.
pageGetText :: PageClass page => page -> IO String  -- ^ returns selection string
pageGetText page =
  {#call poppler_page_get_text #} (toPage page)
  >>= peekUTFString

-- | Returns the duration of page
pageGetDuration :: PageClass page => page
 -> IO Double  -- ^ returns duration in seconds of page or -1.
pageGetDuration page =
  liftM realToFrac $
  {#call poppler_page_get_duration #} (toPage page)

-- | Returns the transition effect of page
pageGetTransition :: PageClass page => page
 -> IO (Maybe PageTransition) -- ^ returns a 'PageTransition' or 'Nothing'.
pageGetTransition page = do
  ptr <- {#call poppler_page_get_transition #} (toPage page)
  if ptr == nullPtr
     then return Nothing
     else liftM Just $ makeNewPageTransition (castPtr ptr)

{#pointer *PageTransition foreign newtype #}

makeNewPageTransition :: Ptr PageTransition -> IO PageTransition
makeNewPageTransition rPtr = do
  transition <- newForeignPtr rPtr page_transition_free
  return (PageTransition transition)

foreign import ccall unsafe "&poppler_page_transition_free"
  page_transition_free :: FinalizerPtr PageTransition

-- | Returns a list of 'LinkMapping' items that map from a location on page to a 'Action'.
pageGetLinkMapping :: PageClass page => page
 -> IO [LinkMapping]
pageGetLinkMapping page = do
  glistPtr <- {#call poppler_page_get_link_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewLinkMapping list
  {#call unsafe poppler_page_free_link_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *LinkMapping foreign newtype #}

makeNewLinkMapping :: Ptr LinkMapping -> IO LinkMapping
makeNewLinkMapping rPtr = do
  linkMapping <- newForeignPtr rPtr poppler_link_mapping_free
  return (LinkMapping linkMapping)

foreign import ccall unsafe "&poppler_link_mapping_free"
  poppler_link_mapping_free :: FinalizerPtr LinkMapping

-- | Returns a list of 'ImageMapping' items that map from a location on page to a 'Action'.
pageGetImageMapping :: PageClass page => page
 -> IO [ImageMapping]
pageGetImageMapping page = do
  glistPtr <- {#call poppler_page_get_image_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewImageMapping list
  {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *ImageMapping foreign newtype #}

makeNewImageMapping :: Ptr ImageMapping -> IO ImageMapping
makeNewImageMapping rPtr = do
  imageMapping <- newForeignPtr rPtr poppler_image_mapping_free
  return (ImageMapping imageMapping)

foreign import ccall unsafe "&poppler_image_mapping_free"
  poppler_image_mapping_free :: FinalizerPtr ImageMapping

-- | Returns a list of 'FormFieldMapping' items that map from a location on page to a 'Action'.
pageGetFormFieldMapping :: PageClass page => page
 -> IO [FormFieldMapping]
pageGetFormFieldMapping page = do
  glistPtr <- {#call poppler_page_get_form_field_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewFormFieldMapping list
  {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *FormFieldMapping foreign newtype #}

makeNewFormFieldMapping :: Ptr FormFieldMapping -> IO FormFieldMapping
makeNewFormFieldMapping rPtr = do
  formFieldMapping <- newForeignPtr rPtr poppler_form_field_mapping_free
  return (FormFieldMapping formFieldMapping)

foreign import ccall unsafe "&poppler_form_field_mapping_free"
  poppler_form_field_mapping_free :: FinalizerPtr FormFieldMapping

-- | Returns a region containing the area that would be rendered by 'pageRenderSelection' or
-- 'pageRenderSelectionToPixbuf' as a GList of PopplerRectangle.
pageGetSelectionRegion :: PageClass page => page
 -> Double -- ^ @scale@     scale specified as pixels per point
 -> SelectionStyle -- ^ @style@     a 'SelectionStyle'
 -> PopplerRectangle -- ^ @selection@ start and end point of selection as a rectangle
 -> IO [PopplerRectangle]
pageGetSelectionRegion page scale style selection =
  with selection $ \ selectionPtr -> do
    glistPtr <- {#call poppler_page_get_selection_region #}
                 (toPage page)
                 (realToFrac scale)
                 ((fromIntegral . fromEnum) style)
                 (castPtr selectionPtr)
    list <- fromGList glistPtr
    rectangles <- mapM peekPopplerRectangle list
    {#call unsafe poppler_page_selection_region_free #} (castPtr glistPtr)
    return rectangles

-- | Render the selection specified by selection for page to the given cairo context. The selection will
-- be rendered, using @glyphColor@ for the glyphs and @backgroundColor@ for the selection background.
--
-- If non-'Nothing', @oldSelection@ specifies the selection that is already rendered to cairo, in which case
-- this function will (some day) only render the changed part of the selection.
pageRenderSelection :: PageClass page => page
 -> PopplerRectangle -- ^ @selection@        start and end point of selection as a rectangle
 -> PopplerRectangle -- ^ @oldSelection@    previous selection
 -> SelectionStyle -- ^ @style@            a 'SelectionStyle'
 -> PopplerColor -- ^ @glyphColor@      color to use for drawing glyphs
 -> PopplerColor -- ^ @backgroundColor@ color to use for the selection background
 -> Render ()
pageRenderSelection page selection oldSelection style glyphColor backgroundColor = do
  cairo <- ask
  liftIO $
         with selection $ \ selectionPtr ->
         with oldSelection $ \ oldSelectionPtr ->
         with glyphColor $ \ glyphColorPtr ->
         with backgroundColor $ \ backgroundColorPtr ->
              {#call poppler_page_render_selection #}
                  (toPage page)
                  cairo
                  (castPtr selectionPtr)
                  (castPtr oldSelectionPtr)
                  ((fromIntegral . fromEnum) style)
                  (castPtr glyphColorPtr)
                  (castPtr backgroundColorPtr)

pageAddAnnot :: (PageClass page, AnnotClass annot) => page -> annot -> IO ()
pageAddAnnot page annot =
  {# call poppler_page_add_annot #} (toPage page) (toAnnot annot)

pageRemoveAnnot :: (PageClass page, AnnotClass annot) => page -> annot -> IO ()
pageRemoveAnnot page annot =
  {# call poppler_page_remove_annot #} (toPage page) (toAnnot annot)

pageRectangleNew :: IO PopplerRectangle
pageRectangleNew =
  (peekPopplerRectangle . castPtr) =<< {# call poppler_rectangle_new #}

{#pointer *AnnotMapping foreign newtype #}

makeNewAnnotMapping :: Ptr AnnotMapping -> IO AnnotMapping
makeNewAnnotMapping rPtr = do
  annotMapping <- newForeignPtr rPtr poppler_annot_mapping_free
  return (AnnotMapping annotMapping)

pageGetAnnotMapping :: PageClass page => page -> IO [AnnotMapping]
pageGetAnnotMapping page = do
  glistPtr <- {# call poppler_page_get_annot_mapping #} (toPage page)
  list     <- fromGList glistPtr
  mappings <- mapM makeNewAnnotMapping list
  {#call unsafe poppler_page_free_form_field_mapping #} (castPtr glistPtr)
  return mappings

foreign import ccall unsafe "&poppler_annot_mapping_free"
  poppler_annot_mapping_free :: FinalizerPtr AnnotMapping

-- | Render the selection specified by selection for page into pixbuf. The selection will be rendered at
-- scale, using @glyphColor@ for the glyphs and @backgroundColor@ for the selection background.
--
-- If non-'Nothing', @oldSelection@ specifies the selection that is already rendered in pixbuf, in which case
-- this function will (some day) only render the changed part of the selection.
{-
pageRenderSelectionToPixbuf :: PageClass page => page
 -> Double -- ^ @scale@            scale specified as pixels per point
 -> Int -- ^ @rotation@         rotate the document by the specified degree
 -> Pixbuf -- ^ @pixbuf@           pixbuf to render to
 -> PopplerRectangle -- ^ @selection@        start and end point of selection as a rectangle
 -> PopplerRectangle -- ^ @oldSelection@    previous selection
 -> SelectionStyle -- ^ @style@            a 'SelectionStyle'
 -> Color -- ^ @glyphColor@      color to use for drawing glyphs
 -> Color -- ^ @backgroundColor@ color to use for the selection background
 -> IO ()
pageRenderSelectionToPixbuf page scale rotation pixbuf selection oldSelection style glyphColor backgroundColor =
  with selection $ \ selectionPtr ->
  with oldSelection $ \ oldSelectionPtr ->
  with glyphColor $ \ glyphColorPtr ->
  with backgroundColor $ \ backgroundColorPtr ->
      {#call poppler_page_render_selection_to_pixbuf #}
        (toPage page)
        (realToFrac scale)
        (fromIntegral rotation)
        pixbuf
        (castPtr selectionPtr)
        (castPtr oldSelectionPtr)
        ((fromIntegral . fromEnum) style)
        (castPtr glyphColorPtr)
        (castPtr backgroundColorPtr)
-}

{-# LANGUAGE CPP, DeriveDataTypeable #-}
--  GIMP Toolkit (GTK) Binding for Haskell: binding to poppler -*-haskell-*-
--
--  Author : Andy Stewart
--  Created: 18-Jun-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 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  POPPLER, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original POPPLER documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module Graphics.UI.Gtk.Poppler.Page (
-- * Types
    Cairo,
    PopplerRectangle (..),
    PopplerColor (..),
    ImageMapping,
    PageTransition,
    LinkMapping,
    FormFieldMapping,

-- * Enums
    SelectionStyle (..),

-- * Methods
    pageRender,
    -- pageRenderToPixbuf,
    pageGetSize,
    pageGetIndex,
    pageGetThumbnail,
    pageGetThumbnailSize,
    pageRenderToPs,
    pageFindText,
    pageGetText,
    pageGetDuration,
    pageGetTransition,
    pageGetLinkMapping,
    pageGetImageMapping,
    pageGetFormFieldMapping,
    pageGetSelectionRegion,
    pageRenderSelection,
    pageAddAnnot,
    pageRemoveAnnot,
    pageRectangleNew
    -- pageRenderSelectionToPixbuf,
    ) where

import Control.Monad
import Data.Typeable
import System.Glib.FFI
import System.Glib.Flags
import System.Glib.GError
import System.Glib.GObject
import System.Glib.GList
import System.Glib.UTFString
import Graphics.UI.Gtk.Poppler.Enums
import Graphics.UI.Gtk.Abstract.Widget (Rectangle (..), Color (..))
{#import Graphics.UI.GtkInternals#}
{#import Graphics.Rendering.Cairo.Types#}
{#import Graphics.UI.Gtk.Poppler.Types#}
import Graphics.UI.Gtk.Poppler.Structs
import Control.Monad.Reader (ReaderT(runReaderT), ask, MonadIO, liftIO)
import Graphics.Rendering.Cairo.Internal (Render(..), bracketR)

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

-- | Render the page to the given cairo context. This function is for rendering a page that will be
-- displayed. If you want to render a page that will be printed use 'pageRenderForPrinting'
-- instead
pageRender :: PageClass page => page
 -> Render ()
pageRender page =
  ask >>= \ x -> liftIO ({#call poppler_page_render #} (toPage page) x)

-- | First scale the document to match the specified pixels per point, then render the rectangle given by
-- the upper left corner at (@srcX@, @srcY@) and @srcWidth@ and @srcHeight@. This function is for rendering
-- a page that will be displayed. If you want to render a page that will be printed use
-- 'pageRenderToPixbufForPrinting' instead
{- pageRenderToPixbuf :: PageClass page => page
 -> Rectangle -- ^ @rect@      rectangle to render
 -> Double -- ^ @scale@      scale specified as pixels per point
 -> Int -- ^ @rotation@   rotate the document by the specified degree
 -> Pixbuf -- ^ @pixbuf@     pixbuf to render into
 -> IO ()
pageRenderToPixbuf page (Rectangle x y width height) scale rotation pixbuf =
  {#call poppler_page_render_to_pixbuf #}
    (toPage page)
    (fromIntegral x)
    (fromIntegral y)
    (fromIntegral width)
    (fromIntegral height)
    (realToFrac scale)
    (fromIntegral rotation)
    pixbuf
-}

-- | Gets the size of page at the current scale and rotation.
pageGetSize :: PageClass page => page
 -> IO (Double, Double)
pageGetSize page =
  alloca $ \ widthPtr ->
  alloca $ \ heightPtr -> do
      {#call poppler_page_get_size #}
        (toPage page)
        widthPtr
        heightPtr
      width <- peek widthPtr
      height <- peek heightPtr
      return (realToFrac width, realToFrac height)

-- | Returns the index of page
pageGetIndex :: PageClass page => page
 -> IO Int  -- ^ returns index value of page
pageGetIndex page =
  liftM fromIntegral $
  {#call poppler_page_get_index #} (toPage page)

-- | Get the embedded thumbnail for the specified page. If the document doesn't have an embedded
-- thumbnail for the page, this function returns 'Nothing'.
pageGetThumbnail :: PageClass page => page
 -> IO (Maybe Surface) -- ^ returns the tumbnail as a @cairoSurfaceT@ or 'Nothing' if the document doesn't have a thumbnail for this page.
pageGetThumbnail page = do
  surfacePtr <- {#call poppler_page_get_thumbnail #} (toPage page)
  if surfacePtr == nullPtr
     then return Nothing
     else liftM Just (mkSurface surfacePtr)

-- | Returns 'True' if page has a thumbnail associated with it. It also fills in width and height with the
-- width and height of the thumbnail. The values of width and height are not changed if no appropriate
-- thumbnail exists.
pageGetThumbnailSize :: PageClass page => page
 -> IO (Maybe (Int, Int))
pageGetThumbnailSize page =
  alloca $ \ widthPtr ->
  alloca $ \ heightPtr -> do
    success <- liftM toBool $
                {#call poppler_page_get_thumbnail_size #}
                  (toPage page)
                  widthPtr
                  heightPtr
    if success
       then do
         width  <- peek widthPtr
         height <- peek heightPtr
         return $ Just (fromIntegral width, fromIntegral height)
       else return Nothing

-- | Render the page on a postscript file
pageRenderToPs :: (PageClass page, PSFileClass psFile) => page -> psFile -> IO ()
pageRenderToPs page psFile =
  {#call poppler_page_render_to_ps #} (toPage page) (toPSFile psFile)

-- | A GList of rectangles for each occurance of the text on the page. The coordinates are in PDF points.
pageFindText :: PageClass page => page
 -> String  -- ^ @text@    the text to search for (UTF-8 encoded)
 -> IO [PopplerRectangle]
pageFindText page text =
  withUTFString text $ \ textPtr -> do
    glistPtr <- {#call poppler_page_find_text #} (toPage page) textPtr
    list <- fromGList glistPtr
    mapM peekPopplerRectangle list

-- | Retrieves the contents of the specified selection as text.
pageGetText :: PageClass page => page -> IO String  -- ^ returns selection string
pageGetText page =
  {#call poppler_page_get_text #} (toPage page)
  >>= peekUTFString

-- | Returns the duration of page
pageGetDuration :: PageClass page => page
 -> IO Double  -- ^ returns duration in seconds of page or -1.
pageGetDuration page =
  liftM realToFrac $
  {#call poppler_page_get_duration #} (toPage page)

-- | Returns the transition effect of page
pageGetTransition :: PageClass page => page
 -> IO (Maybe PageTransition) -- ^ returns a 'PageTransition' or 'Nothing'.
pageGetTransition page = do
  ptr <- {#call poppler_page_get_transition #} (toPage page)
  if ptr == nullPtr
     then return Nothing
     else liftM Just $ makeNewPageTransition (castPtr ptr)

{#pointer *PageTransition foreign newtype #}

makeNewPageTransition :: Ptr PageTransition -> IO PageTransition
makeNewPageTransition rPtr = do
  transition <- newForeignPtr rPtr page_transition_free
  return (PageTransition transition)

foreign import ccall unsafe "&poppler_page_transition_free"
  page_transition_free :: FinalizerPtr PageTransition

-- | Returns a list of 'LinkMapping' items that map from a location on page to a 'Action'.
pageGetLinkMapping :: PageClass page => page
 -> IO [LinkMapping]
pageGetLinkMapping page = do
  glistPtr <- {#call poppler_page_get_link_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewLinkMapping list
  {#call unsafe poppler_page_free_link_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *LinkMapping foreign newtype #}

makeNewLinkMapping :: Ptr LinkMapping -> IO LinkMapping
makeNewLinkMapping rPtr = do
  linkMapping <- newForeignPtr rPtr poppler_link_mapping_free
  return (LinkMapping linkMapping)

foreign import ccall unsafe "&poppler_link_mapping_free"
  poppler_link_mapping_free :: FinalizerPtr LinkMapping

-- | Returns a list of 'ImageMapping' items that map from a location on page to a 'Action'.
pageGetImageMapping :: PageClass page => page
 -> IO [ImageMapping]
pageGetImageMapping page = do
  glistPtr <- {#call poppler_page_get_image_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewImageMapping list
  {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *ImageMapping foreign newtype #}

makeNewImageMapping :: Ptr ImageMapping -> IO ImageMapping
makeNewImageMapping rPtr = do
  imageMapping <- newForeignPtr rPtr poppler_image_mapping_free
  return (ImageMapping imageMapping)

foreign import ccall unsafe "&poppler_image_mapping_free"
  poppler_image_mapping_free :: FinalizerPtr ImageMapping

-- | Returns a list of 'FormFieldMapping' items that map from a location on page to a 'Action'.
pageGetFormFieldMapping :: PageClass page => page
 -> IO [FormFieldMapping]
pageGetFormFieldMapping page = do
  glistPtr <- {#call poppler_page_get_form_field_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewFormFieldMapping list
  {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *FormFieldMapping foreign newtype #}

makeNewFormFieldMapping :: Ptr FormFieldMapping -> IO FormFieldMapping
makeNewFormFieldMapping rPtr = do
  formFieldMapping <- newForeignPtr rPtr poppler_form_field_mapping_free
  return (FormFieldMapping formFieldMapping)

foreign import ccall unsafe "&poppler_form_field_mapping_free"
  poppler_form_field_mapping_free :: FinalizerPtr FormFieldMapping

-- | Returns a region containing the area that would be rendered by 'pageRenderSelection' or
-- 'pageRenderSelectionToPixbuf' as a GList of PopplerRectangle.
pageGetSelectionRegion :: PageClass page => page
 -> Double -- ^ @scale@     scale specified as pixels per point
 -> SelectionStyle -- ^ @style@     a 'SelectionStyle'
 -> PopplerRectangle -- ^ @selection@ start and end point of selection as a rectangle
 -> IO [PopplerRectangle]
pageGetSelectionRegion page scale style selection =
  with selection $ \ selectionPtr -> do
    glistPtr <- {#call poppler_page_get_selection_region #}
                 (toPage page)
                 (realToFrac scale)
                 ((fromIntegral . fromEnum) style)
                 (castPtr selectionPtr)
    list <- fromGList glistPtr
    rectangles <- mapM peekPopplerRectangle list
    {#call unsafe poppler_page_selection_region_free #} (castPtr glistPtr)
    return rectangles

-- | Render the selection specified by selection for page to the given cairo context. The selection will
-- be rendered, using @glyphColor@ for the glyphs and @backgroundColor@ for the selection background.
--
-- If non-'Nothing', @oldSelection@ specifies the selection that is already rendered to cairo, in which case
-- this function will (some day) only render the changed part of the selection.
pageRenderSelection :: PageClass page => page
 -> PopplerRectangle -- ^ @selection@        start and end point of selection as a rectangle
 -> PopplerRectangle -- ^ @oldSelection@    previous selection
 -> SelectionStyle -- ^ @style@            a 'SelectionStyle'
 -> PopplerColor -- ^ @glyphColor@      color to use for drawing glyphs
 -> PopplerColor -- ^ @backgroundColor@ color to use for the selection background
 -> Render ()
pageRenderSelection page selection oldSelection style glyphColor backgroundColor = do
  cairo <- ask
  liftIO $
         with selection $ \ selectionPtr ->
         with oldSelection $ \ oldSelectionPtr ->
         with glyphColor $ \ glyphColorPtr ->
         with backgroundColor $ \ backgroundColorPtr ->
              {#call poppler_page_render_selection #}
                  (toPage page)
                  cairo
                  (castPtr selectionPtr)
                  (castPtr oldSelectionPtr)
                  ((fromIntegral . fromEnum) style)
                  (castPtr glyphColorPtr)
                  (castPtr backgroundColorPtr)

pageAddAnnot :: (PageClass page, AnnotClass annot) => page -> annot -> IO ()
pageAddAnnot page annot =
  {# call poppler_page_add_annot #} (toPage page) (toAnnot annot)

pageRemoveAnnot :: (PageClass page, AnnotClass annot) => page -> annot -> IO ()
pageRemoveAnnot page annot =
  {# call poppler_page_remove_annot #} (toPage page) (toAnnot annot)

pageRectangleNew :: IO PopplerRectangle
pageRectangleNew =
  (peekPopplerRectangle . castPtr) =<< {# call poppler_rectangle_new #}

-- | Render the selection specified by selection for page into pixbuf. The selection will be rendered at
-- scale, using @glyphColor@ for the glyphs and @backgroundColor@ for the selection background.
--
-- If non-'Nothing', @oldSelection@ specifies the selection that is already rendered in pixbuf, in which case
-- this function will (some day) only render the changed part of the selection.
{-
pageRenderSelectionToPixbuf :: PageClass page => page
 -> Double -- ^ @scale@            scale specified as pixels per point
 -> Int -- ^ @rotation@         rotate the document by the specified degree
 -> Pixbuf -- ^ @pixbuf@           pixbuf to render to
 -> PopplerRectangle -- ^ @selection@        start and end point of selection as a rectangle
 -> PopplerRectangle -- ^ @oldSelection@    previous selection
 -> SelectionStyle -- ^ @style@            a 'SelectionStyle'
 -> Color -- ^ @glyphColor@      color to use for drawing glyphs
 -> Color -- ^ @backgroundColor@ color to use for the selection background
 -> IO ()
pageRenderSelectionToPixbuf page scale rotation pixbuf selection oldSelection style glyphColor backgroundColor =
  with selection $ \ selectionPtr ->
  with oldSelection $ \ oldSelectionPtr ->
  with glyphColor $ \ glyphColorPtr ->
  with backgroundColor $ \ backgroundColorPtr ->
      {#call poppler_page_render_selection_to_pixbuf #}
        (toPage page)
        (realToFrac scale)
        (fromIntegral rotation)
        pixbuf
        (castPtr selectionPtr)
        (castPtr oldSelectionPtr)
        ((fromIntegral . fromEnum) style)
        (castPtr glyphColorPtr)
        (castPtr backgroundColorPtr)
-}