storable instance for textures

storable instance for textures

Ignore-this: 6aa1cda922eb9832c02b8b49b249869a

darcs-hash:20100610012250-dcabc-306b1b6d962d0094c75bfde601c05bf4e0a99a7b.gz

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Texture
-- Copyright : (c) [2009..2010] Trevor L. McDonell
-- License   : BSD
--
-- Texture management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Texture
  (
    Texture(..), AddressMode(..), FilterMode(..), Format(..),
    create, destroy,
    getPtr, getAddressMode, getFilterMode, getFormat,
    setPtr, setAddressMode, setFilterMode, setFormat
  )
  where

#include <cuda.h>
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Ptr
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Marshal
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Control.Monad

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |A texture reference
--
newtype Texture = Texture { useTexture :: {# type CUtexref #}}

instance Storable Texture where
  sizeOf _    = sizeOf    (undefined :: {# type CUtexref #})
  alignment _ = alignment (undefined :: {# type CUtexref #})
  peek p      = Texture `fmap` peek (castPtr p)
  poke p t    = poke (castPtr p) (useTexture t)

-- |Texture reference addressing modes
--
{# enum CUaddress_mode as AddressMode
  { underscoreToCase }
  with prefix="CU_TR_ADDRESS_MODE" deriving (Eq, Show) #}

-- |Texture reference filtering mode
--
{# enum CUfilter_mode as FilterMode
  { underscoreToCase }
  with prefix="CU_TR_FILTER_MODE" deriving (Eq, Show) #}

-- |Texture data formats
--
{# enum CUarray_format as Format
  { underscoreToCase
  , UNSIGNED_INT8  as Word8
  , UNSIGNED_INT16 as Word16
  , UNSIGNED_INT32 as Word32
  , SIGNED_INT8    as Int8
  , SIGNED_INT16   as Int16
  , SIGNED_INT32   as Int32 }
  with prefix="CU_AD_FORMAT" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Texture management
--------------------------------------------------------------------------------

-- |Create a new texture reference. Once created, the application must call
-- 'setPtr' to associate the reference with allocated memory. Other texture
-- reference functions are used to specify the format and interpretation to be
-- used when the memory is read through this reference.
--
create :: IO Texture
create = resultIfOk =<< cuTexRefCreate

{# fun unsafe cuTexRefCreate
  { alloca- `Texture' peekTex* } -> `Status' cToEnum #}

-- |Destroy a texture reference
--
destroy :: Texture -> IO ()
destroy tex = nothingIfOk =<< cuTexRefDestroy tex

{# fun unsafe cuTexRefDestroy
  { useTexture `Texture' } -> `Status' cToEnum #}

-- |Get the address associated with a texture reference
--
getPtr :: Texture -> IO (DevicePtr a)
getPtr tex = resultIfOk =<< cuTexRefGetAddress tex

{# fun unsafe cuTexRefGetAddress
  { alloca-    `DevicePtr a' peekDevPtr*
  , useTexture `Texture'                 } -> `Status' cToEnum #}

-- |Get the addressing mode used by a texture reference, corresponding to the
-- given dimension (currently the only supported dimension values are 0 or 1).
--
getAddressMode :: Texture -> Int -> IO AddressMode
getAddressMode tex dim = resultIfOk =<< cuTexRefGetAddressMode tex dim

{# fun unsafe cuTexRefGetAddressMode
  { alloca-    `AddressMode' peekEnum*
  , useTexture `Texture'
  ,            `Int'                  } -> `Status' cToEnum #}

-- |Get the filtering mode used by a texture reference
--
getFilterMode :: Texture -> IO FilterMode
getFilterMode tex = resultIfOk =<< cuTexRefGetFilterMode tex

{# fun unsafe cuTexRefGetFilterMode
  { alloca-    `FilterMode' peekEnum*
  , useTexture `Texture'              } -> `Status' cToEnum #}

-- |Get the data format and number of channel components of the bound texture
--
getFormat :: Texture -> IO (Format, Int)
getFormat tex = do
  (status,fmt,dim) <- cuTexRefGetFormat tex
  resultIfOk (status,(fmt,dim))

{# fun unsafe cuTexRefGetFormat
  { alloca-    `Format'  peekEnum*
  , alloca-    `Int'     peekIntConv*
  , useTexture `Texture'              } -> `Status' cToEnum #}

-- |Bind a linear array address of the given size (bytes) as a texture
-- reference. Any previously bound references are unbound.
--
setPtr :: Texture -> DevicePtr a -> Int -> IO ()
setPtr tex dptr bytes = nothingIfOk =<< cuTexRefSetAddress tex dptr bytes

{# fun unsafe cuTexRefSetAddress
  { alloca-         `Int'
  , useTexture      `Texture'
  , useDeviceHandle `DevicePtr a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |Specify the addressing mode for the given dimension of a texture reference
--
setAddressMode :: Texture -> Int -> AddressMode -> IO ()
setAddressMode tex dim mode = nothingIfOk =<< cuTexRefSetAddressMode tex dim mode

{# fun unsafe cuTexRefSetAddressMode
  { useTexture `Texture'
  ,            `Int'
  , cFromEnum  `AddressMode' } -> `Status' cToEnum #}

-- |Specify the filtering mode to be used when reading memory through a texture
-- reference
--
setFilterMode :: Texture -> FilterMode -> IO ()
setFilterMode tex mode = nothingIfOk =<< cuTexRefSetFilterMode tex mode

{# fun unsafe cuTexRefSetFilterMode
  { useTexture `Texture'
  , cFromEnum  `FilterMode' } -> `Status' cToEnum #}

-- |Specify the format of the data to be read by the texture reference
--
setFormat :: Texture -> Format -> Int -> IO ()
setFormat tex fmt dim = nothingIfOk =<< cuTexRefSetFormat tex fmt dim

{# fun unsafe cuTexRefSetFormat
  { useTexture `Texture'
  , cFromEnum  `Format'
  ,            `Int'     } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Internal
--------------------------------------------------------------------------------

peekTex :: Ptr {# type CUtexref #} -> IO Texture
peekTex = liftM Texture . peek

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Texture
-- Copyright : (c) [2009..2010] Trevor L. McDonell
-- License   : BSD
--
-- Texture management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Texture
  (
    Texture(..), AddressMode(..), FilterMode(..), Format(..),
    create, destroy,
    getPtr, getAddressMode, getFilterMode, getFormat,
    setPtr, setAddressMode, setFilterMode, setFormat
  )
  where

#include <cuda.h>
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Ptr
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Marshal
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Control.Monad

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |A texture reference
--
newtype Texture = Texture { useTexture :: {# type CUtexref #}}

-- |Texture reference addressing modes
--
{# enum CUaddress_mode as AddressMode
  { underscoreToCase }
  with prefix="CU_TR_ADDRESS_MODE" deriving (Eq, Show) #}

-- |Texture reference filtering mode
--
{# enum CUfilter_mode as FilterMode
  { underscoreToCase }
  with prefix="CU_TR_FILTER_MODE" deriving (Eq, Show) #}

-- |Texture data formats
--
{# enum CUarray_format as Format
  { underscoreToCase
  , UNSIGNED_INT8  as Word8
  , UNSIGNED_INT16 as Word16
  , UNSIGNED_INT32 as Word32
  , SIGNED_INT8    as Int8
  , SIGNED_INT16   as Int16
  , SIGNED_INT32   as Int32 }
  with prefix="CU_AD_FORMAT" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Texture management
--------------------------------------------------------------------------------

-- |Create a new texture reference. Once created, the application must call
-- 'setPtr' to associate the reference with allocated memory. Other texture
-- reference functions are used to specify the format and interpretation to be
-- used when the memory is read through this reference.
--
create :: IO Texture
create = resultIfOk =<< cuTexRefCreate

{# fun unsafe cuTexRefCreate
  { alloca- `Texture' peekTex* } -> `Status' cToEnum #}

-- |Destroy a texture reference
--
destroy :: Texture -> IO ()
destroy tex = nothingIfOk =<< cuTexRefDestroy tex

{# fun unsafe cuTexRefDestroy
  { useTexture `Texture' } -> `Status' cToEnum #}

-- |Get the address associated with a texture reference
--
getPtr :: Texture -> IO (DevicePtr a)
getPtr tex = resultIfOk =<< cuTexRefGetAddress tex

{# fun unsafe cuTexRefGetAddress
  { alloca-    `DevicePtr a' peekDevPtr*
  , useTexture `Texture'                 } -> `Status' cToEnum #}

-- |Get the addressing mode used by a texture reference, corresponding to the
-- given dimension (currently the only supported dimension values are 0 or 1).
--
getAddressMode :: Texture -> Int -> IO AddressMode
getAddressMode tex dim = resultIfOk =<< cuTexRefGetAddressMode tex dim

{# fun unsafe cuTexRefGetAddressMode
  { alloca-    `AddressMode' peekEnum*
  , useTexture `Texture'
  ,            `Int'                  } -> `Status' cToEnum #}

-- |Get the filtering mode used by a texture reference
--
getFilterMode :: Texture -> IO FilterMode
getFilterMode tex = resultIfOk =<< cuTexRefGetFilterMode tex

{# fun unsafe cuTexRefGetFilterMode
  { alloca-    `FilterMode' peekEnum*
  , useTexture `Texture'              } -> `Status' cToEnum #}

-- |Get the data format and number of channel components of the bound texture
--
getFormat :: Texture -> IO (Format, Int)
getFormat tex = do
  (status,fmt,dim) <- cuTexRefGetFormat tex
  resultIfOk (status,(fmt,dim))

{# fun unsafe cuTexRefGetFormat
  { alloca-    `Format'  peekEnum*
  , alloca-    `Int'     peekIntConv*
  , useTexture `Texture'              } -> `Status' cToEnum #}

-- |Bind a linear array address of the given size (bytes) as a texture
-- reference. Any previously bound references are unbound.
--
setPtr :: Texture -> DevicePtr a -> Int -> IO ()
setPtr tex dptr bytes = nothingIfOk =<< cuTexRefSetAddress tex dptr bytes

{# fun unsafe cuTexRefSetAddress
  { alloca-         `Int'
  , useTexture      `Texture'
  , useDeviceHandle `DevicePtr a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |Specify the addressing mode for the given dimension of a texture reference
--
setAddressMode :: Texture -> Int -> AddressMode -> IO ()
setAddressMode tex dim mode = nothingIfOk =<< cuTexRefSetAddressMode tex dim mode

{# fun unsafe cuTexRefSetAddressMode
  { useTexture `Texture'
  ,            `Int'
  , cFromEnum  `AddressMode' } -> `Status' cToEnum #}

-- |Specify the filtering mode to be used when reading memory through a texture
-- reference
--
setFilterMode :: Texture -> FilterMode -> IO ()
setFilterMode tex mode = nothingIfOk =<< cuTexRefSetFilterMode tex mode

{# fun unsafe cuTexRefSetFilterMode
  { useTexture `Texture'
  , cFromEnum  `FilterMode' } -> `Status' cToEnum #}

-- |Specify the format of the data to be read by the texture reference
--
setFormat :: Texture -> Format -> Int -> IO ()
setFormat tex fmt dim = nothingIfOk =<< cuTexRefSetFormat tex fmt dim

{# fun unsafe cuTexRefSetFormat
  { useTexture `Texture'
  , cFromEnum  `Format'
  ,            `Int'     } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Internal
--------------------------------------------------------------------------------

peekTex :: Ptr {# type CUtexref #} -> IO Texture
peekTex = liftM Texture . peek


Some more index stuff

Some more index stuff

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}

#include "git2.h"

module Git2 where

import Data.Bits
import Data.Maybe
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO.Unsafe

type OffT    = {#type git_off_t#}
type TimeT   = {#type git_time_t#}
type CPtr    = Ptr ()
type Ptr2Int = CPtr -> IO CInt

newtype ObjDB      = ObjDB CPtr
newtype Repository = Repository CPtr
newtype Index      = Index CPtr
newtype Blob       = Blob CPtr
newtype ObjID      = ObjID CPtr
newtype Commit     = Commit CPtr
newtype Signature  = Signature CPtr
newtype Tree       = Tree CPtr
newtype Config     = Config CPtr

defaultPort :: String
defaultPort = "9418" -- TODO: Import from net.h?

{#enum define Direction { GIT_DIR_FETCH as Fetch
                        , GIT_DIR_PUSH as Push}#}

{-
#define GIT_STATUS_CURRENT        0
/** Flags for index status */
#define GIT_STATUS_INDEX_NEW      (1 << 0)
#define GIT_STATUS_INDEX_MODIFIED (1 << 1)
#define GIT_STATUS_INDEX_DELETED  (1 << 2)

/** Flags for worktree status */
#define GIT_STATUS_WT_NEW         (1 << 3)
#define GIT_STATUS_WT_MODIFIED    (1 << 4)
#define GIT_STATUS_WT_DELETED     (1 << 5)

// TODO Ignored files not handled yet
#define GIT_STATUS_IGNORED        (1 << 6)
-}

{-
{#enum define Status { GIT_STATUS_CURRENT as Current
                     , GIT_STATUS_INDEX_NEW as NewIndex
                     , GIT_STATUS_INDEX_MODIFIED as ModifiedIndex
                     , GIT_STATUS_INDEX_DELETED as DeletedIndex
                     , GIT_STATUS_WT_NEW as NewWorkTree
                     , GIT_STATUS_WT_MODIFIED as ModifiedWorkTree
                     , GIT_STATUS_WT_DELETED as DeletedWorkTree
                     , GIT_STATUS_IGNORED as Ignored}#}
-}

{#enum git_otype as OType {underscoreToCase}#}
{#enum git_rtype as RType {underscoreToCase}#}
{#enum git_repository_pathid as RepositoryPathID {underscoreToCase}#}
{#enum git_error as GitError {underscoreToCase}#}
{#enum git_odb_streammode as ODBStreamMode {underscoreToCase}#}

deriving instance Show GitError

retEither :: CInt -> IO (Either GitError a) -> IO (Either GitError a)
retEither res f | res == 0  = f
                | otherwise = return . Left . toEnum . fromIntegral $ res

retMaybeRes :: CInt -> IO (Maybe GitError)
retMaybeRes res | res == 0  = return Nothing
                | otherwise = return $ Just . toEnum . fromIntegral $ res

-------------------------------------------------------------------------------
-- BEGIN: blob.h
-------------------------------------------------------------------------------

{-
/**
 * Get a read-only buffer with the raw content of a blob.
 *
 * A pointer to the raw content of a blob is returned;
 * this pointer is owned internally by the object and shall
 * not be free'd. The pointer may be invalidated at a later
 * time.
 *
 * @param blob pointer to the blob
 * @return the pointer; NULL if the blob has no contents
 */
GIT_EXTERN(const void *) git_blob_rawcontent(git_blob *blob);
-}
-- TODO: Could the next two be made "pure"
-- TODO: Figure out what this function should return...
rawBlobContent :: Blob -> IO CPtr
rawBlobContent (Blob b) = {#call git_blob_rawcontent#} b

rawBlobSize :: Blob -> IO Int
rawBlobSize (Blob b) = return . fromIntegral =<< {#call git_blob_rawsize#} b

blobFromFile :: ObjID -> Repository -> String -> IO (Maybe GitError)
blobFromFile (ObjID obj) (Repository repo) path = do
  pathStr  <- newCString path
  res      <- {#call git_blob_create_fromfile #} obj repo pathStr
  retMaybeRes res

-- TODO: CPtr here?
blobFromBuffer :: ObjID -> Repository -> CPtr -> IO (Maybe GitError)
blobFromBuffer (ObjID objId) (Repository repo) buf = do
  res <- {#call git_blob_create_frombuffer#} objId repo buf
                                             (fromIntegral $ sizeOf buf)
  retMaybeRes res

-------------------------------------------------------------------------------
-- END: blob.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: commit.h
-------------------------------------------------------------------------------

commitId :: Commit -> ObjID
commitId (Commit c) = unsafePerformIO $
  return . ObjID =<< {#call unsafe git_commit_id#} c

shortCommitMsg :: Commit -> String
shortCommitMsg (Commit c) = unsafePerformIO $
  peekCString =<< {#call unsafe git_commit_message_short#} c

commitMsg :: Commit -> String
commitMsg (Commit c) = unsafePerformIO $
  peekCString =<< {#call unsafe git_commit_message#} c

commitTime :: Commit -> TimeT
commitTime (Commit c) = unsafePerformIO $
  return =<< {#call unsafe git_commit_time#} c

timeOffset :: Commit -> Int
timeOffset (Commit c) = unsafePerformIO $
  return . fromIntegral =<< {#call unsafe git_commit_time_offset#} c

committer :: Commit -> Signature
committer (Commit c) = unsafePerformIO $
  return . Signature =<< {#call unsafe git_commit_committer#} c

author :: Commit -> Signature
author (Commit c) = unsafePerformIO $
  return . Signature =<< {#call unsafe git_commit_author#} c

tree :: Commit -> IO (Either GitError Tree)
tree (Commit c) = alloca $ \tree -> do
  res <- {#call git_commit_tree#} tree c
  retEither res $ fmap (Right . Tree) $ peek tree

treeOid :: Commit -> ObjID
treeOid (Commit c) = unsafePerformIO $
  return . ObjID =<< {#call unsafe git_commit_tree_oid#} c

parentCount :: Commit -> IO Int
parentCount (Commit c) =
  return . fromIntegral =<< {#call unsafe git_commit_parentcount#} c

parent :: Commit -> Int -> IO (Either GitError Commit)
parent (Commit c) n = alloca $ \parent -> do
  res <- {#call git_commit_parent#} parent c (fromIntegral n)
  retEither res $ fmap (Right . Commit) $ peek parent

parentObjID :: Commit -> Int -> IO (Maybe ObjID)
parentObjID (Commit c) n = do
  res <- {#call git_commit_parent_oid#} c (fromIntegral n)
  if res == nullPtr
    then return Nothing
    else return . Just . ObjID $ res

createCommit :: ObjID -> Repository -> Maybe String -> Signature -> Signature
             -> String -> Tree -> [Commit] -> IO (Maybe GitError)
createCommit (ObjID objId) (Repository r) mref (Signature ausig)
             (Signature comsig) msg (Tree t) ps = do
  updRef <- case mref of
              Nothing -> return nullPtr
              Just x  -> newCString x
  msgStr <- newCString msg
  carr   <- newArray [c | Commit c <- ps]
  res    <- {#call git_commit_create#} objId r updRef ausig comsig msgStr t cnt carr
  retMaybeRes res
  where cnt = fromIntegral $ length ps

-------------------------------------------------------------------------------
-- END: commit.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: common.h
-------------------------------------------------------------------------------

-- TODO: Support?
-- GIT_EXTERN(void) git_strarray_free(git_strarray *array);
{-
/**
 * Return the version of the libgit2 library
 * being currently used.
 *
 * @param major Store the major version number
 * @param minor Store the minor version number
 * @param rev Store the revision (patch) number
 */
GIT_EXTERN(void) git_libgit2_version(int *major, int *minor, int *rev);
-}

-------------------------------------------------------------------------------
-- END: common.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: config.h
-------------------------------------------------------------------------------

{-
/**
 * Locate the path to the global configuration file
 *
 * The user or global configuration file is usually
 * located in `$HOME/.gitconfig`.
 *
 * This method will try to guess the full path to that
 * file, if the file exists. The returned path
 * may be used on any `git_config` call to load the
 * global configuration file.
 *
 * @param global_config_path Buffer of GIT_PATH_MAX length to store the path
 * @return GIT_SUCCESS if a global configuration file has been
 *	found. Its path will be stored in `buffer`.
 */
GIT_EXTERN(int) git_config_find_global(char *global_config_path);

/**
 * Open the global configuration file
 *
 * Utility wrapper that calls `git_config_find_global`
 * and opens the located file, if it exists.
 *
 * @param out Pointer to store the config instance
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_open_global(git_config **out);

/**
 * Create a configuration file backend for ondisk files
 *
 * These are the normal `.gitconfig` files that Core Git
 * processes. Note that you first have to add this file to a
 * configuration object before you can query it for configuration
 * variables.
 *
 * @param out the new backend
 * @param path where the config file is located
 */
GIT_EXTERN(int) git_config_file__ondisk(struct git_config_file **out, const char *path);

/**
 * Allocate a new configuration object
 *
 * This object is empty, so you have to add a file to it before you
 * can do anything with it.
 *
 * @param out pointer to the new configuration
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_new(git_config **out);

/**
 * Add a generic config file instance to an existing config
 *
 * Note that the configuration object will free the file
 * automatically.
 *
 * Further queries on this config object will access each
 * of the config file instances in order (instances with
 * a higher priority will be accessed first).
 *
 * @param cfg the configuration to add the file to
 * @param file the configuration file (backend) to add
 * @param priority the priority the backend should have
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_add_file(git_config *cfg, git_config_file *file, int priority);

/**
 * Add an on-disk config file instance to an existing config
 *
 * The on-disk file pointed at by `path` will be opened and
 * parsed; it's expected to be a native Git config file following
 * the default Git config syntax (see man git-config).
 *
 * Note that the configuration object will free the file
 * automatically.
 *
 * Further queries on this config object will access each
 * of the config file instances in order (instances with
 * a higher priority will be accessed first).
 *
 * @param cfg the configuration to add the file to
 * @param path path to the configuration file (backend) to add
 * @param priority the priority the backend should have
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_add_file_ondisk(git_config *cfg, const char *path, int priority);

/**
 * Create a new config instance containing a single on-disk file
 *
 * This method is a simple utility wrapper for the following sequence
 * of calls:
 *	- git_config_new
 *	- git_config_add_file_ondisk
 *
 * @param cfg The configuration instance to create
 * @param path Path to the on-disk file to open
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_open_ondisk(git_config **cfg, const char *path);

/**
 * Free the configuration and its associated memory and files
 *
 * @param cfg the configuration to free
 */
GIT_EXTERN(void) git_config_free(git_config *cfg);

/**
 * Get the value of an integer config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable where the value should be stored
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_int(git_config *cfg, const char *name, int *out);

/**
 * Get the value of a long integer config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable where the value should be stored
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_long(git_config *cfg, const char *name, long int *out);

/**
 * Get the value of a boolean config variable.
 *
 * This function uses the usual C convention of 0 being false and
 * anything else true.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable where the value should be stored
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_bool(git_config *cfg, const char *name, int *out);

/**
 * Get the value of a string config variable.
 *
 * The string is owned by the variable and should not be freed by the
 * user.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable's value
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_string(git_config *cfg, const char *name, const char **out);

/**
 * Set the value of an integer config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param value Integer value for the variable
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_set_int(git_config *cfg, const char *name, int value);

/**
 * Set the value of a long integer config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param value Long integer value for the variable
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_set_long(git_config *cfg, const char *name, long int value);

/**
 * Set the value of a boolean config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param value the value to store
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_set_bool(git_config *cfg, const char *name, int value);

/**
 * Set the value of a string config variable.
 *
 * A copy of the string is made and the user is free to use it
 * afterwards.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param value the string to store.
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_set_string(git_config *cfg, const char *name, const char *value);

/**
 * Delete a config variable
 *
 * @param cfg the configuration
 * @param name the variable to delete
 */
GIT_EXTERN(int) git_config_delete(git_config *cfg, const char *name);

/**
 * Perform an operation on each config variable.
 *
 * The callback receives the normalized name and value of each variable
 * in the config backend, and the data pointer passed to this function.
 * As soon as one of the callback functions returns something other than 0,
 * this function returns that value.
 *
 * @param cfg where to get the variables from
 * @param callback the function to call on each variable
 * @param payload the data to pass to the callback
 * @return GIT_SUCCESS or the return value of the callback which didn't return 0
 */
GIT_EXTERN(int) git_config_foreach(
	git_config *cfg,
	int (*callback)(const char *var_name, const char *value, void *payload),
	void *payload);
-}

-------------------------------------------------------------------------------
-- END: config.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: errors.h
-------------------------------------------------------------------------------

lastError :: IO String
lastError = peekCString =<< {#call git_lasterror#}

clearError :: IO ()
clearError = {#call git_clearerror#}

-------------------------------------------------------------------------------
-- END: errors.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: index.h
-------------------------------------------------------------------------------
{#enum define IdxEntry { GIT_IDXENTRY_NAMEMASK as NameMask
                       , GIT_IDXENTRY_STAGEMASK as StageMask
                       , GIT_IDXENTRY_EXTENDED as ExtendedOrSkipWorkTree
                       , GIT_IDXENTRY_VALID as ValidOrExtended2
                       , GIT_IDXENTRY_STAGESHIFT as StageShift
                       , GIT_IDXENTRY_UPDATE as Update
                       , GIT_IDXENTRY_REMOVE as Remove
                       , GIT_IDXENTRY_UPTODATE as UpToDate
                       , GIT_IDXENTRY_ADDED as Added
                       , GIT_IDXENTRY_HASHED as Hashed
                       , GIT_IDXENTRY_UNHASHED as UnHashed
                       , GIT_IDXENTRY_WT_REMOVE as WTRemove
                       , GIT_IDXENTRY_CONFLICTED as Conflicted
                       , GIT_IDXENTRY_UNPACKED as Unpacked
                       , GIT_IDXENTRY_NEW_SKIP_WORKTREE as NewSkipWorkTree
                       , GIT_IDXENTRY_INTENT_TO_ADD as IntentToAdd
                       , GIT_IDXENTRY_SKIP_WORKTREE as SkipWorkTree
                       , GIT_IDXENTRY_EXTENDED2 as Extended2
                       }#}

-- TODO: Can we get this into IdxEntry somehow?
idxExtFlags :: Int
idxExtFlags = fromEnum IntentToAdd .|. fromEnum SkipWorkTree

-- | Create a new bare Git index object as a memory representation of the Git
-- index file in the provided path, without a repository to back it.
openIndex :: String -> IO (Either GitError Index)
openIndex path = alloca $ \index -> do
  pth <- newCString path
  res <- {#call git_index_open#} index pth
  retEither res $ fmap (Right . Index) $ peek index

-- | Clear the contents (all the entries) of an index object. This clears the
-- index object in memory; changes must be manually written to disk for them to
-- take effect.
clearIndex :: Index -> IO ()
clearIndex (Index idx) = {#call git_index_clear#} idx

-- | Free an existing index object.
freeIndex :: Index -> IO ()
freeIndex (Index idx) = {#call git_index_free#} idx

-- | Update the contents of an existing index object in memory by reading from
-- the hard disk.
readIndex :: Index -> IO (Maybe GitError)
readIndex (Index idx) = do
  res <- {#call git_index_read#} idx
  retMaybeRes res

-- | Write an existing index object from memory back to disk using an atomic
-- file lock.
writeIndex :: Index -> IO (Maybe GitError)
writeIndex (Index idx) = do
  res <- {#call git_index_write#} idx
  retMaybeRes res

-- | Find the first index of any entries which point to given path in the Git
-- index.
findIndex :: Index -> String -> IO (Maybe Int)
findIndex (Index idx) path = do
  pth <- newCString path
  res <- {#call git_index_find#} idx pth
  if res >= 0
    then return . Just $ fromIntegral res
    else return Nothing

-- | Remove all entries with equal path except last added
uniqIndex :: Index -> IO ()
uniqIndex (Index idx) = {#call git_index_uniq#} idx

-- | Add or update an index entry from a file in disk
addIndex :: Index -> String -> Int -> IO (Maybe GitError)
addIndex (Index idx) path stage = do
  pth <- newCString path
  res <- {#call git_index_add#} idx pth (fromIntegral stage)
  retMaybeRes res

{-
/**
 * Add or update an index entry from an in-memory struct
 *
 * A full copy (including the 'path' string) of the given
 * 'source_entry' will be inserted on the index.
 *
 * @param index an existing index object
 * @param source_entry new entry object
 * @return 0 on success, otherwise an error code
 */
GIT_EXTERN(int) git_index_add2(git_index *index, const git_index_entry *source_entry);

/**
 * Add (append) an index entry from a file in disk
 *
 * A new entry will always be inserted into the index;
 * if the index already contains an entry for such
 * path, the old entry will **not** be replaced.
 *
 * The file `path` must be relative to the repository's
 * working folder and must be readable.
 *
 * This method will fail in bare index instances.
 *
 * @param index an existing index object
 * @param path filename to add
 * @param stage stage for the entry
 * @return 0 on success, otherwise an error code
 */
GIT_EXTERN(int) git_index_append(git_index *index, const char *path, int stage);

/**
 * Add (append) an index entry from an in-memory struct
 *
 * A new entry will always be inserted into the index;
 * if the index already contains an entry for the path
 * in the `entry` struct, the old entry will **not** be
 * replaced.
 *
 * A full copy (including the 'path' string) of the given
 * 'source_entry' will be inserted on the index.
 *
 * @param index an existing index object
 * @param source_entry new entry object
 * @return 0 on success, otherwise an error code
 */
GIT_EXTERN(int) git_index_append2(git_index *index, const git_index_entry *source_entry);

/**
 * Remove an entry from the index
 *
 * @param index an existing index object
 * @param position position of the entry to remove
 * @return 0 on success, otherwise an error code
 */
GIT_EXTERN(int) git_index_remove(git_index *index, int position);

/**
 * Get a pointer to one of the entries in the index
 *
 * This entry can be modified, and the changes will be written
 * back to disk on the next write() call.
 *
 * The entry should not be freed by the caller.
 *
 * @param index an existing index object
 * @param n the position of the entry
 * @return a pointer to the entry; NULL if out of bounds
 */
GIT_EXTERN(git_index_entry *) git_index_get(git_index *index, unsigned int n);

/**
 * Get the count of entries currently in the index
 *
 * @param index an existing index object
 * @return integer of count of current entries
 */
GIT_EXTERN(unsigned int) git_index_entrycount(git_index *index);

/**
 * Get the count of unmerged entries currently in the index
 *
 * @param index an existing index object
 * @return integer of count of current unmerged entries
 */
GIT_EXTERN(unsigned int) git_index_entrycount_unmerged(git_index *index);

/**
 * Get an unmerged entry from the index.
 *
 * The returned entry is read-only and should not be modified
 * of freed by the caller.
 *
 * @param index an existing index object
 * @param path path to search
 * @return the unmerged entry; NULL if not found
 */
GIT_EXTERN(const git_index_entry_unmerged *) git_index_get_unmerged_bypath(git_index *index, const char *path);

/**
 * Get an unmerged entry from the index.
 *
 * The returned entry is read-only and should not be modified
 * of freed by the caller.
 *
 * @param index an existing index object
 * @param n the position of the entry
 * @return a pointer to the unmerged entry; NULL if out of bounds
 */
GIT_EXTERN(const git_index_entry_unmerged *) git_index_get_unmerged_byindex(git_index *index, unsigned int n);

/**
 * Return the stage number from a git index entry
 *
 * This entry is calculated from the entrie's flag
 * attribute like this:
 *
 *	(entry->flags & GIT_IDXENTRY_STAGEMASK) >> GIT_IDXENTRY_STAGESHIFT
 *
 * @param entry The entry
 * @returns the stage number
 */
GIT_EXTERN(int) git_index_entry_stage(const git_index_entry *entry);

-}

-------------------------------------------------------------------------------
-- END: index.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: repositoy.h
-------------------------------------------------------------------------------

repoIs :: Ptr2Int -> Repository -> IO Bool
repoIs ffi (Repository ptr) = return . toBool =<< ffi ptr

openRepo :: String -> IO (Either GitError Repository)
openRepo path = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_open#} pprepo pstr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDir :: String -> String -> String -> String
               -> IO (Either GitError Repository)
openRepoObjDir dir objDir idxFile workTree = alloca $ \pprepo -> do
  dirStr  <- newCString dir
  objDStr <- newCString objDir
  idxFStr <- newCString idxFile
  wtrStr  <- newCString workTree
  res     <- {#call git_repository_open2#} pprepo dirStr objDStr idxFStr wtrStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDb :: String -> ObjDB -> String -> String
              -> IO (Either GitError Repository)
openRepoObjDb dir (ObjDB db) idxFile workTree = alloca $ \pprepo -> do
  dirStr  <- newCString dir
  idxFStr <- newCString idxFile
  wtrStr  <- newCString workTree
  res     <- {#call git_repository_open3#} pprepo dirStr db idxFStr wtrStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

discover :: String -> Bool -> String -> IO (Either GitError String)
discover startPath acrossFs ceilingDirs = alloca $ \path -> do
  spStr  <- newCString startPath
  cdsStr <- newCString ceilingDirs
  res    <- {#call git_repository_discover#} path (fromIntegral $ sizeOf path)
                                             spStr (fromBool acrossFs) cdsStr
  retEither res $ fmap Right $ peekCString path

database :: Repository -> IO ObjDB
database (Repository r) = return . ObjDB =<< {#call git_repository_database#} r

index :: Repository -> IO (Either GitError Index)
index (Repository r) = alloca $ \idx -> do
  res  <- {#call git_repository_index#} idx r
  retEither res $ fmap (Right . Index) $ peek idx

free :: Repository -> IO ()
free (Repository r) = {#call git_repository_free#} r

init :: String -> Bool -> IO (Either GitError Repository)
init path isBare = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_init#} pprepo pstr (fromBool isBare)
  retEither res $ fmap (Right . Repository) $ peek pprepo

isHeadDetached :: Repository -> IO Bool
isHeadDetached = repoIs {#call git_repository_head_detached#}

isHeadOrphan :: Repository -> IO Bool
isHeadOrphan = repoIs {#call git_repository_head_orphan#}

isEmpty :: Repository -> IO Bool
isEmpty = repoIs {#call git_repository_is_empty#}

path :: Repository -> RepositoryPathID -> IO String
path (Repository r) pathID = peekCString =<< {#call git_repository_path#} r p
  where p = fromIntegral $ fromEnum pathID

isBare :: Repository -> IO Bool
isBare = repoIs {#call git_repository_is_bare#}

-------------------------------------------------------------------------------
-- END: repository.h
-------------------------------------------------------------------------------

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}

#include "git2.h"

module Git2 where

import Data.Maybe
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO.Unsafe

type OffT    = {#type git_off_t#}
type TimeT   = {#type git_time_t#}
type CPtr    = Ptr ()
type Ptr2Int = CPtr -> IO CInt

newtype ObjDB      = ObjDB CPtr
newtype Repository = Repository CPtr
newtype Index      = Index CPtr
newtype Blob       = Blob CPtr
newtype ObjID      = ObjID CPtr
newtype Commit     = Commit CPtr
newtype Signature  = Signature CPtr
newtype Tree       = Tree CPtr
newtype Config     = Config CPtr

defaultPort :: String
defaultPort = "9418" -- TODO: Import from net.h?

{#enum define Direction { GIT_DIR_FETCH as Fetch
                        , GIT_DIR_PUSH as Push}#}

{-
#define GIT_STATUS_CURRENT        0
/** Flags for index status */
#define GIT_STATUS_INDEX_NEW      (1 << 0)
#define GIT_STATUS_INDEX_MODIFIED (1 << 1)
#define GIT_STATUS_INDEX_DELETED  (1 << 2)

/** Flags for worktree status */
#define GIT_STATUS_WT_NEW         (1 << 3)
#define GIT_STATUS_WT_MODIFIED    (1 << 4)
#define GIT_STATUS_WT_DELETED     (1 << 5)

// TODO Ignored files not handled yet
#define GIT_STATUS_IGNORED        (1 << 6)
-}

{-
{#enum define Status { GIT_STATUS_CURRENT as Current
                     , GIT_STATUS_INDEX_NEW as NewIndex
                     , GIT_STATUS_INDEX_MODIFIED as ModifiedIndex
                     , GIT_STATUS_INDEX_DELETED as DeletedIndex
                     , GIT_STATUS_WT_NEW as NewWorkTree
                     , GIT_STATUS_WT_MODIFIED as ModifiedWorkTree
                     , GIT_STATUS_WT_DELETED as DeletedWorkTree
                     , GIT_STATUS_IGNORED as Ignored}#}
-}

{#enum git_otype as OType {underscoreToCase}#}
{#enum git_rtype as RType {underscoreToCase}#}
{#enum git_repository_pathid as RepositoryPathID {underscoreToCase}#}
{#enum git_error as GitError {underscoreToCase}#}
{#enum git_odb_streammode as ODBStreamMode {underscoreToCase}#}

deriving instance Show GitError

retEither :: CInt -> IO (Either GitError a) -> IO (Either GitError a)
retEither res f | res == 0  = f
                | otherwise = return . Left . toEnum . fromIntegral $ res

retMaybeRes :: CInt -> IO (Maybe GitError)
retMaybeRes res | res == 0  = return Nothing
                | otherwise = return $ Just . toEnum . fromIntegral $ res

-------------------------------------------------------------------------------
-- BEGIN: blob.h
-------------------------------------------------------------------------------

{-
/**
 * Get a read-only buffer with the raw content of a blob.
 *
 * A pointer to the raw content of a blob is returned;
 * this pointer is owned internally by the object and shall
 * not be free'd. The pointer may be invalidated at a later
 * time.
 *
 * @param blob pointer to the blob
 * @return the pointer; NULL if the blob has no contents
 */
GIT_EXTERN(const void *) git_blob_rawcontent(git_blob *blob);
-}
-- TODO: Could the next two be made "pure"
-- TODO: Figure out what this function should return...
rawBlobContent :: Blob -> IO CPtr
rawBlobContent (Blob b) = {#call git_blob_rawcontent#} b

rawBlobSize :: Blob -> IO Int
rawBlobSize (Blob b) = return . fromIntegral =<< {#call git_blob_rawsize#} b

blobFromFile :: ObjID -> Repository -> String -> IO (Maybe GitError)
blobFromFile (ObjID obj) (Repository repo) path = do
  pathStr  <- newCString path
  res      <- {#call git_blob_create_fromfile #} obj repo pathStr
  retMaybeRes res

-- TODO: CPtr here?
blobFromBuffer :: ObjID -> Repository -> CPtr -> IO (Maybe GitError)
blobFromBuffer (ObjID objId) (Repository repo) buf = do
  res <- {#call git_blob_create_frombuffer#} objId repo buf
                                             (fromIntegral $ sizeOf buf)
  retMaybeRes res

-------------------------------------------------------------------------------
-- END: blob.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: commit.h
-------------------------------------------------------------------------------

commitId :: Commit -> ObjID
commitId (Commit c) = unsafePerformIO $
  return . ObjID =<< {#call unsafe git_commit_id#} c

shortCommitMsg :: Commit -> String
shortCommitMsg (Commit c) = unsafePerformIO $
  peekCString =<< {#call unsafe git_commit_message_short#} c

commitMsg :: Commit -> String
commitMsg (Commit c) = unsafePerformIO $
  peekCString =<< {#call unsafe git_commit_message#} c

commitTime :: Commit -> TimeT
commitTime (Commit c) = unsafePerformIO $
  return =<< {#call unsafe git_commit_time#} c

timeOffset :: Commit -> Int
timeOffset (Commit c) = unsafePerformIO $
  return . fromIntegral =<< {#call unsafe git_commit_time_offset#} c

committer :: Commit -> Signature
committer (Commit c) = unsafePerformIO $
  return . Signature =<< {#call unsafe git_commit_committer#} c

author :: Commit -> Signature
author (Commit c) = unsafePerformIO $
  return . Signature =<< {#call unsafe git_commit_author#} c

tree :: Commit -> IO (Either GitError Tree)
tree (Commit c) = alloca $ \tree -> do
  res <- {#call git_commit_tree#} tree c
  retEither res $ fmap (Right . Tree) $ peek tree

treeOid :: Commit -> ObjID
treeOid (Commit c) = unsafePerformIO $
  return . ObjID =<< {#call unsafe git_commit_tree_oid#} c

parentCount :: Commit -> IO Int
parentCount (Commit c) =
  return . fromIntegral =<< {#call unsafe git_commit_parentcount#} c

parent :: Commit -> Int -> IO (Either GitError Commit)
parent (Commit c) n = alloca $ \parent -> do
  res <- {#call git_commit_parent#} parent c (fromIntegral n)
  retEither res $ fmap (Right . Commit) $ peek parent

parentObjID :: Commit -> Int -> IO (Maybe ObjID)
parentObjID (Commit c) n = do
  res <- {#call git_commit_parent_oid#} c (fromIntegral n)
  if res == nullPtr
    then return Nothing
    else return . Just . ObjID $ res

createCommit :: ObjID -> Repository -> Maybe String -> Signature -> Signature
             -> String -> Tree -> [Commit] -> IO (Maybe GitError)
createCommit (ObjID objId) (Repository r) mref (Signature ausig)
             (Signature comsig) msg (Tree t) ps = do
  updRef <- case mref of
              Nothing -> return nullPtr
              Just x  -> newCString x
  msgStr <- newCString msg
  carr   <- newArray [c | Commit c <- ps]
  res    <- {#call git_commit_create#} objId r updRef ausig comsig msgStr t cnt carr
  retMaybeRes res
  where cnt = fromIntegral $ length ps

-------------------------------------------------------------------------------
-- END: commit.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: common.h
-------------------------------------------------------------------------------

-- TODO: Support?
-- GIT_EXTERN(void) git_strarray_free(git_strarray *array);
{-
/**
 * Return the version of the libgit2 library
 * being currently used.
 *
 * @param major Store the major version number
 * @param minor Store the minor version number
 * @param rev Store the revision (patch) number
 */
GIT_EXTERN(void) git_libgit2_version(int *major, int *minor, int *rev);
-}

-------------------------------------------------------------------------------
-- END: common.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: config.h
-------------------------------------------------------------------------------

{-
/**
 * Locate the path to the global configuration file
 *
 * The user or global configuration file is usually
 * located in `$HOME/.gitconfig`.
 *
 * This method will try to guess the full path to that
 * file, if the file exists. The returned path
 * may be used on any `git_config` call to load the
 * global configuration file.
 *
 * @param global_config_path Buffer of GIT_PATH_MAX length to store the path
 * @return GIT_SUCCESS if a global configuration file has been
 *	found. Its path will be stored in `buffer`.
 */
GIT_EXTERN(int) git_config_find_global(char *global_config_path);

/**
 * Open the global configuration file
 *
 * Utility wrapper that calls `git_config_find_global`
 * and opens the located file, if it exists.
 *
 * @param out Pointer to store the config instance
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_open_global(git_config **out);

/**
 * Create a configuration file backend for ondisk files
 *
 * These are the normal `.gitconfig` files that Core Git
 * processes. Note that you first have to add this file to a
 * configuration object before you can query it for configuration
 * variables.
 *
 * @param out the new backend
 * @param path where the config file is located
 */
GIT_EXTERN(int) git_config_file__ondisk(struct git_config_file **out, const char *path);

/**
 * Allocate a new configuration object
 *
 * This object is empty, so you have to add a file to it before you
 * can do anything with it.
 *
 * @param out pointer to the new configuration
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_new(git_config **out);

/**
 * Add a generic config file instance to an existing config
 *
 * Note that the configuration object will free the file
 * automatically.
 *
 * Further queries on this config object will access each
 * of the config file instances in order (instances with
 * a higher priority will be accessed first).
 *
 * @param cfg the configuration to add the file to
 * @param file the configuration file (backend) to add
 * @param priority the priority the backend should have
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_add_file(git_config *cfg, git_config_file *file, int priority);

/**
 * Add an on-disk config file instance to an existing config
 *
 * The on-disk file pointed at by `path` will be opened and
 * parsed; it's expected to be a native Git config file following
 * the default Git config syntax (see man git-config).
 *
 * Note that the configuration object will free the file
 * automatically.
 *
 * Further queries on this config object will access each
 * of the config file instances in order (instances with
 * a higher priority will be accessed first).
 *
 * @param cfg the configuration to add the file to
 * @param path path to the configuration file (backend) to add
 * @param priority the priority the backend should have
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_add_file_ondisk(git_config *cfg, const char *path, int priority);

/**
 * Create a new config instance containing a single on-disk file
 *
 * This method is a simple utility wrapper for the following sequence
 * of calls:
 *	- git_config_new
 *	- git_config_add_file_ondisk
 *
 * @param cfg The configuration instance to create
 * @param path Path to the on-disk file to open
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_open_ondisk(git_config **cfg, const char *path);

/**
 * Free the configuration and its associated memory and files
 *
 * @param cfg the configuration to free
 */
GIT_EXTERN(void) git_config_free(git_config *cfg);

/**
 * Get the value of an integer config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable where the value should be stored
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_int(git_config *cfg, const char *name, int *out);

/**
 * Get the value of a long integer config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable where the value should be stored
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_long(git_config *cfg, const char *name, long int *out);

/**
 * Get the value of a boolean config variable.
 *
 * This function uses the usual C convention of 0 being false and
 * anything else true.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable where the value should be stored
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_bool(git_config *cfg, const char *name, int *out);

/**
 * Get the value of a string config variable.
 *
 * The string is owned by the variable and should not be freed by the
 * user.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable's value
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_string(git_config *cfg, const char *name, const char **out);

/**
 * Set the value of an integer config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param value Integer value for the variable
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_set_int(git_config *cfg, const char *name, int value);

/**
 * Set the value of a long integer config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param value Long integer value for the variable
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_set_long(git_config *cfg, const char *name, long int value);

/**
 * Set the value of a boolean config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param value the value to store
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_set_bool(git_config *cfg, const char *name, int value);

/**
 * Set the value of a string config variable.
 *
 * A copy of the string is made and the user is free to use it
 * afterwards.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param value the string to store.
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_set_string(git_config *cfg, const char *name, const char *value);

/**
 * Delete a config variable
 *
 * @param cfg the configuration
 * @param name the variable to delete
 */
GIT_EXTERN(int) git_config_delete(git_config *cfg, const char *name);

/**
 * Perform an operation on each config variable.
 *
 * The callback receives the normalized name and value of each variable
 * in the config backend, and the data pointer passed to this function.
 * As soon as one of the callback functions returns something other than 0,
 * this function returns that value.
 *
 * @param cfg where to get the variables from
 * @param callback the function to call on each variable
 * @param payload the data to pass to the callback
 * @return GIT_SUCCESS or the return value of the callback which didn't return 0
 */
GIT_EXTERN(int) git_config_foreach(
	git_config *cfg,
	int (*callback)(const char *var_name, const char *value, void *payload),
	void *payload);
-}

-------------------------------------------------------------------------------
-- END: config.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: errors.h
-------------------------------------------------------------------------------

lastError :: IO String
lastError = peekCString =<< {#call git_lasterror#}

clearError :: IO ()
clearError = {#call git_clearerror#}

-------------------------------------------------------------------------------
-- END: errors.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: repositoy.h
-------------------------------------------------------------------------------

repoIs :: Ptr2Int -> Repository -> IO Bool
repoIs ffi (Repository ptr) = return . toBool =<< ffi ptr

openRepo :: String -> IO (Either GitError Repository)
openRepo path = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_open#} pprepo pstr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDir :: String -> String -> String -> String
               -> IO (Either GitError Repository)
openRepoObjDir dir objDir idxFile workTree = alloca $ \pprepo -> do
  dirStr  <- newCString dir
  objDStr <- newCString objDir
  idxFStr <- newCString idxFile
  wtrStr  <- newCString workTree
  res     <- {#call git_repository_open2#} pprepo dirStr objDStr idxFStr wtrStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDb :: String -> ObjDB -> String -> String
              -> IO (Either GitError Repository)
openRepoObjDb dir (ObjDB db) idxFile workTree = alloca $ \pprepo -> do
  dirStr  <- newCString dir
  idxFStr <- newCString idxFile
  wtrStr  <- newCString workTree
  res     <- {#call git_repository_open3#} pprepo dirStr db idxFStr wtrStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

discover :: String -> Bool -> String -> IO (Either GitError String)
discover startPath acrossFs ceilingDirs = alloca $ \path -> do
  spStr  <- newCString startPath
  cdsStr <- newCString ceilingDirs
  res    <- {#call git_repository_discover#} path (fromIntegral $ sizeOf path)
                                             spStr (fromBool acrossFs) cdsStr
  retEither res $ fmap Right $ peekCString path

database :: Repository -> IO ObjDB
database (Repository r) = return . ObjDB =<< {#call git_repository_database#} r

index :: Repository -> IO (Either GitError Index)
index (Repository r) = alloca $ \idx -> do
  res  <- {#call git_repository_index#} idx r
  retEither res $ fmap (Right . Index) $ peek idx

free :: Repository -> IO ()
free (Repository r) = {#call git_repository_free#} r

init :: String -> Bool -> IO (Either GitError Repository)
init path isBare = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_init#} pprepo pstr (fromBool isBare)
  retEither res $ fmap (Right . Repository) $ peek pprepo

isHeadDetached :: Repository -> IO Bool
isHeadDetached = repoIs {#call git_repository_head_detached#}

isHeadOrphan :: Repository -> IO Bool
isHeadOrphan = repoIs {#call git_repository_head_orphan#}

isEmpty :: Repository -> IO Bool
isEmpty = repoIs {#call git_repository_is_empty#}

path :: Repository -> RepositoryPathID -> IO String
path (Repository r) pathID = peekCString =<< {#call git_repository_path#} r p
  where p = fromIntegral $ fromEnum pathID

isBare :: Repository -> IO Bool
isBare = repoIs {#call git_repository_is_bare#}

-------------------------------------------------------------------------------
-- END: repository.h
-------------------------------------------------------------------------------


style tweaks

style tweaks

-- -*-haskell-*-

{-# LANGUAGE
   StandaloneDeriving
  ,GeneralizedNewtypeDeriving
  #-}

module Graphics.X11.Xcb.Internal where

import Control.Applicative
import Control.Monad
import Foreign
import Foreign.C.String
import Foreign.C.Types

import qualified Data.ByteString as S
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Lazy as L

{#import Foreign.IOVec#}

#include <xcb/xcb.h>
#include <xcb/xcbext.h>

peekIntConv
    :: (Integral a, Num b, Storable a)
       => Ptr a -> IO b
peekIntConv ptr = fromIntegral <$> peek ptr

{-
  Welcome to my sometimes-dodgy FFI bindings to XCB.
  The idea isn't really to write something to directly
  write X apps with, but to write a foundation for
  something higher-level and safer.

  So referential transparency can definetly be abused
  with a lot of the calls in here.

  So don't do it.
 -}

{#context lib="xcb" prefix="xcb_"#}

withConnection :: Connection -> (Ptr Connection -> IO b) -> IO b
{#pointer *connection_t as Connection foreign newtype#}
{#pointer *setup_t as Setup newtype#} -- no finalizer, part of the Connection

-- | Returns a connection to the indicated X server, as well
-- as the screen connected to.
-- The passed in string may be null, in which case
-- it will be the same as passing in the DISPLAY environment
-- variable.
connect :: String -> IO (Maybe (Connection, Int))
connect display
    = withCString display $ \displayPtr ->
      alloca $ \screenPtr -> do

      cPtr <- {#call connect as connect_#} displayPtr screenPtr
      screen <- peekIntConv screenPtr

      if cPtr == nullPtr then return Nothing else do

      c <- mkConnection cPtr
      return $ Just (c, screen)

-- | Parse the host, display and screen from a string.
-- The same as what we would do if the string were
-- passed to 'connect'.
parseDisplay :: String -> IO (Maybe (String, Int, Int))
parseDisplay display
    = withCString display $ \displayPtr ->
      alloca $ \hostStringPtr ->
      alloca $ \displayNumPtr ->
      alloca $ \screenPtr -> do
      success <- toBool <$>
                 {#call unsafe parse_display#} displayPtr hostStringPtr displayNumPtr screenPtr
      if not success then return Nothing else do

      host <- peek hostStringPtr >>= peekCString
      peek hostStringPtr >>= free

      displayNum <- peekIntConv displayNumPtr
      screen <- peekIntConv screenPtr

      return $ Just (host, displayNum, screen)

-- | Flush the write buffers.
flush :: Connection -> IO Bool
flush c = withConnection c $ \cPtr ->
          toBool <$> {#call flush as flush_#} cPtr

-- | The memory backing this data structure is owned
-- by the passed in Connection - and will magicaly vanish
-- if your 'Connection' gets GCd before the return value
-- of this function.  Watch out.
unsafeGetSetup :: Connection -> IO Setup
unsafeGetSetup c = withConnection c $ \cPtr ->
                   {#call unsafe get_setup#} cPtr

-- | Length of the setup data in units of four bytes.
setupLength :: Setup -> IO Word16
setupLength (Setup s) = fromIntegral <$> {#get setup_t->length#} s

-- | This ByteString is just as unsafe as the passed in connection
-- object.  Please make a copy.
unsafeSetupData :: Setup -> IO S.ByteString
unsafeSetupData s@(Setup sPtr) = do
  len <- (4*) <$> setupLength s
  sFPtr <- newForeignPtr_ sPtr
  return $ S.fromForeignPtr (castForeignPtr sFPtr) 0 (fromIntegral len)

-- | Maximum size of a single request.
-- May not be an asynchronous call, as we'll make a call out
-- on the big-requests extension to find out if we can use that.
maximumRequestLength :: Connection -> IO Word32
maximumRequestLength c = withConnection c $ \cPtr ->
                         fromIntegral <$> {#call get_maximum_request_length#} cPtr

-- | Asynchronous version of 'maximumRequestLength'.  The return
-- from the server is cached for subsequent callse to 'maximumRequestLength'.
prefetchMaximumReuestLength :: Connection -> IO ()
prefetchMaximumReuestLength c = withConnection c $ \cPtr ->
                                {#call prefetch_maximum_request_length#} cPtr

-- | Is the connection in an error state?
connectionHasError :: Connection -> IO Bool
connectionHasError c = withConnection c $ \cPtr ->
                       toBool <$> {#call connection_has_error#} cPtr

newtype Cookie = Cookie CUInt

-- Working with extensions
{#pointer *extension_t as Extension newtype#} -- static data, no finalizer

-- :-(
instance Storable Extension where
    sizeOf (Extension ex) = sizeOf ex
    alignment (Extension ex) = alignment ex
    peekElemOff ptr off = Extension <$> peekElemOff (castPtr ptr) off
    pokeElemOff ptr off (Extension ex) = pokeElemOff (castPtr ptr) off ex
    peekByteOff ptr off = Extension <$> peekByteOff ptr off
    pokeByteOff ptr off (Extension ex) = pokeByteOff ptr off ex
    peek ptr = Extension <$> peek (castPtr ptr)
    poke ptr (Extension ex) = poke (castPtr ptr) ex

{#pointer *query_extension_reply_t as ExtensionInfo newtype#} -- freed with Connection, no finalizer

-- | May block if the data is not already cached.  For internal
-- use only - make a copy if you need something that will live
-- longer than the scope of the connection.
unsafeGetExtensionData :: Connection -> Extension -> IO ExtensionInfo
unsafeGetExtensionData c ext
    = withConnection c $ \cPtr ->
      {#call get_extension_data#} cPtr ext

extensionPresent :: ExtensionInfo -> IO Bool
extensionPresent (ExtensionInfo ext)
    = toBool <$> {#get query_extension_reply_t->present#} ext

extensionMajorOpcode :: ExtensionInfo -> IO Word8
extensionMajorOpcode (ExtensionInfo ext)
    = fromIntegral <$> {#get query_extension_reply_t->major_opcode#} ext

extensionFirstEvent :: ExtensionInfo -> IO Word8
extensionFirstEvent (ExtensionInfo ext)
    = fromIntegral <$> {#get query_extension_reply_t->first_event#} ext

extensionFirstError :: ExtensionInfo -> IO Word8
extensionFirstError (ExtensionInfo ext)
    = fromIntegral <$> {#get query_extension_reply_t->first_error#} ext

-- | Non-blocking query for extension data
prefetchExtension :: Connection -> Extension -> IO ()
prefetchExtension c ext
    = withConnection c $ \cPtr ->
      {#call prefetch_extension_data#} cPtr ext

class HasResponseType a where
    responseType :: a -> IO Int

isBigEvent :: HasResponseType a => a -> IO Bool
isBigEvent ev = (== 35) <$> responseType ev

isError :: HasResponseType a => a -> IO Bool
isError ev = (== 2) <$> responseType ev

-- Events
withGenericEvent :: GenericEvent -> (Ptr GenericEvent -> IO b) -> IO b
{#pointer *generic_event_t as GenericEvent foreign newtype#}
withGenericBigEvent :: GenericBigEvent -> (Ptr GenericBigEvent -> IO b) -> IO b
{#pointer *ge_event_t as GenericBigEvent foreign newtype#}

-- | The XCB documentation seems to imply that this can also return
-- errors, so be careful.
waitForEvent :: Connection -> IO GenericEvent
waitForEvent c = withConnection c $ \cPtr -> do
                 evPtr <- {#call wait_for_event#} cPtr
                 GenericEvent <$> newForeignPtr finalizerFree evPtr

instance HasResponseType GenericEvent where
    responseType = eventResponseType

eventResponseType :: GenericEvent -> IO Int
eventResponseType ev = withGenericEvent ev $ \evPtr ->
                       fromIntegral <$> {#get generic_event_t->response_type#} evPtr

-- | The conversion is not checked.
unsafeToBigEvent :: GenericEvent -> GenericBigEvent
unsafeToBigEvent (GenericEvent ev) = GenericBigEvent . castForeignPtr $ ev

-- | The conversion is not checked.
unsafeToError :: GenericEvent -> GenericError
unsafeToError (GenericEvent ev) = GenericError . castForeignPtr $ ev

-- | In units of four bytes.  Extra +1 for the 'full_sequence' field
-- introduced when XCB decodes from the wire.
bigEventLength :: GenericBigEvent -> IO Word32
bigEventLength bge = withGenericBigEvent bge $ \bgePtr -> do
                     lenField <- fromIntegral <$> {#get ge_event_t->length#} bgePtr
                     return $ 8 + 1 + lenField

-- | Unsafe in that referential transperency may be broken -
-- the ByteString is aliased to the same memory location as the
-- the event.
unsafeEventData :: GenericEvent -> IO S.ByteString
unsafeEventData ge = do
  isErr <- isError ge
  if isErr then unsafeErrorData (unsafeToError ge) else do

  isBig <- isBigEvent ge
  if isBig
     then do
       let bge@(GenericBigEvent bgeFPtr) = unsafeToBigEvent ge
       len <- bigEventLength bge
       return $ S.fromForeignPtr (castForeignPtr bgeFPtr) 0 (4 * fromIntegral len)
     else
       let GenericEvent evFPtr = ge
       in return $ S.fromForeignPtr (castForeignPtr evFPtr) 0 32

-- Errors
withGenericError :: GenericError -> (Ptr GenericError -> IO b) -> IO b
{#pointer *generic_error_t as GenericError foreign newtype#}

requestCheck :: Connection -> Cookie -> IO (Maybe GenericError)
requestCheck c cookie
    = withConnection c $ \cPtr -> do
      errPtr <- xcb_request_check cPtr cookie
      if errPtr == nullPtr then return Nothing else do
      Just . GenericError <$> newForeignPtr finalizerFree errPtr

foreign import ccall xcb_request_check :: Ptr Connection -> Cookie -> IO (Ptr GenericError)

-- | The returned ByteString is aliased to the same memory
-- location as the GenericError.
unsafeErrorData :: GenericError -> IO S.ByteString
unsafeErrorData (GenericError errFPtr) =
    return $ S.fromForeignPtr (castForeignPtr errFPtr) 0 32

-- Replies
withGenericReply :: GenericReply -> (Ptr GenericReply -> IO b) -> IO b
{#pointer *generic_reply_t as GenericReply foreign newtype#}

-- | Returns the length of the reply in units of four bytes
replyLength :: GenericReply -> IO Word32
replyLength rep = withGenericReply rep $ \repPtr -> do
                  lenField <- fromIntegral <$> {#get generic_reply_t->length#} repPtr
                  return $ lenField + 1 -- for the inserted full_sequence field

instance HasResponseType GenericReply where
    responseType = replyResponseType

replyResponseType :: GenericReply -> IO Int
replyResponseType rep = withGenericReply rep $ \repPtr ->
                        fromIntegral <$> {#get generic_reply_t->response_type#} repPtr

-- | Unchecked conversion
unsafeReplyToError :: GenericReply -> GenericError
unsafeReplyToError (GenericReply rep) = GenericError . castForeignPtr $ rep

-- | The returned ByteString is aliased to the same memory
-- location as the 'GenericReply'
unsafeReplyData :: GenericReply -> IO S.ByteString
unsafeReplyData rep@(GenericReply repFPtr) = do
  len <- fromIntegral <$> replyLength rep
  return $ S.fromForeignPtr (castForeignPtr repFPtr) 0 (4*len)

-- Sending requests
withRequestInfo :: RequestInfo -> (Ptr RequestInfo -> IO b) -> IO b
{#pointer *protocol_request_t as RequestInfo foreign newtype#}

mkRequestInfo :: (Maybe Extension) -> CUInt -> Bool -> IO RequestInfo
mkRequestInfo ext opcode isVoid = do
      fptr <- mallocForeignPtrBytes {#sizeof protocol_request_t#}
      withForeignPtr fptr $ \rptr -> do
        {#set protocol_request_t->ext#} rptr $ maybe (Extension nullPtr) id ext
        {#set protocol_request_t->opcode#} rptr (fromIntegral opcode)
        {#set protocol_request_t->isvoid#} rptr (fromBool isVoid)
      return $ RequestInfo fptr

{#enum send_request_flags_t as RequestFlags {underscoreToCase} deriving(Eq, Show)#}

-- |Note: the 'count' field in the request info is always
-- over-written to the number of chunks in the ByteString
sendRequest :: Connection -> Int -> L.ByteString -> RequestInfo -> IO Cookie
sendRequest c flags bytes rInfo
    = withConnection c $ \cPtr ->
      withRequestInfo rInfo $ \rPtr ->
      withLazyByteString bytes $ \vec vecNum ->
      withIOVec vec $ \vecPtr -> do
      {#set protocol_request_t->count#} rPtr (fromIntegral vecNum)
      Cookie . fromIntegral <$> {#call send_request#} cPtr (fromIntegral flags) (castPtr vecPtr) rPtr

-- | Return 'Nothing' on failure, or the last request id on success.
-- This must be called before calling 'writev', as it indicates that you would
-- like full control of the write end of the connection socket.
takeSocket :: Connection
           -> FunPtr (Ptr () -> IO ())  -- ^ Callback to return socket
           -> Ptr ()                    -- ^ Callback argument
           -> Int                       -- ^ Request flags
           -> IO (Maybe Word64)
takeSocket c fn fnArg flags
    = withConnection c $ \cPtr ->
      alloca $ \countPtr -> do
      ret <- toBool <$> {#call take_socket#} cPtr fn fnArg (fromIntegral flags) countPtr
      countOpt <- if ret then Just . fromIntegral <$> peek countPtr else return Nothing
      return countOpt

-- | Write raw bytes to the connection socket. The count parameter
-- indicates the number of requests in this call. It is assumed
-- that 'takeSocket' has been called prior to calling this. We force the
-- spine of the lazy bytestring argument before consuming it, so watch
-- out for that.
writev :: Connection -> L.ByteString -> Word64 -> IO Bool
writev c bytes reqCount
    = withConnection c $ \cPtr ->
      withLazyByteString bytes $ \vec vecNum ->
      withIOVec vec $ \vecPtr ->
      toBool <$> {#call xcb_writev#} cPtr (castPtr vecPtr) (fromIntegral vecNum) (fromIntegral reqCount)

waitForReply :: Connection -> Cookie -> IO (Either GenericError GenericReply)
waitForReply c (Cookie request) =
    withConnection c $ \cPtr ->
    alloca $ \errPtrPtr -> do
    repPtr <- {#call wait_for_reply#} cPtr (fromIntegral request) errPtrPtr
    if repPtr == nullPtr then do
        errPtr <- peek errPtrPtr
        errFPtr <- newForeignPtr finalizerFree errPtr
        return . Left . GenericError $ errFPtr
     else do
       repFPtr <- newForeignPtr finalizerFree $ castPtr repPtr
       return . Right . GenericReply $ repFPtr

-- Other
generateId :: Connection -> IO Word32
generateId c = withConnection c $ \cPtr ->
               fromIntegral <$> {#call generate_id#} cPtr

-- Internal utils

-- | Create a 'Connection' from a reference.
-- The connection will be shut down when it goes out of scope.
mkConnection :: Ptr Connection -> IO Connection
mkConnection = liftM Connection . newForeignPtr finalizerDisconnect

-- | Creates a connection from an unsafe reference,
-- with no asociated finalzer.
-- Only use this if the Haskell code does not own the connection.
mkConnection_ :: Ptr Connection -> IO Connection
mkConnection_ = liftM Connection . newForeignPtr_

-- | A finalizer for a Ptr Connection which shuts down the connection
-- and frees all resources associated with it.
finalizerDisconnect :: FinalizerPtr Connection
finalizerDisconnect = xcb_disconnect

foreign import ccall "&xcb_disconnect" xcb_disconnect :: FunPtr (Ptr Connection -> IO ())

-- -*-haskell-*-

{-# LANGUAGE
   StandaloneDeriving
  ,GeneralizedNewtypeDeriving
  #-}

module Graphics.X11.Xcb.Internal where

import Control.Applicative
import Control.Monad
import Foreign
import Foreign.C.String
import Foreign.C.Types

import qualified Data.ByteString as S
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Lazy as L

{#import Foreign.IOVec#}

#include <xcb/xcb.h>
#include <xcb/xcbext.h>

peekIntConv
    :: (Integral a, Num b, Storable a)
       => Ptr a -> IO b
peekIntConv ptr = fromIntegral `liftM` peek ptr

{-
  Welcome to my sometimes-dodgy FFI bindings to XCB.
  The idea isn't really to write something to directly
  write X apps with, but to write a foundation for
  something higher-level and safer.

  So referential transparency can definetly be abused
  with a lot of the calls in here.

  So don't do it.
 -}

{#context lib="xcb" prefix="xcb_"#}

withConnection :: Connection -> (Ptr Connection -> IO b) -> IO b
{#pointer *connection_t as Connection foreign newtype#}
{#pointer *setup_t as Setup newtype#} -- no finalizer, part of the Connection

-- | Returns a connection to the indicated X server, as well
-- as the screen connected to.
-- The passed in string may be null, in which case
-- it will be the same as passing in the DISPLAY environment
-- variable.
connect :: String -> IO (Maybe (Connection, Int))
connect display
    = withCString display $ \displayPtr ->
      alloca $ \screenPtr -> do

      cPtr <- {#call connect as connect_#} displayPtr screenPtr
      screen <- peekIntConv screenPtr

      if cPtr == nullPtr then return Nothing else do

      c <- mkConnection cPtr
      return $ Just (c, screen)

-- | Parse the host, display and screen from a string.
-- The same as what we would do if the string were
-- passed to 'connect'.
parseDisplay :: String -> IO (Maybe (String, Int, Int))
parseDisplay display
    = withCString display $ \displayPtr ->
      alloca $ \hostStringPtr ->
      alloca $ \displayNumPtr ->
      alloca $ \screenPtr -> do
      success <- liftM toBool $
                 {#call unsafe parse_display#} displayPtr hostStringPtr displayNumPtr screenPtr
      if not success then return Nothing else do

      host <- peek hostStringPtr >>= peekCString
      peek hostStringPtr >>= free

      displayNum <- peekIntConv displayNumPtr
      screen <- peekIntConv screenPtr

      return $ Just (host, displayNum, screen)

-- | Flush the write buffers.
flush :: Connection -> IO Bool
flush c = withConnection c $ \cPtr ->
          liftM toBool $ {#call flush as flush_#} cPtr

-- | The memory backing this data structure is owned
-- by the passed in Connection - and will magicaly vanish
-- if your 'Connection' gets GCd before the return value
-- of this function.  Watch out.
unsafeGetSetup :: Connection -> IO Setup
unsafeGetSetup c = withConnection c $ \cPtr ->
                   {#call unsafe get_setup#} cPtr

-- | Length of the setup data in units of four bytes.
setupLength :: Setup -> IO Word16
setupLength (Setup s) = liftM fromIntegral $ {#get setup_t->length#} s

-- | This ByteString is just as unsafe as the passed in connection
-- object.  Please make a copy.
unsafeSetupData :: Setup -> IO S.ByteString
unsafeSetupData s@(Setup sPtr) = do
  len <- liftM (4*) $ setupLength s
  sFPtr <- newForeignPtr_ sPtr
  return $ S.fromForeignPtr (castForeignPtr sFPtr) 0 (fromIntegral len)

-- | Maximum size of a single request.
-- May not be an asynchronous call, as we'll make a call out
-- on the big-requests extension to find out if we can use that.
maximumRequestLength :: Connection -> IO Word32
maximumRequestLength c = withConnection c $ \cPtr ->
                         liftM fromIntegral $ {#call get_maximum_request_length#} cPtr

-- | Asynchronous version of 'maximumRequestLength'.  The return
-- from the server is cached for subsequent callse to 'maximumRequestLength'.
prefetchMaximumReuestLength :: Connection -> IO ()
prefetchMaximumReuestLength c = withConnection c $ \cPtr ->
                                {#call prefetch_maximum_request_length#} cPtr

-- | Is the connection in an error state?
connectionHasError :: Connection -> IO Bool
connectionHasError c = withConnection c $ \cPtr ->
                       liftM toBool $ {#call connection_has_error#} cPtr

newtype Cookie = Cookie CUInt

-- Working with extensions
{#pointer *extension_t as Extension newtype#} -- static data, no finalizer

-- :-(
instance Storable Extension where
    sizeOf (Extension ex) = sizeOf ex
    alignment (Extension ex) = alignment ex
    peekElemOff ptr off = liftM Extension $ peekElemOff (castPtr ptr) off
    pokeElemOff ptr off (Extension ex) = pokeElemOff (castPtr ptr) off ex
    peekByteOff ptr off = liftM Extension $ peekByteOff ptr off
    pokeByteOff ptr off (Extension ex) = pokeByteOff ptr off ex
    peek ptr = liftM Extension $ peek (castPtr ptr)
    poke ptr (Extension ex) = poke (castPtr ptr) ex

{#pointer *query_extension_reply_t as ExtensionInfo newtype#} -- freed with Connection, no finalizer

-- | May block if the data is not already cached.  For internal
-- use only - make a copy if you need something that will live
-- longer than the scope of the connection.
unsafeGetExtensionData :: Connection -> Extension -> IO ExtensionInfo
unsafeGetExtensionData c ext
    = withConnection c $ \cPtr ->
      {#call get_extension_data#} cPtr ext

extensionPresent :: ExtensionInfo -> IO Bool
extensionPresent (ExtensionInfo ext)
    = liftM toBool $ {#get query_extension_reply_t->present#} ext

extensionMajorOpcode :: ExtensionInfo -> IO Word8
extensionMajorOpcode (ExtensionInfo ext)
    = liftM fromIntegral $ {#get query_extension_reply_t->major_opcode#} ext

extensionFirstEvent :: ExtensionInfo -> IO Word8
extensionFirstEvent (ExtensionInfo ext)
    = liftM fromIntegral $ {#get query_extension_reply_t->first_event#} ext

extensionFirstError :: ExtensionInfo -> IO Word8
extensionFirstError (ExtensionInfo ext)
    = liftM fromIntegral $ {#get query_extension_reply_t->first_error#} ext

-- | Non-blocking query for extension data
prefetchExtension :: Connection -> Extension -> IO ()
prefetchExtension c ext
    = withConnection c $ \cPtr ->
      {#call prefetch_extension_data#} cPtr ext

class HasResponseType a where
    responseType :: a -> IO Int

isBigEvent :: HasResponseType a => a -> IO Bool
isBigEvent ev = (== 35) `liftM` responseType ev

isError :: HasResponseType a => a -> IO Bool
isError ev = (== 2) `liftM` responseType ev

-- Events
withGenericEvent :: GenericEvent -> (Ptr GenericEvent -> IO b) -> IO b
{#pointer *generic_event_t as GenericEvent foreign newtype#}
withGenericBigEvent :: GenericBigEvent -> (Ptr GenericBigEvent -> IO b) -> IO b
{#pointer *ge_event_t as GenericBigEvent foreign newtype#}

-- | The XCB documentation seems to imply that this can also return
-- errors, so be careful.
waitForEvent :: Connection -> IO GenericEvent
waitForEvent c = withConnection c $ \cPtr -> do
                 evPtr <- {#call wait_for_event#} cPtr
                 liftM GenericEvent $ newForeignPtr finalizerFree evPtr

instance HasResponseType GenericEvent where
    responseType = eventResponseType

eventResponseType :: GenericEvent -> IO Int
eventResponseType ev = withGenericEvent ev $ \evPtr ->
                       liftM fromIntegral $ {#get generic_event_t->response_type#} evPtr

-- | The conversion is not checked.
unsafeToBigEvent :: GenericEvent -> GenericBigEvent
unsafeToBigEvent (GenericEvent ev) = GenericBigEvent . castForeignPtr $ ev

-- | The conversion is not checked.
unsafeToError :: GenericEvent -> GenericError
unsafeToError (GenericEvent ev) = GenericError . castForeignPtr $ ev

-- | In units of four bytes.  Extra +1 for the 'full_sequence' field
-- introduced when XCB decodes from the wire.
bigEventLength :: GenericBigEvent -> IO Word32
bigEventLength bge = withGenericBigEvent bge $ \bgePtr -> do
                     lenField <- fromIntegral `liftM` {#get ge_event_t->length#} bgePtr
                     return $ 8 + 1 + lenField

-- | Unsafe in that referential transperency may be broken -
-- the ByteString is aliased to the same memory location as the
-- the event.
unsafeEventData :: GenericEvent -> IO S.ByteString
unsafeEventData ge = do
  isErr <- isError ge
  if isErr then unsafeErrorData (unsafeToError ge) else do

  isBig <- isBigEvent ge
  if isBig
     then do
       let bge@(GenericBigEvent bgeFPtr) = unsafeToBigEvent ge
       len <- bigEventLength bge
       return $ S.fromForeignPtr (castForeignPtr bgeFPtr) 0 (4 * fromIntegral len)
     else
       let GenericEvent evFPtr = ge
       in return $ S.fromForeignPtr (castForeignPtr evFPtr) 0 32

-- Errors
withGenericError :: GenericError -> (Ptr GenericError -> IO b) -> IO b
{#pointer *generic_error_t as GenericError foreign newtype#}

requestCheck :: Connection -> Cookie -> IO (Maybe GenericError)
requestCheck c cookie
    = withConnection c $ \cPtr -> do
      errPtr <- xcb_request_check cPtr cookie
      if errPtr == nullPtr then return Nothing else do
      liftM (Just . GenericError) $ newForeignPtr finalizerFree errPtr

foreign import ccall xcb_request_check :: Ptr Connection -> Cookie -> IO (Ptr GenericError)

-- | The returned ByteString is aliased to the same memory
-- location as the GenericError.
unsafeErrorData :: GenericError -> IO S.ByteString
unsafeErrorData (GenericError errFPtr) =
    return $ S.fromForeignPtr (castForeignPtr errFPtr) 0 32

-- Replies
withGenericReply :: GenericReply -> (Ptr GenericReply -> IO b) -> IO b
{#pointer *generic_reply_t as GenericReply foreign newtype#}

-- | Returns the length of the reply in units of four bytes
replyLength :: GenericReply -> IO Word32
replyLength rep = withGenericReply rep $ \repPtr -> do
                  lenField <- liftM fromIntegral $ {#get generic_reply_t->length#} repPtr
                  return $ lenField + 1 -- for the inserted full_sequence field

instance HasResponseType GenericReply where
    responseType = replyResponseType

replyResponseType :: GenericReply -> IO Int
replyResponseType rep = withGenericReply rep $ \repPtr ->
                        liftM fromIntegral $ {#get generic_reply_t->response_type#} repPtr

-- | Unchecked conversion
unsafeReplyToError :: GenericReply -> GenericError
unsafeReplyToError (GenericReply rep) = GenericError . castForeignPtr $ rep

-- | The returned ByteString is aliased to the same memory
-- location as the 'GenericReply'
unsafeReplyData :: GenericReply -> IO S.ByteString
unsafeReplyData rep@(GenericReply repFPtr) = do
  len <- fromIntegral `liftM` replyLength rep
  return $ S.fromForeignPtr (castForeignPtr repFPtr) 0 (4*len)

-- Sending requests
withRequestInfo :: RequestInfo -> (Ptr RequestInfo -> IO b) -> IO b
{#pointer *protocol_request_t as RequestInfo foreign newtype#}

mkRequestInfo :: (Maybe Extension) -> CUInt -> Bool -> IO RequestInfo
mkRequestInfo ext opcode isVoid = do
      fptr <- mallocForeignPtrBytes {#sizeof protocol_request_t#}
      withForeignPtr fptr $ \rptr -> do
        {#set protocol_request_t->ext#} rptr $ maybe (Extension nullPtr) id ext
        {#set protocol_request_t->opcode#} rptr (fromIntegral opcode)
        {#set protocol_request_t->isvoid#} rptr (fromBool isVoid)
      return $ RequestInfo fptr

{#enum send_request_flags_t as RequestFlags {underscoreToCase} deriving(Eq, Show)#}

-- |Note: the 'count' field in the request info is always
-- over-written to the number of chunks in the ByteString
sendRequest :: Connection -> Int -> L.ByteString -> RequestInfo -> IO Cookie
sendRequest c flags bytes rInfo
    = withConnection c $ \cPtr ->
      withRequestInfo rInfo $ \rPtr ->
      withLazyByteString bytes $ \vec vecNum ->
      withIOVec vec $ \vecPtr -> do
      {#set protocol_request_t->count#} rPtr (fromIntegral vecNum)
      liftM (Cookie . fromIntegral) $ {#call send_request#} cPtr (fromIntegral flags) (castPtr vecPtr) rPtr

-- | Return 'Nothing' on failure, or the last request id on success.
-- This must be called before calling 'writev', as it indicates that you would
-- like full control of the write end of the connection socket.
takeSocket :: Connection
           -> FunPtr (Ptr () -> IO ())  -- ^ Callback to return socket
           -> Ptr ()                    -- ^ Callback argument
           -> Int                       -- ^ Request flags
           -> IO (Maybe Word64)
takeSocket c fn fnArg flags
    = withConnection c $ \cPtr ->
      alloca $ \countPtr -> do
      ret <- toBool <$> {#call take_socket#} cPtr fn fnArg (fromIntegral flags) countPtr
      countOpt <- if ret then Just . fromIntegral <$> peek countPtr else return Nothing
      return countOpt

-- | Write raw bytes to the connection socket. The count parameter
-- indicates the number of requests in this call. It is assumed
-- that 'takeSocket' has been called prior to calling this. We force the
-- spine of the lazy bytestring argument before consuming it, so watch
-- out for that.
writev :: Connection -> L.ByteString -> Word64 -> IO Bool
writev c bytes reqCount
    = withConnection c $ \cPtr ->
      withLazyByteString bytes $ \vec vecNum ->
      withIOVec vec $ \vecPtr ->
      toBool <$> {#call xcb_writev#} cPtr (castPtr vecPtr) (fromIntegral vecNum) (fromIntegral reqCount)

waitForReply :: Connection -> Cookie -> IO (Either GenericError GenericReply)
waitForReply c (Cookie request) =
    withConnection c $ \cPtr ->
    alloca $ \errPtrPtr -> do
    repPtr <- {#call wait_for_reply#} cPtr (fromIntegral request) errPtrPtr
    if repPtr == nullPtr then do
        errPtr <- peek errPtrPtr
        errFPtr <- newForeignPtr finalizerFree errPtr
        return . Left . GenericError $ errFPtr
     else do
       repFPtr <- newForeignPtr finalizerFree $ castPtr repPtr
       return . Right . GenericReply $ repFPtr

-- Other
generateId :: Connection -> IO Word32
generateId c = withConnection c $ \cPtr ->
               liftM fromIntegral $ {#call generate_id#} cPtr

-- Internal utils

-- | Create a 'Connection' from a reference.
-- The connection will be shut down when it goes out of scope.
mkConnection :: Ptr Connection -> IO Connection
mkConnection = liftM Connection . newForeignPtr finalizerDisconnect

-- | Creates a connection from an unsafe reference,
-- with no asociated finalzer.
-- Only use this if the Haskell code does not own the connection.
mkConnection_ :: Ptr Connection -> IO Connection
mkConnection_ = liftM Connection . newForeignPtr_

-- | A finalizer for a Ptr Connection which shuts down the connection
-- and frees all resources associated with it.
finalizerDisconnect :: FinalizerPtr Connection
finalizerDisconnect = xcb_disconnect

foreign import ccall "&xcb_disconnect" xcb_disconnect :: FunPtr (Ptr Connection -> IO ())