Haddock tweaks in IO module.

Haddock tweaks in IO module.

Ignore-this: b196f8eb273decb2b48ef0744f4ff21

darcs-hash:20090309003406-ed7c9-59b52172dff531ed82dd48c8ac6696c830dadaab.gz

-- hexpat, a Haskell wrapper for expat
-- Copyright (C) 2008 Evan Martin <martine@danga.com>
-- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>

-- | A very low-level interface to Expat. Unless you need extreme speed, this
-- should normally be avoided in favour of the interface provided by "Text-XML-Expat-Tree".
-- Basic usage is:
--
-- (1) Make a new parser: 'newParser'.
--
-- (2) Set up callbacks on the parser: 'setStartElementHandler', etc.
--
-- (3) Feed data into the parser: 'parse' or 'parseChunk'.

module Text.XML.Expat.IO (
  -- ** Parser Setup
  Parser, newParser,

  -- ** Parsing
  parse, parseChunk, Encoding(..), XMLParseError(..),

  -- ** Parser Callbacks
  StartElementHandler, EndElementHandler, CharacterDataHandler,
  setStartElementHandler, setEndElementHandler, setCharacterDataHandler,

  -- ** Lower-level interface
  unsafeParseChunk,
  withHandlers,
  unsafeSetHandlers,
  unsafeReleaseHandlers,
  ExpatHandlers,

  -- ** Helpers
  encodingToString
) where

import Control.Exception (bracket)
import Control.Parallel.Strategies
import Control.Monad
import C2HS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Internal as BSI
import Data.IORef

#include <expat.h>

-- Expat functions start with "XML", but C2HS appears to ignore our "as"
-- definitions if they only differ from the symbol in case.  So we write out
-- XML_* in most cases anyway...  :(
{#context lib = "expat" prefix = "XML"#}

-- |Opaque parser type.
type ParserPtr = Ptr ()
data Parser = Parser
    (ForeignPtr ())
    (IORef CStartElementHandler)
    (IORef CEndElementHandler)
    (IORef CCharacterDataHandler)

instance Show Parser where
    showsPrec _ (Parser fp _ _ _) = showsPrec 0 fp

withParser :: Parser -> (ParserPtr -> IO a) -> IO a
withParser (Parser fp _ _ _) = withForeignPtr fp

-- |Encoding types available for the document encoding.
data Encoding = ASCII | UTF8 | UTF16 | ISO88591
encodingToString :: Encoding -> String
encodingToString ASCII    = "US-ASCII"
encodingToString UTF8     = "UTF-8"
encodingToString UTF16    = "UTF-16"
encodingToString ISO88591 = "ISO-8859-1"

withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a
withOptEncoding Nothing    f = f nullPtr
withOptEncoding (Just enc) f = withCString (encodingToString enc) f

{#fun unsafe XML_ParserCreate as parserCreate
    {withOptEncoding* `Maybe Encoding'} -> `ParserPtr' id#}
foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())

-- |Create a 'Parser'.  The encoding parameter, if provided, overrides the
-- document's encoding declaration.
newParser :: Maybe Encoding -> IO Parser
newParser enc = do
  ptr <- parserCreate enc
  fptr <- newForeignPtr parserFree ptr
  nullStartH <- newIORef nullCStartElementHandler
  nullEndH <- newIORef nullCEndElementHandler
  nullCharH <- newIORef nullCCharacterDataHandler
  return $ Parser fptr nullStartH nullEndH nullCharH

-- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt
-- instead of an Int.
withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a
withBStringLen bs f = do
  BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len)

unStatus :: CInt -> Bool
unStatus 0 = False
unStatus 1 = True

-- |@parse data@ feeds /lazy/ bytestring data into a parser. It returns Nothing
-- on success, or Just the parse error.
parse :: Parser -> BSL.ByteString -> IO (Maybe XMLParseError)
parse parser@(Parser _ _ _ _) bs = withHandlers parser $ feedChunk (BSL.toChunks bs)
  where
    feedChunk []      = return Nothing
    feedChunk (c:cs)  = do
        ok <- doParseChunk parser c (null cs)
        if ok
            then feedChunk cs
            else Just `fmap` getError parser

-- |@parseChunk data False@ feeds /strict/ ByteString data into a
-- 'Parser'.  The end of the data is indicated by passing @True@ for the
-- final parameter.   It returns Nothing on success, or Just the parse error.
parseChunk :: Parser
           -> BS.ByteString
           -> Bool
           -> IO (Maybe XMLParseError)
parseChunk parser xml final = withHandlers parser $ unsafeParseChunk parser xml final

-- | This variant of parseChunk must either be called inside 'withHandlers' (safest), or
-- between 'unsafeSetHandlers' and 'unsafeReleaseHandlers', and this
-- will give you better performance than 'parseChunk' if you process multiple chunks inside.
unsafeParseChunk :: Parser
           -> BS.ByteString
           -> Bool
           -> IO (Maybe XMLParseError)
unsafeParseChunk parser xml final = do
    ok <- doParseChunk parser xml final
    if ok
        then return Nothing
        else Just `fmap` getError parser

getError parser = withParser parser $ \p -> do
                code <- xmlGetErrorCode p
                cerr <- xmlErrorString code
                err <- peekCString cerr
                line <- xmlGetCurrentLineNumber p
                col <- xmlGetCurrentColumnNumber p
                return $ XMLParseError err
                    (fromIntegral line) (fromIntegral col)

data ExpatHandlers = ExpatHandlers
    (FunPtr CStartElementHandler)
    (FunPtr CEndElementHandler)
    (FunPtr CCharacterDataHandler)

unsafeSetHandlers :: Parser -> IO ExpatHandlers
unsafeSetHandlers parser@(Parser fp startRef endRef charRef) = do
    cStartH <- mkCStartElementHandler =<< readIORef startRef
    cEndH   <- mkCEndElementHandler =<< readIORef endRef
    cCharH  <- mkCCharacterDataHandler =<< readIORef charRef
    withParser parser $ \p -> do
        {#call unsafe XML_SetStartElementHandler as ^#}  p cStartH
        {#call unsafe XML_SetEndElementHandler as ^#}    p cEndH
        {#call unsafe XML_SetCharacterDataHandler as ^#} p cCharH
    return $ ExpatHandlers cStartH cEndH cCharH

unsafeReleaseHandlers :: ExpatHandlers -> IO ()
unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH) = do
    freeHaskellFunPtr cStartH
    freeHaskellFunPtr cEndH
    freeHaskellFunPtr cCharH

-- | 'unsafeParseChunk' is required to be called inside @withHandlers@.
-- Safer than using 'unsafeSetHandlers' / 'unsafeReleaseHandlers'.
withHandlers :: Parser
             -> IO a  -- ^ Computation where unsafeParseChunk may be used
             -> IO a
withHandlers parser code = do
    bracket
        (unsafeSetHandlers parser)
        unsafeReleaseHandlers
        (\_ -> code)

{#fun XML_Parse as doParseChunk
    {withParser* `Parser', withBStringLen* `BS.ByteString' &, `Bool'}
    -> `Bool' unStatus#}

-- | Parse error, consisting of message text, line number, and column number
data XMLParseError = XMLParseError String Integer Integer deriving (Eq, Show)

instance NFData XMLParseError where
    rnf (XMLParseError msg lin col) = rnf (msg, lin, col)

-- |The type of the \"element started\" callback.  The first parameter is
-- the element name; the second are the (attribute, value) pairs. Return True
-- to continue parsing as normal, or False to terminate the parse.
type StartElementHandler  = CString -> [(CString, CString)] -> IO Bool
-- |The type of the \"element ended\" callback.  The parameter is
-- the element name. Return True to continue parsing as normal, or False to
-- terminate the parse.
type EndElementHandler    = CString -> IO Bool
-- |The type of the \"character data\" callback.  The parameter is
-- the character data processed.  This callback may be called more than once
-- while processing a single conceptual block of text. Return True to continue
-- parsing as normal, or False to terminate the parse.
type CharacterDataHandler = CStringLen -> IO Bool

type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO ()
nullCStartElementHandler _ _ _ = return ()

foreign import ccall unsafe "expat.h XML_GetErrorCode" xmlGetErrorCode
    :: ParserPtr -> IO CInt
foreign import ccall unsafe "expat.h XML_GetCurrentLineNumber" xmlGetCurrentLineNumber
    :: ParserPtr -> IO CUInt  -- to do: Get 64-bit value if supported (how?)
foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber
    :: ParserPtr -> IO CUInt  -- to do: Get 64-bit value if supported (how?)
foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString
    :: CInt -> IO CString
foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser
    :: ParserPtr -> CInt -> IO ()

foreign import ccall safe "wrapper"
  mkCStartElementHandler :: CStartElementHandler
                         -> IO (FunPtr CStartElementHandler)

wrapStartElementHandler :: Parser -> StartElementHandler -> CStartElementHandler
wrapStartElementHandler parser@(Parser _ _ _ _) handler = h
  where
    h ptr cname cattrs = do
        cattrlist <- peekArray0 nullPtr cattrs
        stillRunning <- handler cname (pairwise cattrlist)
        unless stillRunning $
            withParser parser $ \p -> xmlStopParser p 0

-- |Attach a StartElementHandler to a Parser.
setStartElementHandler :: Parser -> StartElementHandler -> IO ()
setStartElementHandler parser@(Parser _ startRef _ _) handler =
    withParser parser $ \p -> do
        writeIORef startRef $ wrapStartElementHandler parser handler

type CEndElementHandler = Ptr () -> CString -> IO ()
nullCEndElementHandler _ _ = return ()

foreign import ccall safe "wrapper"
  mkCEndElementHandler :: CEndElementHandler
                       -> IO (FunPtr CEndElementHandler)
wrapEndElementHandler :: Parser -> EndElementHandler -> CEndElementHandler
wrapEndElementHandler parser@(Parser _ _ _ _) handler = h
  where
    h ptr cname = do
        stillRunning <- handler cname
        unless stillRunning $
            withParser parser $ \p -> xmlStopParser p 0

-- |Attach an EndElementHandler to a Parser.
setEndElementHandler :: Parser -> EndElementHandler -> IO ()
setEndElementHandler parser@(Parser _ _ endRef _) handler =
    withParser parser $ \p -> do
        writeIORef endRef $ wrapEndElementHandler parser handler

type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO ()
nullCCharacterDataHandler _ _ _ = return ()

foreign import ccall safe "wrapper"
  mkCCharacterDataHandler :: CCharacterDataHandler
                          -> IO (FunPtr CCharacterDataHandler)
wrapCharacterDataHandler :: Parser -> CharacterDataHandler -> CCharacterDataHandler
wrapCharacterDataHandler parser@(Parser _ _ _ _) handler = h
  where
    h ptr cdata len = do
        stillRunning <- handler (cdata, fromIntegral len)
        unless stillRunning $
            withParser parser $ \p -> xmlStopParser p 0

-- | Attach an CharacterDataHandler to a Parser.
setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()
setCharacterDataHandler parser@(Parser _ _ _ charRef) handler =
    withParser parser $ \p -> do
        writeIORef charRef $ wrapCharacterDataHandler parser handler

pairwise (x1:x2:xs) = (x1,x2) : pairwise xs
pairwise []         = []

-- hexpat, a Haskell wrapper for expat
-- Copyright (C) 2008 Evan Martin <martine@danga.com>
-- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>

-- | A very low-level interface to Expat. Unless you need extreme speed, this
-- should normally be avoided in favour of the interface provided by "Text-XML-Expat-Tree".
-- Basic usage is:
--
-- (1) Make a new parser: 'newParser'.
--
-- (2) Set up callbacks on the parser: 'setStartElementHandler', etc.
--
-- (3) Feed data into the parser: 'parse' or 'parseChunk'.

module Text.XML.Expat.IO (
  -- ** Parser Setup
  Parser, newParser,

  -- ** Parsing
  parse, parseChunk, Encoding(..), XMLParseError(..),

  -- ** Parser Callbacks
  StartElementHandler, EndElementHandler, CharacterDataHandler,
  setStartElementHandler, setEndElementHandler, setCharacterDataHandler,

  -- ** Lower-level interface
  withHandlers,
  unsafeSetHandlers,
  unsafeReleaseHandlers,
  ExpatHandlers,
  unsafeParseChunk,

  -- ** Helpers
  encodingToString
) where

import Control.Exception (bracket)
import Control.Parallel.Strategies
import Control.Monad
import C2HS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Internal as BSI
import Data.IORef

#include <expat.h>

-- Expat functions start with "XML", but C2HS appears to ignore our "as"
-- definitions if they only differ from the symbol in case.  So we write out
-- XML_* in most cases anyway...  :(
{#context lib = "expat" prefix = "XML"#}

-- |Opaque parser type.
type ParserPtr = Ptr ()
data Parser = Parser
    (ForeignPtr ())
    (IORef CStartElementHandler)
    (IORef CEndElementHandler)
    (IORef CCharacterDataHandler)

instance Show Parser where
    showsPrec _ (Parser fp _ _ _) = showsPrec 0 fp

withParser :: Parser -> (ParserPtr -> IO a) -> IO a
withParser (Parser fp _ _ _) = withForeignPtr fp

-- |Encoding types available for the document encoding.
data Encoding = ASCII | UTF8 | UTF16 | ISO88591
encodingToString :: Encoding -> String
encodingToString ASCII    = "US-ASCII"
encodingToString UTF8     = "UTF-8"
encodingToString UTF16    = "UTF-16"
encodingToString ISO88591 = "ISO-8859-1"

withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a
withOptEncoding Nothing    f = f nullPtr
withOptEncoding (Just enc) f = withCString (encodingToString enc) f

{#fun unsafe XML_ParserCreate as parserCreate
    {withOptEncoding* `Maybe Encoding'} -> `ParserPtr' id#}
foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())

-- |Create a 'Parser'.  The encoding parameter, if provided, overrides the
-- document's encoding declaration.
newParser :: Maybe Encoding -> IO Parser
newParser enc = do
  ptr <- parserCreate enc
  fptr <- newForeignPtr parserFree ptr
  nullStartH <- newIORef nullCStartElementHandler
  nullEndH <- newIORef nullCEndElementHandler
  nullCharH <- newIORef nullCCharacterDataHandler
  return $ Parser fptr nullStartH nullEndH nullCharH

-- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt
-- instead of an Int.
withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a
withBStringLen bs f = do
  BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len)

unStatus :: CInt -> Bool
unStatus 0 = False
unStatus 1 = True

-- |@parse data@ feeds /lazy/ bytestring data into a parser. It returns Nothing
-- on success, or Just the parse error.
parse :: Parser -> BSL.ByteString -> IO (Maybe XMLParseError)
parse parser@(Parser _ _ _ _) bs = withHandlers parser $ feedChunk (BSL.toChunks bs)
  where
    feedChunk []      = return Nothing
    feedChunk (c:cs)  = do
        ok <- doParseChunk parser c (null cs)
        if ok
            then feedChunk cs
            else Just `fmap` getError parser

-- |@parseChunk data False@ feeds /strict/ ByteString data into a
-- 'Parser'.  The end of the data is indicated by passing @True@ for the
-- final parameter.   It returns Nothing on success, or Just the parse error.
parseChunk :: Parser
           -> BS.ByteString
           -> Bool
           -> IO (Maybe XMLParseError)
parseChunk parser xml final = withHandlers parser $ unsafeParseChunk parser xml final

-- | This version of parseChunk must either be called inside withHandlers (safest), or
-- between 'unsafeSetHandlers' and 'unsafeReleaseHandlers', and this
-- will give you better performance if you process multiple chunks inside.
unsafeParseChunk :: Parser
           -> BS.ByteString
           -> Bool
           -> IO (Maybe XMLParseError)
unsafeParseChunk parser xml final = do
    ok <- doParseChunk parser xml final
    if ok
        then return Nothing
        else Just `fmap` getError parser

getError parser = withParser parser $ \p -> do
                code <- xmlGetErrorCode p
                cerr <- xmlErrorString code
                err <- peekCString cerr
                line <- xmlGetCurrentLineNumber p
                col <- xmlGetCurrentColumnNumber p
                return $ XMLParseError err
                    (fromIntegral line) (fromIntegral col)

data ExpatHandlers = ExpatHandlers
    (FunPtr CStartElementHandler)
    (FunPtr CEndElementHandler)
    (FunPtr CCharacterDataHandler)

unsafeSetHandlers :: Parser -> IO ExpatHandlers
unsafeSetHandlers parser@(Parser fp startRef endRef charRef) = do
    cStartH <- mkCStartElementHandler =<< readIORef startRef
    cEndH   <- mkCEndElementHandler =<< readIORef endRef
    cCharH  <- mkCCharacterDataHandler =<< readIORef charRef
    withParser parser $ \p -> do
        {#call unsafe XML_SetStartElementHandler as ^#}  p cStartH
        {#call unsafe XML_SetEndElementHandler as ^#}    p cEndH
        {#call unsafe XML_SetCharacterDataHandler as ^#} p cCharH
    return $ ExpatHandlers cStartH cEndH cCharH

unsafeReleaseHandlers :: ExpatHandlers -> IO ()
unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH) = do
    freeHaskellFunPtr cStartH
    freeHaskellFunPtr cEndH
    freeHaskellFunPtr cCharH

-- | 'unsafeParseChunk' is required to be called inside the argument to this.
-- Safer than using unsafeSetHandlers / unsafeReleaseHandlers.
withHandlers :: Parser -> IO a -> IO a
withHandlers parser code = do
    bracket
        (unsafeSetHandlers parser)
        unsafeReleaseHandlers
        (\_ -> code)

{#fun XML_Parse as doParseChunk
    {withParser* `Parser', withBStringLen* `BS.ByteString' &, `Bool'}
    -> `Bool' unStatus#}

-- | Parse error, consisting of message text, line number, and column number
data XMLParseError = XMLParseError String Integer Integer deriving (Eq, Show)

instance NFData XMLParseError where
    rnf (XMLParseError msg lin col) = rnf (msg, lin, col)

-- |The type of the \"element started\" callback.  The first parameter is
-- the element name; the second are the (attribute, value) pairs. Return True
-- to continue parsing as normal, or False to terminate the parse.
type StartElementHandler  = CString -> [(CString, CString)] -> IO Bool
-- |The type of the \"element ended\" callback.  The parameter is
-- the element name. Return True to continue parsing as normal, or False to
-- terminate the parse.
type EndElementHandler    = CString -> IO Bool
-- |The type of the \"character data\" callback.  The parameter is
-- the character data processed.  This callback may be called more than once
-- while processing a single conceptual block of text. Return True to continue
-- parsing as normal, or False to terminate the parse.
type CharacterDataHandler = CStringLen -> IO Bool

type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO ()
nullCStartElementHandler _ _ _ = return ()

foreign import ccall unsafe "expat.h XML_GetErrorCode" xmlGetErrorCode
    :: ParserPtr -> IO CInt
foreign import ccall unsafe "expat.h XML_GetCurrentLineNumber" xmlGetCurrentLineNumber
    :: ParserPtr -> IO CUInt  -- to do: Get 64-bit value if supported (how?)
foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber
    :: ParserPtr -> IO CUInt  -- to do: Get 64-bit value if supported (how?)
foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString
    :: CInt -> IO CString
foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser
    :: ParserPtr -> CInt -> IO ()

foreign import ccall safe "wrapper"
  mkCStartElementHandler :: CStartElementHandler
                         -> IO (FunPtr CStartElementHandler)

wrapStartElementHandler :: Parser -> StartElementHandler -> CStartElementHandler
wrapStartElementHandler parser@(Parser _ _ _ _) handler = h
  where
    h ptr cname cattrs = do
        cattrlist <- peekArray0 nullPtr cattrs
        stillRunning <- handler cname (pairwise cattrlist)
        unless stillRunning $
            withParser parser $ \p -> xmlStopParser p 0

-- |Attach a StartElementHandler to a Parser.
setStartElementHandler :: Parser -> StartElementHandler -> IO ()
setStartElementHandler parser@(Parser _ startRef _ _) handler =
    withParser parser $ \p -> do
        writeIORef startRef $ wrapStartElementHandler parser handler

type CEndElementHandler = Ptr () -> CString -> IO ()
nullCEndElementHandler _ _ = return ()

foreign import ccall safe "wrapper"
  mkCEndElementHandler :: CEndElementHandler
                       -> IO (FunPtr CEndElementHandler)
wrapEndElementHandler :: Parser -> EndElementHandler -> CEndElementHandler
wrapEndElementHandler parser@(Parser _ _ _ _) handler = h
  where
    h ptr cname = do
        stillRunning <- handler cname
        unless stillRunning $
            withParser parser $ \p -> xmlStopParser p 0

-- |Attach an EndElementHandler to a Parser.
setEndElementHandler :: Parser -> EndElementHandler -> IO ()
setEndElementHandler parser@(Parser _ _ endRef _) handler =
    withParser parser $ \p -> do
        writeIORef endRef $ wrapEndElementHandler parser handler

type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO ()
nullCCharacterDataHandler _ _ _ = return ()

foreign import ccall safe "wrapper"
  mkCCharacterDataHandler :: CCharacterDataHandler
                          -> IO (FunPtr CCharacterDataHandler)
wrapCharacterDataHandler :: Parser -> CharacterDataHandler -> CCharacterDataHandler
wrapCharacterDataHandler parser@(Parser _ _ _ _) handler = h
  where
    h ptr cdata len = do
        stillRunning <- handler (cdata, fromIntegral len)
        unless stillRunning $
            withParser parser $ \p -> xmlStopParser p 0

-- | Attach an CharacterDataHandler to a Parser.
setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()
setCharacterDataHandler parser@(Parser _ _ _ charRef) handler =
    withParser parser $ \p -> do
        writeIORef charRef $ wrapCharacterDataHandler parser handler

pairwise (x1:x2:xs) = (x1,x2) : pairwise xs
pairwise []         = []


Make MessageID a newtype.

Make MessageID a newtype.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Statusbar
--
--  Author : Axel Simon
--
--  Created: 23 May 2001
--
--  Version $Revision: 1.8 $ from $Date: 2005/11/06 20:46:10 $
--
--  Copyright (C) 1999-2005 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Report messages of minor importance to the user
--
module Graphics.UI.Gtk.Display.Statusbar (
-- * Detail
--
-- | A 'Statusbar' is usually placed along the bottom of an application's main
-- 'Window'. It may provide a regular commentary of the application's status
-- (as is usually the case in a web browser, for example), or may be used to
-- simply output a message when the status changes, (when an upload is complete
-- in an FTP client, for example). It may also have a resize grip (a triangular
-- area in the lower right corner) which can be clicked on to resize the window
-- containing the statusbar.
--
-- Status bars in Gtk+ maintain a stack of messages. The message at the top
-- of the each bar's stack is the one that will currently be displayed.
--
-- Any messages added to a statusbar's stack must specify a /context_id/
-- that is used to uniquely identify the source of a message. This context_id
-- can be generated by 'statusbarGetContextId', given a message and the
-- statusbar that it will be added to. Note that messages are stored in a
-- stack, and when choosing which message to display, the stack structure is
-- adhered to, regardless of the context identifier of a message.
--
-- Status bars are created using 'statusbarNew'.
--
-- Messages are added to the bar's stack with 'statusbarPush'.
--
-- The message at the top of the stack can be removed using 'statusbarPop'.
-- A message can be removed from anywhere in the stack if its message_id was
-- recorded at the time it was added. This is done using 'statusbarRemove'.

-- * Class Hierarchy
-- |
-- @
-- |  'GObject'
-- |   +----'Object'
-- |         +----'Widget'
-- |               +----'Container'
-- |                     +----'Box'
-- |                           +----'HBox'
-- |                                 +----Statusbar
-- @

-- * Types
  Statusbar,
  StatusbarClass,
  castToStatusbar,
  toStatusbar,
  ContextId,
  MessageId,

-- * Constructors
  statusbarNew,

-- * Methods
  statusbarGetContextId,
  statusbarPush,
  statusbarPop,
  statusbarRemove,
  statusbarSetHasResizeGrip,
  statusbarGetHasResizeGrip,

-- * Attributes
  statusbarHasResizeGrip,

-- * Signals
  onTextPopped,
  afterTextPopped,
  onTextPushed,
  afterTextPushed,
  ) where

import Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.Attributes
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}

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

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

-- | Creates a new 'Statusbar' ready for messages.
--
statusbarNew :: IO Statusbar
statusbarNew =
  makeNewObject mkStatusbar $
  liftM (castPtr :: Ptr Widget -> Ptr Statusbar) $
  {# call unsafe statusbar_new #}

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

type ContextId = {#type guint#}

-- | Returns a new context identifier, given a description of the actual
-- context. This id can be used to later remove entries form the Statusbar.
--
statusbarGetContextId :: StatusbarClass self => self
 -> String       -- ^ @contextDescription@ - textual description of what context the
                 -- new message is being used in.
 -> IO ContextId -- ^ returns an id that can be used to later remove entries
                 -- ^ from the Statusbar.
statusbarGetContextId self contextDescription =
  withUTFString contextDescription $ \contextDescriptionPtr ->
  {# call unsafe statusbar_get_context_id #}
    (toStatusbar self)
    contextDescriptionPtr

newtype MessageId = MessageId {#type guint#}

-- | Pushes a new message onto the Statusbar's stack. It will
-- be displayed as long as it is on top of the stack.
--
statusbarPush :: StatusbarClass self => self
 -> ContextId    -- ^ @contextId@ - the message's context id, as returned by
                 -- 'statusbarGetContextId'.
 -> String       -- ^ @text@ - the message to add to the statusbar.
 -> IO MessageId -- ^ returns the message's new message id for use with
                 -- 'statusbarRemove'.
statusbarPush self contextId text =
  liftM MessageId $
  withUTFString text $ \textPtr ->
  {# call statusbar_push #}
    (toStatusbar self)
    contextId
    textPtr

-- | Removes the topmost message that has the correct context.
--
statusbarPop :: StatusbarClass self => self
 -> ContextId   -- ^ @contextId@ - the context identifier used when the
                -- message was added.
 -> IO ()
statusbarPop self contextId =
  {# call statusbar_pop #}
    (toStatusbar self)
     contextId

-- | Forces the removal of a message from a statusbar's stack. The exact
-- @contextId@ and @messageId@ must be specified.
--
statusbarRemove :: StatusbarClass self => self
 -> ContextId -- ^ @contextId@ - a context identifier.
 -> MessageId -- ^ @messageId@ - a message identifier, as returned by
              -- 'statusbarPush'.
 -> IO ()
statusbarRemove self contextId (MessageId messageId) =
  {# call statusbar_remove #}
    (toStatusbar self)
    contextId
    messageId

-- | Sets whether the statusbar has a resize grip. @True@ by default.
--
statusbarSetHasResizeGrip :: StatusbarClass self => self -> Bool -> IO ()
statusbarSetHasResizeGrip self setting =
  {# call statusbar_set_has_resize_grip #}
    (toStatusbar self)
    (fromBool setting)

-- | Returns whether the statusbar has a resize grip.
--
statusbarGetHasResizeGrip :: StatusbarClass self => self -> IO Bool
statusbarGetHasResizeGrip self =
  liftM toBool $
  {# call unsafe statusbar_get_has_resize_grip #}
    (toStatusbar self)

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

-- | Whether the statusbar has a grip for resizing the toplevel window.
--
-- Default value: @True@
--
statusbarHasResizeGrip :: StatusbarClass self => Attr self Bool
statusbarHasResizeGrip = newAttr
  statusbarGetHasResizeGrip
  statusbarSetHasResizeGrip

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

-- | Called if a message is removed.
--
onTextPopped, afterTextPopped :: StatusbarClass self => self
 -> (ContextId -> String -> IO ())
 -> IO (ConnectId self)
onTextPopped self user = connect_WORD_STRING__NONE "text-popped" False self (user . fromIntegral)
afterTextPopped self user = connect_WORD_STRING__NONE "text-popped" True self (user . fromIntegral)

-- | Called if a message is pushed on top of the
-- stack.
--
onTextPushed, afterTextPushed :: StatusbarClass self => self
 -> (ContextId -> String -> IO ())
 -> IO (ConnectId self)
onTextPushed self user = connect_WORD_STRING__NONE "text-pushed" False self (user . fromIntegral)
afterTextPushed self user = connect_WORD_STRING__NONE "text-pushed" True self (user . fromIntegral)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Statusbar
--
--  Author : Axel Simon
--
--  Created: 23 May 2001
--
--  Version $Revision: 1.8 $ from $Date: 2005/11/06 20:46:10 $
--
--  Copyright (C) 1999-2005 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Report messages of minor importance to the user
--
module Graphics.UI.Gtk.Display.Statusbar (
-- * Detail
--
-- | A 'Statusbar' is usually placed along the bottom of an application's main
-- 'Window'. It may provide a regular commentary of the application's status
-- (as is usually the case in a web browser, for example), or may be used to
-- simply output a message when the status changes, (when an upload is complete
-- in an FTP client, for example). It may also have a resize grip (a triangular
-- area in the lower right corner) which can be clicked on to resize the window
-- containing the statusbar.
--
-- Status bars in Gtk+ maintain a stack of messages. The message at the top
-- of the each bar's stack is the one that will currently be displayed.
--
-- Any messages added to a statusbar's stack must specify a /context_id/
-- that is used to uniquely identify the source of a message. This context_id
-- can be generated by 'statusbarGetContextId', given a message and the
-- statusbar that it will be added to. Note that messages are stored in a
-- stack, and when choosing which message to display, the stack structure is
-- adhered to, regardless of the context identifier of a message.
--
-- Status bars are created using 'statusbarNew'.
--
-- Messages are added to the bar's stack with 'statusbarPush'.
--
-- The message at the top of the stack can be removed using 'statusbarPop'.
-- A message can be removed from anywhere in the stack if its message_id was
-- recorded at the time it was added. This is done using 'statusbarRemove'.

-- * Class Hierarchy
-- |
-- @
-- |  'GObject'
-- |   +----'Object'
-- |         +----'Widget'
-- |               +----'Container'
-- |                     +----'Box'
-- |                           +----'HBox'
-- |                                 +----Statusbar
-- @

-- * Types
  Statusbar,
  StatusbarClass,
  castToStatusbar,
  toStatusbar,
  ContextId,
  MessageId,

-- * Constructors
  statusbarNew,

-- * Methods
  statusbarGetContextId,
  statusbarPush,
  statusbarPop,
  statusbarRemove,
  statusbarSetHasResizeGrip,
  statusbarGetHasResizeGrip,

-- * Attributes
  statusbarHasResizeGrip,

-- * Signals
  onTextPopped,
  afterTextPopped,
  onTextPushed,
  afterTextPushed,
  ) where

import Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.Attributes
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}

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

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

-- | Creates a new 'Statusbar' ready for messages.
--
statusbarNew :: IO Statusbar
statusbarNew =
  makeNewObject mkStatusbar $
  liftM (castPtr :: Ptr Widget -> Ptr Statusbar) $
  {# call unsafe statusbar_new #}

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

type ContextId = {#type guint#}

-- | Returns a new context identifier, given a description of the actual
-- context. This id can be used to later remove entries form the Statusbar.
--
statusbarGetContextId :: StatusbarClass self => self
 -> String       -- ^ @contextDescription@ - textual description of what context the
                 -- new message is being used in.
 -> IO ContextId -- ^ returns an id that can be used to later remove entries
                 -- ^ from the Statusbar.
statusbarGetContextId self contextDescription =
  withUTFString contextDescription $ \contextDescriptionPtr ->
  {# call unsafe statusbar_get_context_id #}
    (toStatusbar self)
    contextDescriptionPtr

type MessageId = {#type guint#}

-- | Pushes a new message onto the Statusbar's stack. It will
-- be displayed as long as it is on top of the stack.
--
statusbarPush :: StatusbarClass self => self
 -> ContextId    -- ^ @contextId@ - the message's context id, as returned by
                 -- 'statusbarGetContextId'.
 -> String       -- ^ @text@ - the message to add to the statusbar.
 -> IO MessageId -- ^ returns the message's new message id for use with
                 -- 'statusbarRemove'.
statusbarPush self contextId text =
  withUTFString text $ \textPtr ->
  {# call statusbar_push #}
    (toStatusbar self)
    contextId
    textPtr

-- | Removes the topmost message that has the correct context.
--
statusbarPop :: StatusbarClass self => self
 -> ContextId   -- ^ @contextId@ - the context identifier used when the
                -- message was added.
 -> IO ()
statusbarPop self contextId =
  {# call statusbar_pop #}
    (toStatusbar self)
     contextId

-- | Forces the removal of a message from a statusbar's stack. The exact
-- @contextId@ and @messageId@ must be specified.
--
statusbarRemove :: StatusbarClass self => self
 -> ContextId -- ^ @contextId@ - a context identifier.
 -> MessageId -- ^ @messageId@ - a message identifier, as returned by
              -- 'statusbarPush'.
 -> IO ()
statusbarRemove self contextId messageId =
  {# call statusbar_remove #}
    (toStatusbar self)
    contextId
    messageId

-- | Sets whether the statusbar has a resize grip. @True@ by default.
--
statusbarSetHasResizeGrip :: StatusbarClass self => self -> Bool -> IO ()
statusbarSetHasResizeGrip self setting =
  {# call statusbar_set_has_resize_grip #}
    (toStatusbar self)
    (fromBool setting)

-- | Returns whether the statusbar has a resize grip.
--
statusbarGetHasResizeGrip :: StatusbarClass self => self -> IO Bool
statusbarGetHasResizeGrip self =
  liftM toBool $
  {# call unsafe statusbar_get_has_resize_grip #}
    (toStatusbar self)

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

-- | Whether the statusbar has a grip for resizing the toplevel window.
--
-- Default value: @True@
--
statusbarHasResizeGrip :: StatusbarClass self => Attr self Bool
statusbarHasResizeGrip = newAttr
  statusbarGetHasResizeGrip
  statusbarSetHasResizeGrip

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

-- | Called if a message is removed.
--
onTextPopped, afterTextPopped :: StatusbarClass self => self
 -> (ContextId -> String -> IO ())
 -> IO (ConnectId self)
onTextPopped self user = connect_WORD_STRING__NONE "text-popped" False self (user . fromIntegral)
afterTextPopped self user = connect_WORD_STRING__NONE "text-popped" True self (user . fromIntegral)

-- | Called if a message is pushed on top of the
-- stack.
--
onTextPushed, afterTextPushed :: StatusbarClass self => self
 -> (ContextId -> String -> IO ())
 -> IO (ConnectId self)
onTextPushed self user = connect_WORD_STRING__NONE "text-pushed" False self (user . fromIntegral)
afterTextPushed self user = connect_WORD_STRING__NONE "text-pushed" True self (user . fromIntegral)


Added bcast

Added bcast

{-# LANGUAGE ForeignFunctionInterface #-}

#include <mpi.h>
#include "init_wrapper.h"

module Bindings.MPI.Internal
   ( init, finalize, send, recv, commRank, probe, commSize,
     iSend, iRecv, bcast
   ) where

import Prelude hiding (init, error)
import C2HS
import Control.Applicative ((<$>))
import Bindings.MPI.Comm (Comm)
import Bindings.MPI.Request (Request)
import Bindings.MPI.Status (Status, StatusPtr)
import Bindings.MPI.MarshalUtils (enumToCInt)
import Bindings.MPI.ErrorClasses (ErrorClass)
import Bindings.MPI.MarshalUtils (enumFromCInt)
import Bindings.MPI.Utils (checkError)

{# context prefix = "MPI" #}

init = {# call unsafe init_wrapper as init_wrapper_ #}
finalize = {# call unsafe Finalize as finalize_ #}
commSize = {# call unsafe Comm_size as commSize_ #}
commRank = {# call unsafe Comm_rank as commRank_ #}
probe = {# call Probe as probe_ #}
send = {# call unsafe Send as send_ #}
recv = {# call unsafe Recv as recv_ #}
iSend = {# call unsafe Isend as iSend_ #}
iRecv = {# call Irecv as iRecv_ #}
bcast = {# call Bcast as bcast_ #}

{-# LANGUAGE ForeignFunctionInterface #-}

#include <mpi.h>
#include "init_wrapper.h"

module Bindings.MPI.Internal
   ( init, finalize, send, recv, commRank, probe, commSize,
     iSend, iRecv
   ) where

import Prelude hiding (init, error)
import C2HS
import Control.Applicative ((<$>))
import Bindings.MPI.Comm (Comm)
import Bindings.MPI.Request (Request)
import Bindings.MPI.Status (Status, StatusPtr)
import Bindings.MPI.MarshalUtils (enumToCInt)
import Bindings.MPI.ErrorClasses (ErrorClass)
import Bindings.MPI.MarshalUtils (enumFromCInt)
import Bindings.MPI.Utils (checkError)

{# context prefix = "MPI" #}

init = {# call unsafe init_wrapper as init_wrapper_ #}
finalize = {# call unsafe Finalize as finalize_ #}
commSize = {# call unsafe Comm_size as commSize_ #}
commRank = {# call unsafe Comm_rank as commRank_ #}
probe = {# call Probe as probe_ #}
send = {# call unsafe Send as send_ #}
recv = {# call unsafe Recv as recv_ #}
iSend = {# call unsafe Isend as iSend_ #}
iRecv = {# call Irecv as iRecv_ #}


Implement annotTextGetIsOpen and annotTextSetIsOpen

{-# LANGUAGE CPP, DeriveDataTypeable #-}
module Graphics.UI.Gtk.Poppler.Annotation (
    Annot,
    AnnotClass,
    AnnotType (..),
    AnnotFlag (..),
    AnnotMarkup,
    AnnotMarkupClass,
    annotGetAnnotType,
    annotGetAnnotFlags,
    annotSetAnnotFlags,
    annotGetName,
    annotGetPageIndex,
    annotGetColor,
    annotSetColor,
    annotGetContents,
    annotSetContents,
    annotGetModified,
    annotMarkupGetLabel,
    annotMarkupSetLabel,
    annotMarkupGetSubject,
    annotMarkupGetOpacity,
    annotMarkupSetOpacity,
    annotMarkupHasPopup,
    annotMarkupSetPopup,
    annotMarkupGetPopupIsOpen,
    annotMarkupSetPopupIsOpen,
    annotTextNew,
    annotTextGetIsOpen,
    annotTextSetIsOpen
    ) 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

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

annotGetAnnotType :: AnnotClass annot => annot -> IO AnnotType
annotGetAnnotType annot =
  liftM (toEnum . fromIntegral) $
  {# call poppler_annot_get_annot_type #} (toAnnot annot)

annotGetAnnotFlags :: AnnotClass annot => annot -> IO AnnotFlag
annotGetAnnotFlags annot =
  liftM (toEnum . fromIntegral) $
  {# call poppler_annot_get_flags #} (toAnnot annot)

annotSetAnnotFlags :: AnnotClass annot => annot -> AnnotFlag -> IO ()
annotSetAnnotFlags annot flag =
  {# call poppler_annot_set_flags #}
  (toAnnot annot)
  (fromIntegral $ fromEnum flag)

annotGetName :: AnnotClass annot => annot -> IO String
annotGetName annot =
  {# call poppler_annot_get_name #} (toAnnot annot) >>= peekUTFString

annotGetPageIndex :: AnnotClass annot => annot -> IO Int
annotGetPageIndex annot =
  liftM fromIntegral $
  {# call poppler_annot_get_page_index #} (toAnnot annot)

annotGetColor :: AnnotClass annot => annot -> IO PopplerColor
annotGetColor annot =
  (peekPopplerColor . castPtr) =<<
  {# call poppler_annot_get_color #} (toAnnot annot)

annotSetColor :: AnnotClass annot => annot -> PopplerColor -> IO ()
annotSetColor annot color =
  with color $ \colorPtr ->
    {# call poppler_annot_set_color #} (toAnnot annot) (castPtr colorPtr)

annotGetContents :: AnnotClass annot => annot -> IO String
annotGetContents annot =
  {# call poppler_annot_get_contents #} (toAnnot annot) >>= peekUTFString

annotSetContents :: AnnotClass annot => annot -> String -> IO ()
annotSetContents annot content =
  withUTFString content $ \contentPtr ->
    {# call poppler_annot_set_contents #} (toAnnot annot) contentPtr

annotGetModified :: AnnotClass annot => annot -> IO String
annotGetModified annot =
  {# call poppler_annot_get_modified #} (toAnnot annot) >>= peekUTFString

annotMarkupGetLabel :: AnnotMarkupClass mark => mark -> IO String
annotMarkupGetLabel mark =
  peekUTFString =<<
  {# call poppler_annot_markup_get_label #} (toAnnotMarkup mark)

annotMarkupSetLabel :: AnnotMarkupClass mark => mark -> String -> IO ()
annotMarkupSetLabel mark label =
  withUTFString label $ \labelPtr ->
    {# call poppler_annot_markup_set_label #}
    (toAnnotMarkup mark)
    (castPtr labelPtr)

annotMarkupGetSubject :: AnnotMarkupClass mark => mark -> IO String
annotMarkupGetSubject mark =
  peekUTFString =<<
  {# call poppler_annot_markup_get_subject #} (toAnnotMarkup mark)

annotMarkupGetOpacity :: AnnotMarkupClass mark => mark -> IO Double
annotMarkupGetOpacity mark =
  liftM realToFrac $
  {# call poppler_annot_markup_get_opacity #} (toAnnotMarkup mark)

annotMarkupSetOpacity :: AnnotMarkupClass mark => mark -> Double -> IO ()
annotMarkupSetOpacity mark opacity =
  {# call poppler_annot_markup_set_opacity #}
  (toAnnotMarkup mark)
  (realToFrac opacity)

annotMarkupHasPopup :: AnnotMarkupClass mark => mark -> IO Bool
annotMarkupHasPopup mark =
  liftM toBool $
  {# call poppler_annot_markup_has_popup #} (toAnnotMarkup mark)

annotMarkupSetPopup :: AnnotMarkupClass mark
                    => mark
                    -> PopplerRectangle
                    -> IO ()
annotMarkupSetPopup mark rect =
  with rect $ \rectPtr ->
    {# call poppler_annot_markup_set_popup #} (toAnnotMarkup mark) (castPtr rectPtr)

annotMarkupGetPopupIsOpen :: AnnotMarkupClass mark => mark -> IO Bool
annotMarkupGetPopupIsOpen mark =
  liftM toBool $
  {# call poppler_annot_markup_get_popup_is_open #} (toAnnotMarkup mark)

annotMarkupSetPopupIsOpen :: AnnotMarkupClass mark => mark -> Bool -> IO ()
annotMarkupSetPopupIsOpen mark bool =
  {# call poppler_annot_markup_set_popup_is_open #}
  (toAnnotMarkup mark)
  (fromBool bool)

annotTextNew :: DocumentClass doc => doc -> PopplerRectangle -> IO Annot
annotTextNew doc selection =
  wrapNewGObject mkAnnot $
  with selection $ \selectionPtr ->
    {# call poppler_annot_text_new #} (toDocument doc) (castPtr selectionPtr)

annotTextGetIsOpen :: AnnotClass annot => annot -> IO Bool
annotTextGetIsOpen annot =
  liftM toBool $
  withForeignPtr (unAnnot (toAnnot annot)) $ \annotPtr ->
    {# call poppler_annot_text_get_is_open #} (castPtr annotPtr)

annotTextSetIsOpen :: AnnotClass annot => annot -> Bool -> IO ()
annotTextSetIsOpen annot bool =
  withForeignPtr (unAnnot (toAnnot annot)) $ \annotPtr ->
    {# call poppler_annot_text_set_is_open #}
    (castPtr annotPtr)
    (fromBool bool)

{-# LANGUAGE CPP, DeriveDataTypeable #-}
module Graphics.UI.Gtk.Poppler.Annotation (
    Annot,
    AnnotClass,
    AnnotType (..),
    AnnotFlag (..),
    AnnotMarkup,
    AnnotMarkupClass,
    annotGetAnnotType,
    annotGetAnnotFlags,
    annotSetAnnotFlags,
    annotGetName,
    annotGetPageIndex,
    annotGetColor,
    annotSetColor,
    annotGetContents,
    annotSetContents,
    annotGetModified,
    annotMarkupGetLabel,
    annotMarkupSetLabel,
    annotMarkupGetSubject,
    annotMarkupGetOpacity,
    annotMarkupSetOpacity,
    annotMarkupHasPopup,
    annotMarkupSetPopup,
    annotMarkupGetPopupIsOpen,
    annotMarkupSetPopupIsOpen,
    annotTextNew
    ) 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

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

annotGetAnnotType :: AnnotClass annot => annot -> IO AnnotType
annotGetAnnotType annot =
  liftM (toEnum . fromIntegral) $
  {# call poppler_annot_get_annot_type #} (toAnnot annot)

annotGetAnnotFlags :: AnnotClass annot => annot -> IO AnnotFlag
annotGetAnnotFlags annot =
  liftM (toEnum . fromIntegral) $
  {# call poppler_annot_get_flags #} (toAnnot annot)

annotSetAnnotFlags :: AnnotClass annot => annot -> AnnotFlag -> IO ()
annotSetAnnotFlags annot flag =
  {# call poppler_annot_set_flags #}
  (toAnnot annot)
  (fromIntegral $ fromEnum flag)

annotGetName :: AnnotClass annot => annot -> IO String
annotGetName annot =
  {# call poppler_annot_get_name #} (toAnnot annot) >>= peekUTFString

annotGetPageIndex :: AnnotClass annot => annot -> IO Int
annotGetPageIndex annot =
  liftM fromIntegral $
  {# call poppler_annot_get_page_index #} (toAnnot annot)

annotGetColor :: AnnotClass annot => annot -> IO PopplerColor
annotGetColor annot =
  (peekPopplerColor . castPtr) =<<
  {# call poppler_annot_get_color #} (toAnnot annot)

annotSetColor :: AnnotClass annot => annot -> PopplerColor -> IO ()
annotSetColor annot color =
  with color $ \colorPtr ->
    {# call poppler_annot_set_color #} (toAnnot annot) (castPtr colorPtr)

annotGetContents :: AnnotClass annot => annot -> IO String
annotGetContents annot =
  {# call poppler_annot_get_contents #} (toAnnot annot) >>= peekUTFString

annotSetContents :: AnnotClass annot => annot -> String -> IO ()
annotSetContents annot content =
  withUTFString content $ \contentPtr ->
    {# call poppler_annot_set_contents #} (toAnnot annot) contentPtr

annotGetModified :: AnnotClass annot => annot -> IO String
annotGetModified annot =
  {# call poppler_annot_get_modified #} (toAnnot annot) >>= peekUTFString

annotMarkupGetLabel :: AnnotMarkupClass mark => mark -> IO String
annotMarkupGetLabel mark =
  peekUTFString =<<
  {# call poppler_annot_markup_get_label #} (toAnnotMarkup mark)

annotMarkupSetLabel :: AnnotMarkupClass mark => mark -> String -> IO ()
annotMarkupSetLabel mark label =
  withUTFString label $ \labelPtr ->
    {# call poppler_annot_markup_set_label #}
    (toAnnotMarkup mark)
    (castPtr labelPtr)

annotMarkupGetSubject :: AnnotMarkupClass mark => mark -> IO String
annotMarkupGetSubject mark =
  peekUTFString =<<
  {# call poppler_annot_markup_get_subject #} (toAnnotMarkup mark)

annotMarkupGetOpacity :: AnnotMarkupClass mark => mark -> IO Double
annotMarkupGetOpacity mark =
  liftM realToFrac $
  {# call poppler_annot_markup_get_opacity #} (toAnnotMarkup mark)

annotMarkupSetOpacity :: AnnotMarkupClass mark => mark -> Double -> IO ()
annotMarkupSetOpacity mark opacity =
  {# call poppler_annot_markup_set_opacity #}
  (toAnnotMarkup mark)
  (realToFrac opacity)

annotMarkupHasPopup :: AnnotMarkupClass mark => mark -> IO Bool
annotMarkupHasPopup mark =
  liftM toBool $
  {# call poppler_annot_markup_has_popup #} (toAnnotMarkup mark)

annotMarkupSetPopup :: AnnotMarkupClass mark
                    => mark
                    -> PopplerRectangle
                    -> IO ()
annotMarkupSetPopup mark rect =
  with rect $ \rectPtr ->
    {# call poppler_annot_markup_set_popup #} (toAnnotMarkup mark) (castPtr rectPtr)

annotMarkupGetPopupIsOpen :: AnnotMarkupClass mark => mark -> IO Bool
annotMarkupGetPopupIsOpen mark =
  liftM toBool $
  {# call poppler_annot_markup_get_popup_is_open #} (toAnnotMarkup mark)

annotMarkupSetPopupIsOpen :: AnnotMarkupClass mark => mark -> Bool -> IO ()
annotMarkupSetPopupIsOpen mark bool =
  {# call poppler_annot_markup_set_popup_is_open #}
  (toAnnotMarkup mark)
  (fromBool bool)

annotTextNew :: DocumentClass doc => doc -> PopplerRectangle -> IO Annot
annotTextNew doc selection =
  wrapNewGObject mkAnnot $
  with selection $ \selectionPtr ->
    {# call poppler_annot_text_new #} (toDocument doc) (castPtr selectionPtr)


GHC 7.6 compatibility

GHC 7.6 compatibility

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

  Iterator,
  Iterable,
  IteratorFilter,
  IteratorFoldFunction,
  IteratorResult(..),

  iteratorNext,
  iteratorResync,
  iteratorFilter,
  iteratorFold,
  iteratorForeach,
  iteratorFind

  ) where

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

import Data.Maybe (fromJust)
import System.Glib.FFI
{#import System.Glib.GValue#}
import Data.IORef

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

iteratorNext :: Iterable a
             => Iterator a
             -> IO (IteratorResult, Maybe a)
iteratorNext (Iterator iterator) =
    alloca $ \elemPtr ->
        do result <- {# call iterator_next #} iterator elemPtr
           obj <- peek elemPtr >>= maybePeek peekIterable
           return (toEnum $ fromIntegral result, obj)

iteratorResync :: Iterator a
               -> IO ()
iteratorResync (Iterator iterator) =
    {# call iterator_resync #} iterator

type CIteratorFilter =  {# type gpointer #}
                     -> {# type gpointer #}
                     -> IO {# type gint #}
marshalIteratorFilter :: Iterable a
                      => IteratorFilter a
                      -> IO {# type GCompareFunc #}
marshalIteratorFilter iteratorFilter =
    makeIteratorFilter cIteratorFilter
    where cIteratorFilter elementPtr _ =
              do include <- peekIterable elementPtr >>= iteratorFilter
                 return $ if include then 1 else 0
foreign import ccall "wrapper"
    makeIteratorFilter :: CIteratorFilter
                    -> IO {# type GCompareFunc #}

iteratorFilter :: Iterable a
               => Iterator a
               -> IteratorFilter a
               -> IO (Iterator a)
iteratorFilter (Iterator iterator) filter =
    do cFilter <- marshalIteratorFilter filter
       {# call iterator_filter #} iterator cFilter nullPtr >>=
           takeIterator

{- type IteratorFoldFunction itemT accumT = itemT
                                         -> accumT
                                         -> IO (Maybe accumT) -}
type CIteratorFoldFunction =  {# type gpointer #}
                           -> Ptr GValue
                           -> {# type gpointer #}
                           -> IO {# type gboolean #}
marshalIteratorFoldFunction :: Iterable itemT
                            => IteratorFoldFunction itemT accumT
                            -> IORef accumT
                            -> IO {# type GstIteratorFoldFunction #}
marshalIteratorFoldFunction iteratorFoldFunction accumRef =
    makeIteratorFoldFunction cIteratorFoldFunction
    where cIteratorFoldFunction :: CIteratorFoldFunction
          cIteratorFoldFunction itemPtr _ _ =
              do item <- peekIterable itemPtr
                 accum <- readIORef accumRef
                 (continue, accum') <- iteratorFoldFunction item accum
                 writeIORef accumRef accum'
                 return $ fromBool continue
foreign import ccall "wrapper"
    makeIteratorFoldFunction :: CIteratorFoldFunction
                             -> IO {# type GstIteratorFoldFunction #}

iteratorFold :: Iterable itemT
             => Iterator itemT
             -> accumT
             -> IteratorFoldFunction itemT accumT
             -> IO (IteratorResult, accumT)
iteratorFold (Iterator iterator) init func =
    do accumRef <- newIORef init
       func' <- marshalIteratorFoldFunction func accumRef
       result <- {# call iterator_fold #} iterator
                                          func'
                                          (GValue nullPtr)
                                          nullPtr
       freeHaskellFunPtr func'
       accum <- readIORef accumRef
       return (toEnum $ fromIntegral result, accum)

iteratorForeach :: Iterable itemT
                => Iterator itemT
                -> (itemT -> IO ())
                -> IO IteratorResult
iteratorForeach iterator func =
    do (result, _) <- iteratorFold iterator () $ \item _ ->
                          func item >> return (True, ())
       return result

iteratorFind :: Iterable itemT
             => Iterator itemT
             -> (itemT -> IO Bool)
             -> IO (IteratorResult, Maybe itemT)
iteratorFind iterator pred =
    iteratorFold iterator Nothing $ \item accum ->
        do found <- pred item
           if found
               then return (False, Just item)
               else return (True, accum)

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

  Iterator,
  Iterable,
  IteratorFilter,
  IteratorFoldFunction,
  IteratorResult(..),

  iteratorNext,
  iteratorResync,
  iteratorFilter,
  iteratorFold,
  iteratorForeach,
  iteratorFind

  ) where

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

import Data.Maybe (fromJust)
import System.Glib.FFI
{#import System.Glib.GValue#}
import Data.IORef

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

iteratorNext :: Iterable a
             => Iterator a
             -> IO (IteratorResult, Maybe a)
iteratorNext (Iterator iterator) =
    alloca $ \elemPtr ->
        do result <- {# call iterator_next #} iterator elemPtr
           obj <- peek elemPtr >>= maybePeek peekIterable
           return (toEnum $ fromIntegral result, obj)

iteratorResync :: Iterator a
               -> IO ()
iteratorResync (Iterator iterator) =
    {# call iterator_resync #} iterator

type CIteratorFilter =  {# type gpointer #}
                     -> {# type gpointer #}
                     -> IO {# type gint #}
marshalIteratorFilter :: Iterable a
                      => IteratorFilter a
                      -> IO {# type GCompareFunc #}
marshalIteratorFilter iteratorFilter =
    makeIteratorFilter cIteratorFilter
    where cIteratorFilter elementPtr _ =
              do include <- peekIterable elementPtr >>= iteratorFilter
                 return $ if include then 1 else 0
foreign import ccall "wrapper"
    makeIteratorFilter :: CIteratorFilter
                    -> IO {# type GCompareFunc #}

iteratorFilter :: Iterable a
               => Iterator a
               -> IteratorFilter a
               -> IO (Iterator a)
iteratorFilter (Iterator iterator) filter =
    do cFilter <- marshalIteratorFilter filter
       {# call iterator_filter #} iterator cFilter nullPtr >>=
           takeIterator

{- type IteratorFoldFunction itemT accumT = itemT
                                         -> accumT
                                         -> IO (Maybe accumT) -}
type CIteratorFoldFunction =  {# type gpointer #}
                           -> GValue
                           -> {# type gpointer #}
                           -> IO {# type gboolean #}
marshalIteratorFoldFunction :: Iterable itemT
                            => IteratorFoldFunction itemT accumT
                            -> IORef accumT
                            -> IO {# type GstIteratorFoldFunction #}
marshalIteratorFoldFunction iteratorFoldFunction accumRef =
    makeIteratorFoldFunction cIteratorFoldFunction
    where cIteratorFoldFunction :: CIteratorFoldFunction
          cIteratorFoldFunction itemPtr _ _ =
              do item <- peekIterable itemPtr
                 accum <- readIORef accumRef
                 (continue, accum') <- iteratorFoldFunction item accum
                 writeIORef accumRef accum'
                 return $ fromBool continue
foreign import ccall "wrapper"
    makeIteratorFoldFunction :: CIteratorFoldFunction
                             -> IO {# type GstIteratorFoldFunction #}

iteratorFold :: Iterable itemT
             => Iterator itemT
             -> accumT
             -> IteratorFoldFunction itemT accumT
             -> IO (IteratorResult, accumT)
iteratorFold (Iterator iterator) init func =
    do accumRef <- newIORef init
       func' <- marshalIteratorFoldFunction func accumRef
       result <- {# call iterator_fold #} iterator
                                          func'
                                          (GValue nullPtr)
                                          nullPtr
       freeHaskellFunPtr func'
       accum <- readIORef accumRef
       return (toEnum $ fromIntegral result, accum)

iteratorForeach :: Iterable itemT
                => Iterator itemT
                -> (itemT -> IO ())
                -> IO IteratorResult
iteratorForeach iterator func =
    do (result, _) <- iteratorFold iterator () $ \item _ ->
                          func item >> return (True, ())
       return result

iteratorFind :: Iterable itemT
             => Iterator itemT
             -> (itemT -> IO Bool)
             -> IO (IteratorResult, Maybe itemT)
iteratorFind iterator pred =
    iteratorFold iterator Nothing $ \item accum ->
        do found <- pred item
           if found
               then return (False, Just item)
               else return (True, accum)


Fix getKeyList exception on empty list

Fix getKeyList exception on empty list

{- |
Core Foundation provides a simple, standard way to manage user (and application) preferences. Core Foundation stores preferences as key-value pairs that are assigned a scope using a combination of user name, application ID, and host (computer) names. This makes it possible to save and retrieve preferences that apply to different classes of users. Core Foundation preferences is useful to all applications that support user preferences. Note that modification of some preferences domains (those not belonging to the \"Current User\") requires root privileges (or Admin privileges prior to Mac OS X v10.6)-see Authorization Services Programming Guide (<https://developer.apple.com/library/mac/#documentation/Security/Conceptual/authorization_concepts/01introduction/introduction.html>)
for information on how to gain suitable privileges.
-}
module CoreFoundation.Preferences(
  -- * Types
  Key,
  SuiteID,
  AppID,
  anyApp,
  currentApp,
  HostID,
  anyHost,
  currentHost,
  UserID,
  anyUser,
  currentUser,
  -- * Getting
  getAppValue,
  getKeyList,
  getMultiple,
  getValue,
  -- * Setting
  setAppValue,
  setMultiple,
  setValue,
  -- * Synchronizing
  SyncFailed(..),
  appSync,
  sync,
  -- * Suite preferences
  addSuiteToApp,
  removeSuiteFromApp,
  -- * Misc
  appValueIsForced,
  getAppList,
  ) where

import Prelude hiding(String)

import CoreFoundation.Base
import CoreFoundation.String
import CoreFoundation.Array
import CoreFoundation.Dictionary
import CoreFoundation.PropertyList
#include <CoreFoundation/CFPreferences.h>
#include "cbits.h"

import Control.Applicative
import Control.Monad
import Control.Exception
import Data.Typeable
import qualified Data.Vector as V
import Data.Maybe(fromMaybe)
import Foreign
import Foreign.C.Types

{#pointer CFStringRef -> CFString#}
{#pointer CFArrayRef -> CFArray#}
{#pointer CFDictionaryRef -> CFDictionary#}
{#pointer CFPropertyListRef -> CFPropertyList#}

-- | Keys. These can be constructed using the OverloadedStrings
-- language extension.
type Key = String

-- | ID of a suite, for example @com.apple.iApps@.
type SuiteID = String

-- | Application ID. Takes the form of a java package name, @com.foosoft@, or one of the constants 'anyApp', 'currentApp'.
type AppID = String

-- | Matches any application. This may be passed to functions which \"search\", such as 'getAppValue', 'getValue', 'getKeyList', etc. However, this may not be passed to functions which put a value in a specific location, such as 'setAppValue', 'syncApp'.
anyApp :: AppID
anyApp = constant {#call pure unsafe hsAnyApp#}

-- | Specifies the current application
currentApp :: AppID
currentApp = constant {#call pure unsafe hsCurrentApp#}

-- | Host ID. User-provided, or see the constants 'anyHost', 'currentHost'
type HostID = String

-- | When passed to functions which \"search\", such as 'getValue', 'getKeyList', etc, this allows the search to match any host. When passed to \"setting\" functions such as 'setValue', 'sync', it sets the value for all hosts.
anyHost :: HostID
anyHost = constant {#call pure unsafe hsAnyHost#}

-- | Current host
currentHost :: HostID
currentHost = constant {#call pure unsafe hsCurrentHost#}

-- | User ID. User-provided, or see the constants 'anyUser',
              -- 'currentUser'
type UserID = String

-- | When passed to functions which \"search\", such as 'getValue', 'getKeyList', etc, this allows the search to match any user. When passed to \"setting\" functions such as 'setValue', 'sync', it sets the value for all users.
anyUser :: UserID
anyUser = constant {#call pure unsafe hsAnyUser#}

-- | Current user
currentUser :: UserID
currentUser = constant {#call pure unsafe hsCurrentUser#}

------------------------- Getting ----------------------------
{- |
Obtains a preference value for the specified key and application. Wraps CFPreferencesCopyAppValue.
-}
getAppValue :: Key -> AppID -> IO (Maybe Plist)
getAppValue = call2 createNullable {#call unsafe CFPreferencesCopyAppValue as ^#}

{- |
Constructs and returns the list of all keys set in the specified domain. Wraps CFPreferencesCopyKeyList
-}
getKeyList :: AppID -> UserID -> HostID -> IO (Array Key)
getKeyList =
  call3
    (fmap (fromMaybe (fromHs V.empty)) . createNullable)
    {#call unsafe CFPreferencesCopyKeyList as ^ #}

{- |
Returns a dictionary containing preference values for multiple keys. If no values were located, returns an empty dictionary.
-}
getMultiple :: Array Key -> AppID -> UserID -> HostID -> IO (Dictionary Key Plist)
getMultiple = call4 create {#call unsafe CFPreferencesCopyMultiple as ^ #}

{- |
Returns a preference value for a given domain.

This function is the primitive get mechanism for the higher level preference function 'getAppValue'. Unlike the high-level function, 'getValue' searches only the exact domain specified. Do not use this function directly unless you have a need. Do not use arbitrary user and host names, instead pass the pre-defined domain qualifier constants (i.e. 'currentUser', 'anyUser', 'currentHost', 'anyHost').
-}
getValue :: Key -> AppID -> UserID -> HostID -> IO (Maybe Plist)
getValue = call4 createNullable {#call unsafe CFPreferencesCopyValue as ^ #}

-------------------------- Setting ---------------------------
{- |
Adds, modifies, or removes a preference.

New preference values are stored in the standard application preference location, <~/Library/Preferences/>. When called with 'currentApp', modifications are performed in the preference domain \"Current User, Current Application, Any Host.\" If you need to create preferences in some other domain, use the low-level function 'setValue'.

You must call the 'appSync' function in order for your changes to be saved to permanent storage.

Wraps @CFPreferencesSetAppValue@.
-}
setAppValue :: Key -> Maybe Plist -> AppID -> IO ()
setAppValue key val app =
  withObject key $ \k ->
  withMaybe val $ \v ->
  withObject app $ \a ->
  {#call unsafe CFPreferencesSetAppValue as ^ #} k v a

{- |
Convenience function that allows you to set and remove multiple preference values.

Behavior is undefined if a key is in both keysToSet and keysToRemove.

Wraps @CFPreferencesSetMultiple@.
-}
setMultiple ::
    Dictionary Key Plist -- ^ values to set
 -> Array Key -- ^ keys to remove
 -> AppID
 -> UserID
 -> HostID
 -> IO ()
setMultiple = call5 idScheme {#call unsafe CFPreferencesSetMultiple as ^ #}

{- |
Adds, modifies, or removes a preference value for the specified domain.

This function is the primitive set mechanism for the higher level preference function 'setAppValue'. Only the exact domain specified is modified. Do not use this function directly unless you have a specific need. Do not use arbitrary user and host names, instead pass the pre-defined constants.

You must call the 'sync' function in order for your changes to be saved to permanent storage. Note that you can only save preferences for \"Any User\" if you have root privileges (or Admin privileges prior to Mac OS X v10.6).
-}
setValue :: Key -> Maybe Plist -> AppID -> UserID -> HostID -> IO ()
setValue key val app user host =
  withObject key $ \k ->
  withMaybe val $ \v ->
  withObject app $ \a ->
  withObject user $ \u ->
  withObject host $ \h ->
  {#call unsafe CFPreferencesSetValue as ^ #} k v a u h

------------------------- Synchronizing ---------------
-- | Exception thrown when 'appSync' or 'sync' fail.
data SyncFailed = SyncFailed
  deriving(Typeable)
instance Show SyncFailed where
  show _ = "Syncing Apple preferences failed"
instance Exception SyncFailed

{- |
Writes to permanent storage all pending changes to the preference data for the application, and reads the latest preference data from permanent storage.

Calling the function 'setAppValue' is not in itself sufficient for storing preferences. The 'appSync' function writes to permanent storage all pending preference changes for the application. Typically you would call this function after multiple calls to 'setAppValue'. Conversely, preference data is cached after it is first read. Changes made externally are not automatically incorporated. The 'appSync' function reads the latest preferences from permanent storage.

Throws 'SyncFailed' if synchronization failed.
-}
appSync :: AppID -> IO ()
appSync = call1 (checkError SyncFailed) {#call unsafe CFPreferencesAppSynchronize as ^ #}

{- |
For the specified domain, writes all pending changes to preference data to permanent storage, and reads latest preference data from permanent storage.

This function is the primitive synchronize mechanism for the higher level preference function 'appSync'; it writes updated preferences to permanent storage, and reads the latest preferences from permanent storage. Only the exact domain specified is modified. Note that to modify \"Any User\" preferences requires root privileges (or Admin privileges prior to Mac OS X v10.6) - see <https://developer.apple.com/library/mac/#documentation/Security/Conceptual/authorization_concepts/01introduction/introduction.html>
-}
sync :: AppID -> UserID -> HostID -> IO ()
sync = call3 (checkError SyncFailed) {#call unsafe CFPreferencesSynchronize as ^ #}

---------------------- Suite preferences -----------
{- |
Adds suite preferences to an application’s preference search chain.

Suite preferences allow you to maintain a set of preferences that are common to all applications in the suite. When a suite is added to an application’s search chain, all of the domains pertaining to that suite are inserted into the chain. Suite preferences are added between the \"Current Application\" domains and the \"Any Application\" domains. If you add multiple suite preferences to one application, the order of the suites in the search chain is non-deterministic. You can override a suite preference for a given application by defining the same preference key in the application specific preferences.

Wraps @CFPreferencesAddSuitePreferencesToApp@.
-}
addSuiteToApp :: AppID -> SuiteID -> IO ()
addSuiteToApp = call2 idScheme {#call unsafe CFPreferencesAddSuitePreferencesToApp as ^ #}

{- |
Removes suite preferences from an application’s search chain.
-}
removeSuiteFromApp :: AppID -> SuiteID -> IO ()
removeSuiteFromApp = call2 idScheme {#call unsafe CFPreferencesRemoveSuitePreferencesFromApp as ^ #}

----------------------- Misc ------------------
{- |
Determines whether or not a given key has been imposed on the user.

In cases where machines and/or users are under some kind of management, you should use this function to determine whether or not to disable UI elements corresponding to those preference keys.
-}
appValueIsForced :: Key -> AppID -> IO Bool
appValueIsForced = call2 (Foreign.toBool <$>) {#call unsafe CFPreferencesAppValueIsForced as ^ #}

{- |
Constructs and returns the list of all applications that have preferences in the scope of the specified user and host.
-}
getAppList :: UserID -> HostID -> IO (Array AppID)
getAppList = call2 create {#call unsafe CFPreferencesCopyApplicationList as ^ #}

-- marshalling utils
checkError exception gen = do
  res <- gen
  when (res == 0) $ throw exception

withMaybe Nothing f = f nullPtr
withMaybe (Just o) f = withObject o f

call1 scheme f = \arg1 ->
  withObject arg1 $ \parg1 ->
  scheme $
  f parg1

call2 scheme f = \arg1 arg2 ->
  withObject arg1 $ \parg1 ->
  withObject arg2 $ \parg2 ->
  scheme $
  f parg1 parg2

call3 scheme f = \arg1 arg2 arg3 ->
  withObject arg1 $ \parg1 ->
  withObject arg2 $ \parg2 ->
  withObject arg3 $ \parg3 ->
  scheme $
  f parg1 parg2 parg3

call4 scheme f = \arg1 arg2 arg3 arg4 ->
  withObject arg1 $ \parg1 ->
  withObject arg2 $ \parg2 ->
  withObject arg3 $ \parg3 ->
  withObject arg4 $ \parg4 ->
  scheme $
  f parg1 parg2 parg3 parg4

call5 scheme f = \arg1 arg2 arg3 arg4 arg5 ->
  withObject arg1 $ \parg1 ->
  withObject arg2 $ \parg2 ->
  withObject arg3 $ \parg3 ->
  withObject arg4 $ \parg4 ->
  withObject arg5 $ \parg5 ->
  scheme $
  f parg1 parg2 parg3 parg4 parg5

{- |
Core Foundation provides a simple, standard way to manage user (and application) preferences. Core Foundation stores preferences as key-value pairs that are assigned a scope using a combination of user name, application ID, and host (computer) names. This makes it possible to save and retrieve preferences that apply to different classes of users. Core Foundation preferences is useful to all applications that support user preferences. Note that modification of some preferences domains (those not belonging to the \"Current User\") requires root privileges (or Admin privileges prior to Mac OS X v10.6)-see Authorization Services Programming Guide (<https://developer.apple.com/library/mac/#documentation/Security/Conceptual/authorization_concepts/01introduction/introduction.html>)
for information on how to gain suitable privileges.
-}
module CoreFoundation.Preferences(
  -- * Types
  Key,
  SuiteID,
  AppID,
  anyApp,
  currentApp,
  HostID,
  anyHost,
  currentHost,
  UserID,
  anyUser,
  currentUser,
  -- * Getting
  getAppValue,
  getKeyList,
  getMultiple,
  getValue,
  -- * Setting
  setAppValue,
  setMultiple,
  setValue,
  -- * Synchronizing
  SyncFailed(..),
  appSync,
  sync,
  -- * Suite preferences
  addSuiteToApp,
  removeSuiteFromApp,
  -- * Misc
  appValueIsForced,
  getAppList,
  ) where

import Prelude hiding(String)

import CoreFoundation.Base
import CoreFoundation.String
import CoreFoundation.Array
import CoreFoundation.Dictionary
import CoreFoundation.PropertyList
#include <CoreFoundation/CFPreferences.h>
#include "cbits.h"

import Control.Applicative
import Control.Monad
import Control.Exception
import Data.Typeable
import Foreign
import Foreign.C.Types

{#pointer CFStringRef -> CFString#}
{#pointer CFArrayRef -> CFArray#}
{#pointer CFDictionaryRef -> CFDictionary#}
{#pointer CFPropertyListRef -> CFPropertyList#}

-- | Keys. These can be constructed using the OverloadedStrings
-- language extension.
type Key = String

-- | ID of a suite, for example @com.apple.iApps@.
type SuiteID = String

-- | Application ID. Takes the form of a java package name, @com.foosoft@, or one of the constants 'anyApp', 'currentApp'.
type AppID = String

-- | Matches any application. This may be passed to functions which \"search\", such as 'getAppValue', 'getValue', 'getKeyList', etc. However, this may not be passed to functions which put a value in a specific location, such as 'setAppValue', 'syncApp'.
anyApp :: AppID
anyApp = constant {#call pure unsafe hsAnyApp#}

-- | Specifies the current application
currentApp :: AppID
currentApp = constant {#call pure unsafe hsCurrentApp#}

-- | Host ID. User-provided, or see the constants 'anyHost', 'currentHost'
type HostID = String

-- | When passed to functions which \"search\", such as 'getValue', 'getKeyList', etc, this allows the search to match any host. When passed to \"setting\" functions such as 'setValue', 'sync', it sets the value for all hosts.
anyHost :: HostID
anyHost = constant {#call pure unsafe hsAnyHost#}

-- | Current host
currentHost :: HostID
currentHost = constant {#call pure unsafe hsCurrentHost#}

-- | User ID. User-provided, or see the constants 'anyUser',
              -- 'currentUser'
type UserID = String

-- | When passed to functions which \"search\", such as 'getValue', 'getKeyList', etc, this allows the search to match any user. When passed to \"setting\" functions such as 'setValue', 'sync', it sets the value for all users.
anyUser :: UserID
anyUser = constant {#call pure unsafe hsAnyUser#}

-- | Current user
currentUser :: UserID
currentUser = constant {#call pure unsafe hsCurrentUser#}

------------------------- Getting ----------------------------
{- |
Obtains a preference value for the specified key and application. Wraps CFPreferencesCopyAppValue.
-}
getAppValue :: Key -> AppID -> IO (Maybe Plist)
getAppValue = call2 createNullable {#call unsafe CFPreferencesCopyAppValue as ^#}

{- |
Constructs and returns the list of all keys set in the specified domain. Wraps CFPreferencesCopyKeyList
-}
getKeyList :: AppID -> UserID -> HostID -> IO (Array Key)
getKeyList = call3 create {#call unsafe CFPreferencesCopyKeyList as ^ #}

{- |
Returns a dictionary containing preference values for multiple keys. If no values were located, returns an empty dictionary.
-}
getMultiple :: Array Key -> AppID -> UserID -> HostID -> IO (Dictionary Key Plist)
getMultiple = call4 create {#call unsafe CFPreferencesCopyMultiple as ^ #}

{- |
Returns a preference value for a given domain.

This function is the primitive get mechanism for the higher level preference function 'getAppValue'. Unlike the high-level function, 'getValue' searches only the exact domain specified. Do not use this function directly unless you have a need. Do not use arbitrary user and host names, instead pass the pre-defined domain qualifier constants (i.e. 'currentUser', 'anyUser', 'currentHost', 'anyHost').
-}
getValue :: Key -> AppID -> UserID -> HostID -> IO (Maybe Plist)
getValue = call4 createNullable {#call unsafe CFPreferencesCopyValue as ^ #}

-------------------------- Setting ---------------------------
{- |
Adds, modifies, or removes a preference.

New preference values are stored in the standard application preference location, <~/Library/Preferences/>. When called with 'currentApp', modifications are performed in the preference domain \"Current User, Current Application, Any Host.\" If you need to create preferences in some other domain, use the low-level function 'setValue'.

You must call the 'appSync' function in order for your changes to be saved to permanent storage.

Wraps @CFPreferencesSetAppValue@.
-}
setAppValue :: Key -> Maybe Plist -> AppID -> IO ()
setAppValue key val app =
  withObject key $ \k ->
  withMaybe val $ \v ->
  withObject app $ \a ->
  {#call unsafe CFPreferencesSetAppValue as ^ #} k v a

{- |
Convenience function that allows you to set and remove multiple preference values.

Behavior is undefined if a key is in both keysToSet and keysToRemove.

Wraps @CFPreferencesSetMultiple@.
-}
setMultiple ::
    Dictionary Key Plist -- ^ values to set
 -> Array Key -- ^ keys to remove
 -> AppID
 -> UserID
 -> HostID
 -> IO ()
setMultiple = call5 idScheme {#call unsafe CFPreferencesSetMultiple as ^ #}

{- |
Adds, modifies, or removes a preference value for the specified domain.

This function is the primitive set mechanism for the higher level preference function 'setAppValue'. Only the exact domain specified is modified. Do not use this function directly unless you have a specific need. Do not use arbitrary user and host names, instead pass the pre-defined constants.

You must call the 'sync' function in order for your changes to be saved to permanent storage. Note that you can only save preferences for \"Any User\" if you have root privileges (or Admin privileges prior to Mac OS X v10.6).
-}
setValue :: Key -> Maybe Plist -> AppID -> UserID -> HostID -> IO ()
setValue key val app user host =
  withObject key $ \k ->
  withMaybe val $ \v ->
  withObject app $ \a ->
  withObject user $ \u ->
  withObject host $ \h ->
  {#call unsafe CFPreferencesSetValue as ^ #} k v a u h

------------------------- Synchronizing ---------------
-- | Exception thrown when 'appSync' or 'sync' fail.
data SyncFailed = SyncFailed
  deriving(Typeable)
instance Show SyncFailed where
  show _ = "Syncing Apple preferences failed"
instance Exception SyncFailed

{- |
Writes to permanent storage all pending changes to the preference data for the application, and reads the latest preference data from permanent storage.

Calling the function 'setAppValue' is not in itself sufficient for storing preferences. The 'appSync' function writes to permanent storage all pending preference changes for the application. Typically you would call this function after multiple calls to 'setAppValue'. Conversely, preference data is cached after it is first read. Changes made externally are not automatically incorporated. The 'appSync' function reads the latest preferences from permanent storage.

Throws 'SyncFailed' if synchronization failed.
-}
appSync :: AppID -> IO ()
appSync = call1 (checkError SyncFailed) {#call unsafe CFPreferencesAppSynchronize as ^ #}

{- |
For the specified domain, writes all pending changes to preference data to permanent storage, and reads latest preference data from permanent storage.

This function is the primitive synchronize mechanism for the higher level preference function 'appSync'; it writes updated preferences to permanent storage, and reads the latest preferences from permanent storage. Only the exact domain specified is modified. Note that to modify \"Any User\" preferences requires root privileges (or Admin privileges prior to Mac OS X v10.6) - see <https://developer.apple.com/library/mac/#documentation/Security/Conceptual/authorization_concepts/01introduction/introduction.html>
-}
sync :: AppID -> UserID -> HostID -> IO ()
sync = call3 (checkError SyncFailed) {#call unsafe CFPreferencesSynchronize as ^ #}

---------------------- Suite preferences -----------
{- |
Adds suite preferences to an application’s preference search chain.

Suite preferences allow you to maintain a set of preferences that are common to all applications in the suite. When a suite is added to an application’s search chain, all of the domains pertaining to that suite are inserted into the chain. Suite preferences are added between the \"Current Application\" domains and the \"Any Application\" domains. If you add multiple suite preferences to one application, the order of the suites in the search chain is non-deterministic. You can override a suite preference for a given application by defining the same preference key in the application specific preferences.

Wraps @CFPreferencesAddSuitePreferencesToApp@.
-}
addSuiteToApp :: AppID -> SuiteID -> IO ()
addSuiteToApp = call2 idScheme {#call unsafe CFPreferencesAddSuitePreferencesToApp as ^ #}

{- |
Removes suite preferences from an application’s search chain.
-}
removeSuiteFromApp :: AppID -> SuiteID -> IO ()
removeSuiteFromApp = call2 idScheme {#call unsafe CFPreferencesRemoveSuitePreferencesFromApp as ^ #}

----------------------- Misc ------------------
{- |
Determines whether or not a given key has been imposed on the user.

In cases where machines and/or users are under some kind of management, you should use this function to determine whether or not to disable UI elements corresponding to those preference keys.
-}
appValueIsForced :: Key -> AppID -> IO Bool
appValueIsForced = call2 (Foreign.toBool <$>) {#call unsafe CFPreferencesAppValueIsForced as ^ #}

{- |
Constructs and returns the list of all applications that have preferences in the scope of the specified user and host.
-}
getAppList :: UserID -> HostID -> IO (Array AppID)
getAppList = call2 create {#call unsafe CFPreferencesCopyApplicationList as ^ #}

-- marshalling utils
checkError exception gen = do
  res <- gen
  when (res == 0) $ throw exception

withMaybe Nothing f = f nullPtr
withMaybe (Just o) f = withObject o f

call1 scheme f = \arg1 ->
  withObject arg1 $ \parg1 ->
  scheme $
  f parg1

call2 scheme f = \arg1 arg2 ->
  withObject arg1 $ \parg1 ->
  withObject arg2 $ \parg2 ->
  scheme $
  f parg1 parg2

call3 scheme f = \arg1 arg2 arg3 ->
  withObject arg1 $ \parg1 ->
  withObject arg2 $ \parg2 ->
  withObject arg3 $ \parg3 ->
  scheme $
  f parg1 parg2 parg3

call4 scheme f = \arg1 arg2 arg3 arg4 ->
  withObject arg1 $ \parg1 ->
  withObject arg2 $ \parg2 ->
  withObject arg3 $ \parg3 ->
  withObject arg4 $ \parg4 ->
  scheme $
  f parg1 parg2 parg3 parg4

call5 scheme f = \arg1 arg2 arg3 arg4 arg5 ->
  withObject arg1 $ \parg1 ->
  withObject arg2 $ \parg2 ->
  withObject arg3 $ \parg3 ->
  withObject arg4 $ \parg4 ->
  withObject arg5 $ \parg5 ->
  scheme $
  f parg1 parg2 parg3 parg4 parg5