parentObjID

parentObjID

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

#include "git2.h"

module Git2 where

import Data.ByteString
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

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

{-
/**
 * Get the id of the tree pointed to by a commit. This differs from
 * `git_commit_tree` in that no attempts are made to fetch an object
 * from the ODB.
 *
 * @param commit a previously loaded commit.
 * @return the id of tree pointed to by commit.
 */
GIT_EXTERN(const git_oid *) git_commit_tree_oid(git_commit *commit);

/**
 * Get the number of parents of this commit
 *
 * @param commit a previously loaded commit.
 * @return integer of count of parents
 */
GIT_EXTERN(unsigned int) git_commit_parentcount(git_commit *commit);
-}

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

{-
/**
 * Create a new commit in the repository using `git_object`
 * instances as parameters.
 *
 * @param oid Pointer where to store the OID of the
 *	newly created commit
 *
 * @param repo Repository where to store the commit
 *
 * @param update_ref If not NULL, name of the reference that
 *	will be updated to point to this commit. If the reference
 *	is not direct, it will be resolved to a direct reference.
 *	Use "HEAD" to update the HEAD of the current branch and
 *	make it point to this commit
 *
 * @param author Signature representing the author and the authory
 *	time of this commit
 *
 * @param committer Signature representing the committer and the
 *  commit time of this commit
 *
 * @param message Full message for this commit
 *
 * @param tree An instance of a `git_tree` object that will
 * be used as the tree for the commit. This tree object must
 * also be owned by the given `repo`.
 *
 * @param parent_count Number of parents for this commit
 *
 * @param parents[] Array of `parent_count` pointers to `git_commit`
 * objects that will be used as the parents for this commit. This
 * array may be NULL if `parent_count` is 0 (root commit). All the
 * given commits must be owned by the `repo`.
 *
 * @return 0 on success; error code otherwise
 *	The created commit will be written to the Object Database and
 *	the given reference will be updated to point to it
 */
GIT_EXTERN(int) git_commit_create(
		git_oid *oid,
		git_repository *repo,
		const char *update_ref,
		const git_signature *author,
		const git_signature *committer,
		const char *message,
		const git_tree *tree,
		int parent_count,
		const git_commit *parents[]);

/**
 * Create a new commit in the repository using a variable
 * argument list.
 *
 * The parents for the commit are specified as a variable
 * list of pointers to `const git_commit *`. Note that this
 * is a convenience method which may not be safe to export
 * for certain languages or compilers
 *
 * All other parameters remain the same
 *
 * @see git_commit_create
 */
GIT_EXTERN(int) git_commit_create_v(
		git_oid *oid,
		git_repository *repo,
		const char *update_ref,
		const git_signature *author,
		const git_signature *committer,
		const char *message,
		const git_tree *tree,
		int parent_count,
		...);
-}

-------------------------------------------------------------------------------
-- END: commit.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.ByteString
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

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

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

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

{-
/**
 * Get the id of the tree pointed to by a commit. This differs from
 * `git_commit_tree` in that no attempts are made to fetch an object
 * from the ODB.
 *
 * @param commit a previously loaded commit.
 * @return the id of tree pointed to by commit.
 */
GIT_EXTERN(const git_oid *) git_commit_tree_oid(git_commit *commit);

/**
 * Get the number of parents of this commit
 *
 * @param commit a previously loaded commit.
 * @return integer of count of parents
 */
GIT_EXTERN(unsigned int) git_commit_parentcount(git_commit *commit);
-}

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

{-
/**
 * Get the oid of a specified parent for a commit. This is different from
 * `git_commit_parent`, which will attempt to load the parent commit from
 * the ODB.
 *
 * @param commit a previously loaded commit.
 * @param n the position of the parent (from 0 to `parentcount`)
 * @return the id of the parent, NULL on error.
 */
GIT_EXTERN(const git_oid *) git_commit_parent_oid(git_commit *commit, unsigned int n);

/**
 * Create a new commit in the repository using `git_object`
 * instances as parameters.
 *
 * @param oid Pointer where to store the OID of the
 *	newly created commit
 *
 * @param repo Repository where to store the commit
 *
 * @param update_ref If not NULL, name of the reference that
 *	will be updated to point to this commit. If the reference
 *	is not direct, it will be resolved to a direct reference.
 *	Use "HEAD" to update the HEAD of the current branch and
 *	make it point to this commit
 *
 * @param author Signature representing the author and the authory
 *	time of this commit
 *
 * @param committer Signature representing the committer and the
 *  commit time of this commit
 *
 * @param message Full message for this commit
 *
 * @param tree An instance of a `git_tree` object that will
 * be used as the tree for the commit. This tree object must
 * also be owned by the given `repo`.
 *
 * @param parent_count Number of parents for this commit
 *
 * @param parents[] Array of `parent_count` pointers to `git_commit`
 * objects that will be used as the parents for this commit. This
 * array may be NULL if `parent_count` is 0 (root commit). All the
 * given commits must be owned by the `repo`.
 *
 * @return 0 on success; error code otherwise
 *	The created commit will be written to the Object Database and
 *	the given reference will be updated to point to it
 */
GIT_EXTERN(int) git_commit_create(
		git_oid *oid,
		git_repository *repo,
		const char *update_ref,
		const git_signature *author,
		const git_signature *committer,
		const char *message,
		const git_tree *tree,
		int parent_count,
		const git_commit *parents[]);

/**
 * Create a new commit in the repository using a variable
 * argument list.
 *
 * The parents for the commit are specified as a variable
 * list of pointers to `const git_commit *`. Note that this
 * is a convenience method which may not be safe to export
 * for certain languages or compilers
 *
 * All other parameters remain the same
 *
 * @see git_commit_create
 */
GIT_EXTERN(int) git_commit_create_v(
		git_oid *oid,
		git_repository *repo,
		const char *update_ref,
		const git_signature *author,
		const git_signature *committer,
		const char *message,
		const git_tree *tree,
		int parent_count,
		...);
-}

-------------------------------------------------------------------------------
-- END: commit.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

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

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


Trivial tidyup of export list in GConfValue.chs

By using this style:
GConfValueClass(marshalFromGConfValue, marshalToGConfValue)
rather than
GConfValueClass, marshalFromGConfValue, marshalToGConfValue
Haddock will document the classes member functions better. Otherwise they
get documented as visible members of the class and separately as ordinary top
level exported functions.

darcs-hash:20060122122524-b4c10-2f8a218bed5b60e270c534df466b85b74119cd97.gz

{-# OPTIONS -fallow-overlapping-instances #-} -- String & [a] overlap
-- -*-haskell-*-
-- GIMP Toolkit (GTK) GConf API
--
--  Author : Duncan Coutts
--  Created: 16 April 2004
--
--  Copyright (c) 2004 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
--  |
--
--  Module for dealing with the values stored in the GConf system.
--
--  GConfValue has its own primitive type system which is represented in
--  Haskell using type classes. This allows values to be get and set without
--  needing to perform any dynamic type casting or needing a union type.
--
--  Alternatively, a dynamic\/union type is provided for the rare occasions
--  when that degree of flexability is required. It should only be necessary
--  if you need to deal with configuration values without statically knowing
--  their type.
--

module System.Gnome.GConf.GConfValue (
 GConfPrimitiveValueClass,
 GConfValueClass(marshalFromGConfValue, marshalToGConfValue),
 GConfValue(GConfValue),
 GConfValueDyn(..),
 ) where

import Monad (liftM, when)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GList (toGSList, readGSList)

--{# context lib="gconf" prefix ="gconf_value" #}
{# context lib="gconf" #}

{# enum GConfValueType {underscoreToCase} deriving (Eq, Show) #}

{# pointer *GConfValue newtype #}

-- | Class of types which can be kept by GConf
class GConfValueClass value where
  --unsafe because assumes non-null pointer and correct type
  unsafeMarshalFromGConfValue :: GConfValue -> IO value

  -- safe checked version, may throw exception
  marshalFromGConfValue :: GConfValue -> IO value
  marshalFromGConfValue value = do
    checkForNullAndExpectedType (typeofGConfValue (undefined::value)) value
    unsafeMarshalFromGConfValue value

  typeofGConfValue :: value -> GConfValueType

  marshalToGConfValue :: value -> IO GConfValue

-- The above methods follow the following memory management rules regarding
-- GConfValues: marshalFrom reads the value but does not gain ownership and thus
-- does not deallocate. marshalTo allocates a new value and gives up ownership;
-- it is not responsible for dellocation (it does not attach a finaliser).
-- The code that uses marshalTo must ensure that it hands the value off to a
-- function that is prepared to asume ownership of the value.

-- | Dynamic version for when the type is not known statically.
data GConfValueDyn = GConfValueString String
                   | GConfValueInt Int
                   | GConfValueFloat Double
                   | GConfValueBool Bool
                   | GConfValueSchema               -- ^ Not supported
                   | GConfValueList [GConfValueDyn] -- ^ Must all be of same primitive type
                   | GConfValuePair (GConfValueDyn, GConfValueDyn) -- ^ Must both be primitive

-- Allow variant using Maybe, where Nothing means the value was not set
-- Use this variant when you expect the gconf key to not be set somethimes;
-- otherwise the 'raw' types will raise an exception if you get an unset key.
-- Just for consistency, setting a key to Nothing will unset the key, however
-- it is preferable to use gconfClientUnset explicitly.
instance GConfValueClass value => GConfValueClass (Maybe value) where
  typeofGConfValue _ = typeofGConfValue (undefined :: value)
  unsafeMarshalFromGConfValue = marshalFromGConfValue
  marshalFromGConfValue value =
    catch (liftM Just $ marshalFromGConfValue value)
          (\_ -> return Nothing)
  marshalToGConfValue (Just v) = marshalToGConfValue v
  marshalToGConfValue Nothing  = return $ GConfValue nullPtr

-- The GConfValue type system says some types are primitive.
-- Compound types (lists & pairs) may only be constructed from primitive types.
class GConfValueClass value => GConfPrimitiveValueClass value
instance GConfPrimitiveValueClass Int
instance GConfPrimitiveValueClass Bool
instance GConfPrimitiveValueClass Double
instance GConfPrimitiveValueClass String

instance GConfValueClass Int where
  typeofGConfValue _ = GconfValueInt
  unsafeMarshalFromGConfValue = liftM fromIntegral . {# call unsafe gconf_value_get_int #}
  marshalToGConfValue n = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueInt)
    {# call unsafe gconf_value_set_int #} (GConfValue value) (fromIntegral n)
    return (GConfValue value)

instance GConfValueClass Bool where
  typeofGConfValue _ = GconfValueBool
  unsafeMarshalFromGConfValue = liftM toBool . {# call unsafe gconf_value_get_bool #}
  marshalToGConfValue b = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueBool)
    {# call unsafe gconf_value_set_bool #} (GConfValue value) (fromBool b)
    return (GConfValue value)

instance GConfValueClass Double where
  typeofGConfValue _ = GconfValueFloat
  unsafeMarshalFromGConfValue = liftM realToFrac . {# call unsafe gconf_value_get_float #}
  marshalToGConfValue f = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueFloat)
    {# call unsafe gconf_value_set_float #} (GConfValue value) (realToFrac f)
    return (GConfValue value)

-- Now unfortunately String & [a] overlap, although really they don't since Char
-- is not an instance of GConfPrimitiveValueClass, however classes are open so
-- we don't know that Char would never be an instance. I want closed classes!
instance GConfValueClass String where
  typeofGConfValue _ = GconfValueString

  unsafeMarshalFromGConfValue value = do
    strPtr <- {# call unsafe gconf_value_get_string #} value
    peekUTFString strPtr

  marshalToGConfValue s = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueString)
    withCString s $ \strPtr ->
      {# call unsafe gconf_value_set_string #} (GConfValue value) strPtr
    return (GConfValue value)

instance (GConfPrimitiveValueClass a, GConfPrimitiveValueClass b) => GConfValueClass (a,b) where
  typeofGConfValue _ = GconfValuePair

  unsafeMarshalFromGConfValue value = do
    a <- {# call unsafe gconf_value_get_car #} value
    b <- {# call unsafe gconf_value_get_cdr #} value
    a' <- marshalFromGConfValue (GConfValue a)
    b' <- marshalFromGConfValue (GConfValue b)
    return (a',b')

  marshalToGConfValue (a,b) = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValuePair)
    a' <- marshalToGConfValue a
    b' <- marshalToGConfValue b
    {# call unsafe gconf_value_set_car_nocopy #} (GConfValue value) a'
    {# call unsafe gconf_value_set_cdr_nocopy #} (GConfValue value) b'
    return (GConfValue value)

instance GConfPrimitiveValueClass a => GConfValueClass [a] where
  typeofGConfValue _ = GconfValueList

  unsafeMarshalFromGConfValue value = do
    gsList <- {# call unsafe gconf_value_get_list #} value
    valuesPtrs <- readGSList gsList
    mapM (unsafeMarshalFromGConfValue . GConfValue) valuesPtrs

  marshalFromGConfValue value = do
    checkForNullAndExpectedType GconfValueList value
    listType <- liftM (toEnum . fromIntegral) $
                {# call unsafe gconf_value_get_list_type #} value
    when (listType /= typeofGConfValue (undefined :: a))
         (fail "GConf: key is list with elements of unexpected type")
    unsafeMarshalFromGConfValue value

  marshalToGConfValue list = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueList)
    valuesPtrs <- mapM (liftM (\(GConfValue ptr) -> ptr) . marshalToGConfValue) list
    valuesList <- toGSList valuesPtrs
    {# call unsafe gconf_value_set_list_type #} (GConfValue value)
      (fromIntegral $ fromEnum $ typeofGConfValue (undefined::a))
    {# call unsafe gconf_value_set_list_nocopy #} (GConfValue value) valuesList
    return (GConfValue value)

----------------
-- For convenience and best practice, an instance for Enum
-- This conforms to the GConf GTK+/Gnome convention for storing enum types,
-- which is to store them as a string using ThisStlyeOfCapitalisation.

-- Note: currently disabled since it requires -fallow-undecidable-instances
{-
instance (Show enum, Read enum, Enum enum, GConfValueClass enum)
      => GConfPrimitiveValueClass enum
instance (Show enum, Read enum, Enum enum) => GConfValueClass enum where
  marshalFromGConfValue value = do
    enumStr <- marshalFromGConfValue value
    case reads enumStr of
      [(enum,_)] -> return enum
      _          -> fail "GCconf: invalid enum value"
  marshalFromGConfValue' value = do
    maybeEnumStr <- marshalFromGConfValue' value
    case maybeEnumStr of
      Nothing -> return Nothing
      (Just enumStr) -> case reads enumStr of
                          [(enum,_)] -> return (Just enum)
                          _          -> return Nothing
  marshalToGConfValue enum = marshalToGConfValue (show enum)
  typeofGConfValue _ = GconfValueString
-}

----------------
-- Helper funcs

gconfValueGetType :: GConfValue ->  IO GConfValueType
--we mean the following but unfortunately c2hs barfs on 'type'
--gconfValueGetType (GConfValue valuePtr) = {# get GConfValue->type #} valuePtr
-- so instead we have the ugly:
gconfValueGetType (GConfValue valuePtr) =
  liftM (toEnum . fromIntegral) $ peek (castPtr valuePtr :: Ptr CInt)
--TODO: check that sizeof(GConfValueType) == sizeof(int)

-- returns Nothing if ok, or and error message
checkForNullAndExpectedType :: GConfValueType -> GConfValue -> IO ()
checkForNullAndExpectedType expectedType value@(GConfValue ptr)
 | ptr == nullPtr = fail "GConf: cannot get value of key, key is unset"
 | otherwise = do valueType <- gconfValueGetType value
                  when (valueType /= expectedType)
                       (fail $ "GConf: key is of unexpected type, expected: "
                          ++ show expectedType ++ ", got: " ++ show valueType)

{-
checkForNullAndExpectedType :: GConfValueType -> GConfValue -> IO GConfValue
checkForNullAndExpectedType expectedType value@(GConfValue ptr)
 | ptr == nullPtr = fail "GConf: cannot get value of key, key is unset"
 | otherwise = do valueType <- gconfValueGetType value
                  if valueType /= expectedType
                    then fail $ "GConf: key is of unexpected type, expected: "
                             ++ show expectedType ++ ", got: " ++ show valueType
                    else return value

checkForNullAndExpectedType' :: GConfValueType -> GConfValue -> IO (Maybe GConfValue)
checkForNullAndExpectedType' expectedType value@(GConfValue ptr)
 | ptr == nullPtr = return Nothing
 | otherwise = do valueType <- gconfValueGetType value
                  if valueType /= expectedType
                    then return Nothing
                    else return (Just value)
-}
----------------
-- GConfValueDyn

unsafeMarshalGConfValueDynListFromGConfValue :: GConfValue -> IO [GConfValueDyn]
unsafeMarshalGConfValueDynListFromGConfValue value = do
  gsList <- {# call unsafe gconf_value_get_list #} value
  valuesPtrs <- readGSList gsList
  mapM (unsafeMarshalFromGConfValue . GConfValue) valuesPtrs

marshalGConfValueDynListToGConfValue :: [GConfValueDyn] -> IO GConfValue
marshalGConfValueDynListToGConfValue as = do
  value <- {# call unsafe gconf_value_new #}
    (fromIntegral $ fromEnum GconfValueList)
  valuesPtrs <- mapM (liftM (\(GConfValue ptr) -> ptr) . marshalToGConfValue) as
  valuesList <- toGSList valuesPtrs
  {# call unsafe gconf_value_set_list_type #} (GConfValue value)
    (fromIntegral $ fromEnum $ (case as of
                                  []    -> GconfValueInvalid  --unknown type
                                  (a:_) -> gconfValueDynGetType (head as)))
  {# call unsafe gconf_value_set_list_nocopy #} (GConfValue value) valuesList
  return (GConfValue value)

unsafeMarshalGConfValueDynPairFromGConfValue :: GConfValue -> IO (GConfValueDyn, GConfValueDyn)
unsafeMarshalGConfValueDynPairFromGConfValue value = do
  a <- {# call unsafe gconf_value_get_car #} value
  b <- {# call unsafe gconf_value_get_cdr #} value
  a' <- marshalFromGConfValue (GConfValue a)
  b' <- marshalFromGConfValue (GConfValue b)
  return (a', b')

marshalGConfValueDynPairToGConfValue :: (GConfValueDyn, GConfValueDyn) -> IO GConfValue
marshalGConfValueDynPairToGConfValue (a,b) = do
  value <- {# call unsafe gconf_value_new #}
    (fromIntegral $ fromEnum GconfValuePair)
  a' <- marshalToGConfValue a
  b' <- marshalToGConfValue b
  {# call unsafe gconf_value_set_car_nocopy #} (GConfValue value) a'
  {# call unsafe gconf_value_set_cdr_nocopy #} (GConfValue value) b'
  return (GConfValue value)

instance GConfValueClass GConfValueDyn where
  typeofGConfValue _ = undefined -- will never be used
  unsafeMarshalFromGConfValue value = do
    valueType <- gconfValueGetType value
    case valueType of
      GconfValueString -> liftM GConfValueString $ unsafeMarshalFromGConfValue value
      GconfValueInt    -> liftM GConfValueInt    $ unsafeMarshalFromGConfValue value
      GconfValueFloat  -> liftM GConfValueFloat  $ unsafeMarshalFromGConfValue value
      GconfValueBool   -> liftM GConfValueBool   $ unsafeMarshalFromGConfValue value
      GconfValueSchema -> return GConfValueSchema
      GconfValueList   -> liftM GConfValueList   $ unsafeMarshalGConfValueDynListFromGConfValue value
      GconfValuePair   -> liftM GConfValuePair   $ unsafeMarshalGConfValueDynPairFromGConfValue value

  marshalFromGConfValue value@(GConfValue ptr) = do
    when (ptr == nullPtr) $ fail "GConf: cannot get value of key, key is unset"
    unsafeMarshalFromGConfValue value

  marshalToGConfValue v = case v of
    (GConfValueString v') -> marshalToGConfValue v'
    (GConfValueInt    v') -> marshalToGConfValue v'
    (GConfValueFloat  v') -> marshalToGConfValue v'
    (GConfValueBool   v') -> marshalToGConfValue v'
    (GConfValueSchema   ) -> fail "GConf: setting schema types not supported"
    (GConfValueList   v') -> marshalGConfValueDynListToGConfValue v'
    (GConfValuePair   v') -> marshalGConfValueDynPairToGConfValue v'

gconfValueDynGetType :: GConfValueDyn -> GConfValueType
gconfValueDynGetType (GConfValueString _) = GconfValueString
gconfValueDynGetType (GConfValueInt    _) = GconfValueInt
gconfValueDynGetType (GConfValueFloat  _) = GconfValueFloat
gconfValueDynGetType (GConfValueBool   _) = GconfValueBool
gconfValueDynGetType (GConfValueList   _) = GconfValueList
gconfValueDynGetType (GConfValuePair   _) = GconfValuePair

{-# OPTIONS -fallow-overlapping-instances #-} -- String & [a] overlap
-- -*-haskell-*-
-- GIMP Toolkit (GTK) GConf API
--
--  Author : Duncan Coutts
--  Created: 16 April 2004
--
--  Copyright (c) 2004 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
--  |
--
--  Module for dealing with the values stored in the GConf system.
--
--  GConfValue has its own primitive type system which is represented in
--  Haskell using type classes. This allows values to be get and set without
--  needing to perform any dynamic type casting or needing a union type.
--
--  Alternatively, a dynamic\/union type is provided for the rare occasions
--  when that degree of flexability is required. It should only be necessary
--  if you need to deal with configuration values without statically knowing
--  their type.
--

module System.Gnome.GConf.GConfValue (
 GConfPrimitiveValueClass,
 GConfValueClass,
 marshalFromGConfValue,
 marshalToGConfValue,
 GConfValue(GConfValue),
 GConfValueDyn(..),
 ) where

import Monad (liftM, when)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GList (toGSList, readGSList)

--{# context lib="gconf" prefix ="gconf_value" #}
{# context lib="gconf" #}

{# enum GConfValueType {underscoreToCase} deriving (Eq, Show) #}

{# pointer *GConfValue newtype #}

-- | Class of types which can be kept by GConf
class GConfValueClass value where
  --unsafe because assumes non-null pointer and correct type
  unsafeMarshalFromGConfValue :: GConfValue -> IO value

  -- safe checked version, may throw exception
  marshalFromGConfValue :: GConfValue -> IO value
  marshalFromGConfValue value = do
    checkForNullAndExpectedType (typeofGConfValue (undefined::value)) value
    unsafeMarshalFromGConfValue value

  typeofGConfValue :: value -> GConfValueType

  marshalToGConfValue :: value -> IO GConfValue

-- The above methods follow the following memory management rules regarding
-- GConfValues: marshalFrom reads the value but does not gain ownership and thus
-- does not deallocate. marshalTo allocates a new value and gives up ownership;
-- it is not responsible for dellocation (it does not attach a finaliser).
-- The code that uses marshalTo must ensure that it hands the value off to a
-- function that is prepared to asume ownership of the value.

-- | Dynamic version for when the type is not known statically.
data GConfValueDyn = GConfValueString String
                   | GConfValueInt Int
                   | GConfValueFloat Double
                   | GConfValueBool Bool
                   | GConfValueSchema               -- ^ Not supported
                   | GConfValueList [GConfValueDyn] -- ^ Must all be of same primitive type
                   | GConfValuePair (GConfValueDyn, GConfValueDyn) -- ^ Must both be primitive

-- Allow variant using Maybe, where Nothing means the value was not set
-- Use this variant when you expect the gconf key to not be set somethimes;
-- otherwise the 'raw' types will raise an exception if you get an unset key.
-- Just for consistency, setting a key to Nothing will unset the key, however
-- it is preferable to use gconfClientUnset explicitly.
instance GConfValueClass value => GConfValueClass (Maybe value) where
  typeofGConfValue _ = typeofGConfValue (undefined :: value)
  unsafeMarshalFromGConfValue = marshalFromGConfValue
  marshalFromGConfValue value =
    catch (liftM Just $ marshalFromGConfValue value)
          (\_ -> return Nothing)
  marshalToGConfValue (Just v) = marshalToGConfValue v
  marshalToGConfValue Nothing  = return $ GConfValue nullPtr

-- The GConfValue type system says some types are primitive.
-- Compound types (lists & pairs) may only be constructed from primitive types.
class GConfValueClass value => GConfPrimitiveValueClass value
instance GConfPrimitiveValueClass Int
instance GConfPrimitiveValueClass Bool
instance GConfPrimitiveValueClass Double
instance GConfPrimitiveValueClass String

instance GConfValueClass Int where
  typeofGConfValue _ = GconfValueInt
  unsafeMarshalFromGConfValue = liftM fromIntegral . {# call unsafe gconf_value_get_int #}
  marshalToGConfValue n = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueInt)
    {# call unsafe gconf_value_set_int #} (GConfValue value) (fromIntegral n)
    return (GConfValue value)

instance GConfValueClass Bool where
  typeofGConfValue _ = GconfValueBool
  unsafeMarshalFromGConfValue = liftM toBool . {# call unsafe gconf_value_get_bool #}
  marshalToGConfValue b = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueBool)
    {# call unsafe gconf_value_set_bool #} (GConfValue value) (fromBool b)
    return (GConfValue value)

instance GConfValueClass Double where
  typeofGConfValue _ = GconfValueFloat
  unsafeMarshalFromGConfValue = liftM realToFrac . {# call unsafe gconf_value_get_float #}
  marshalToGConfValue f = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueFloat)
    {# call unsafe gconf_value_set_float #} (GConfValue value) (realToFrac f)
    return (GConfValue value)

-- Now unfortunately String & [a] overlap, although really they don't since Char
-- is not an instance of GConfPrimitiveValueClass, however classes are open so
-- we don't know that Char would never be an instance. I want closed classes!
instance GConfValueClass String where
  typeofGConfValue _ = GconfValueString

  unsafeMarshalFromGConfValue value = do
    strPtr <- {# call unsafe gconf_value_get_string #} value
    peekUTFString strPtr

  marshalToGConfValue s = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueString)
    withCString s $ \strPtr ->
      {# call unsafe gconf_value_set_string #} (GConfValue value) strPtr
    return (GConfValue value)

instance (GConfPrimitiveValueClass a, GConfPrimitiveValueClass b) => GConfValueClass (a,b) where
  typeofGConfValue _ = GconfValuePair

  unsafeMarshalFromGConfValue value = do
    a <- {# call unsafe gconf_value_get_car #} value
    b <- {# call unsafe gconf_value_get_cdr #} value
    a' <- marshalFromGConfValue (GConfValue a)
    b' <- marshalFromGConfValue (GConfValue b)
    return (a',b')

  marshalToGConfValue (a,b) = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValuePair)
    a' <- marshalToGConfValue a
    b' <- marshalToGConfValue b
    {# call unsafe gconf_value_set_car_nocopy #} (GConfValue value) a'
    {# call unsafe gconf_value_set_cdr_nocopy #} (GConfValue value) b'
    return (GConfValue value)

instance GConfPrimitiveValueClass a => GConfValueClass [a] where
  typeofGConfValue _ = GconfValueList

  unsafeMarshalFromGConfValue value = do
    gsList <- {# call unsafe gconf_value_get_list #} value
    valuesPtrs <- readGSList gsList
    mapM (unsafeMarshalFromGConfValue . GConfValue) valuesPtrs

  marshalFromGConfValue value = do
    checkForNullAndExpectedType GconfValueList value
    listType <- liftM (toEnum . fromIntegral) $
                {# call unsafe gconf_value_get_list_type #} value
    when (listType /= typeofGConfValue (undefined :: a))
         (fail "GConf: key is list with elements of unexpected type")
    unsafeMarshalFromGConfValue value

  marshalToGConfValue list = do
    value <- {# call unsafe gconf_value_new #}
      (fromIntegral $ fromEnum GconfValueList)
    valuesPtrs <- mapM (liftM (\(GConfValue ptr) -> ptr) . marshalToGConfValue) list
    valuesList <- toGSList valuesPtrs
    {# call unsafe gconf_value_set_list_type #} (GConfValue value)
      (fromIntegral $ fromEnum $ typeofGConfValue (undefined::a))
    {# call unsafe gconf_value_set_list_nocopy #} (GConfValue value) valuesList
    return (GConfValue value)

----------------
-- For convenience and best practice, an instance for Enum
-- This conforms to the GConf GTK+/Gnome convention for storing enum types,
-- which is to store them as a string using ThisStlyeOfCapitalisation.

-- Note: currently disabled since it requires -fallow-undecidable-instances
{-
instance (Show enum, Read enum, Enum enum, GConfValueClass enum)
      => GConfPrimitiveValueClass enum
instance (Show enum, Read enum, Enum enum) => GConfValueClass enum where
  marshalFromGConfValue value = do
    enumStr <- marshalFromGConfValue value
    case reads enumStr of
      [(enum,_)] -> return enum
      _          -> fail "GCconf: invalid enum value"
  marshalFromGConfValue' value = do
    maybeEnumStr <- marshalFromGConfValue' value
    case maybeEnumStr of
      Nothing -> return Nothing
      (Just enumStr) -> case reads enumStr of
                          [(enum,_)] -> return (Just enum)
                          _          -> return Nothing
  marshalToGConfValue enum = marshalToGConfValue (show enum)
  typeofGConfValue _ = GconfValueString
-}

----------------
-- Helper funcs

gconfValueGetType :: GConfValue ->  IO GConfValueType
--we mean the following but unfortunately c2hs barfs on 'type'
--gconfValueGetType (GConfValue valuePtr) = {# get GConfValue->type #} valuePtr
-- so instead we have the ugly:
gconfValueGetType (GConfValue valuePtr) =
  liftM (toEnum . fromIntegral) $ peek (castPtr valuePtr :: Ptr CInt)
--TODO: check that sizeof(GConfValueType) == sizeof(int)

-- returns Nothing if ok, or and error message
checkForNullAndExpectedType :: GConfValueType -> GConfValue -> IO ()
checkForNullAndExpectedType expectedType value@(GConfValue ptr)
 | ptr == nullPtr = fail "GConf: cannot get value of key, key is unset"
 | otherwise = do valueType <- gconfValueGetType value
                  when (valueType /= expectedType)
                       (fail $ "GConf: key is of unexpected type, expected: "
                          ++ show expectedType ++ ", got: " ++ show valueType)

{-
checkForNullAndExpectedType :: GConfValueType -> GConfValue -> IO GConfValue
checkForNullAndExpectedType expectedType value@(GConfValue ptr)
 | ptr == nullPtr = fail "GConf: cannot get value of key, key is unset"
 | otherwise = do valueType <- gconfValueGetType value
                  if valueType /= expectedType
                    then fail $ "GConf: key is of unexpected type, expected: "
                             ++ show expectedType ++ ", got: " ++ show valueType
                    else return value

checkForNullAndExpectedType' :: GConfValueType -> GConfValue -> IO (Maybe GConfValue)
checkForNullAndExpectedType' expectedType value@(GConfValue ptr)
 | ptr == nullPtr = return Nothing
 | otherwise = do valueType <- gconfValueGetType value
                  if valueType /= expectedType
                    then return Nothing
                    else return (Just value)
-}
----------------
-- GConfValueDyn

unsafeMarshalGConfValueDynListFromGConfValue :: GConfValue -> IO [GConfValueDyn]
unsafeMarshalGConfValueDynListFromGConfValue value = do
  gsList <- {# call unsafe gconf_value_get_list #} value
  valuesPtrs <- readGSList gsList
  mapM (unsafeMarshalFromGConfValue . GConfValue) valuesPtrs

marshalGConfValueDynListToGConfValue :: [GConfValueDyn] -> IO GConfValue
marshalGConfValueDynListToGConfValue as = do
  value <- {# call unsafe gconf_value_new #}
    (fromIntegral $ fromEnum GconfValueList)
  valuesPtrs <- mapM (liftM (\(GConfValue ptr) -> ptr) . marshalToGConfValue) as
  valuesList <- toGSList valuesPtrs
  {# call unsafe gconf_value_set_list_type #} (GConfValue value)
    (fromIntegral $ fromEnum $ (case as of
                                  []    -> GconfValueInvalid  --unknown type
                                  (a:_) -> gconfValueDynGetType (head as)))
  {# call unsafe gconf_value_set_list_nocopy #} (GConfValue value) valuesList
  return (GConfValue value)

unsafeMarshalGConfValueDynPairFromGConfValue :: GConfValue -> IO (GConfValueDyn, GConfValueDyn)
unsafeMarshalGConfValueDynPairFromGConfValue value = do
  a <- {# call unsafe gconf_value_get_car #} value
  b <- {# call unsafe gconf_value_get_cdr #} value
  a' <- marshalFromGConfValue (GConfValue a)
  b' <- marshalFromGConfValue (GConfValue b)
  return (a', b')

marshalGConfValueDynPairToGConfValue :: (GConfValueDyn, GConfValueDyn) -> IO GConfValue
marshalGConfValueDynPairToGConfValue (a,b) = do
  value <- {# call unsafe gconf_value_new #}
    (fromIntegral $ fromEnum GconfValuePair)
  a' <- marshalToGConfValue a
  b' <- marshalToGConfValue b
  {# call unsafe gconf_value_set_car_nocopy #} (GConfValue value) a'
  {# call unsafe gconf_value_set_cdr_nocopy #} (GConfValue value) b'
  return (GConfValue value)

instance GConfValueClass GConfValueDyn where
  typeofGConfValue _ = undefined -- will never be used
  unsafeMarshalFromGConfValue value = do
    valueType <- gconfValueGetType value
    case valueType of
      GconfValueString -> liftM GConfValueString $ unsafeMarshalFromGConfValue value
      GconfValueInt    -> liftM GConfValueInt    $ unsafeMarshalFromGConfValue value
      GconfValueFloat  -> liftM GConfValueFloat  $ unsafeMarshalFromGConfValue value
      GconfValueBool   -> liftM GConfValueBool   $ unsafeMarshalFromGConfValue value
      GconfValueSchema -> return GConfValueSchema
      GconfValueList   -> liftM GConfValueList   $ unsafeMarshalGConfValueDynListFromGConfValue value
      GconfValuePair   -> liftM GConfValuePair   $ unsafeMarshalGConfValueDynPairFromGConfValue value

  marshalFromGConfValue value@(GConfValue ptr) = do
    when (ptr == nullPtr) $ fail "GConf: cannot get value of key, key is unset"
    unsafeMarshalFromGConfValue value

  marshalToGConfValue v = case v of
    (GConfValueString v') -> marshalToGConfValue v'
    (GConfValueInt    v') -> marshalToGConfValue v'
    (GConfValueFloat  v') -> marshalToGConfValue v'
    (GConfValueBool   v') -> marshalToGConfValue v'
    (GConfValueSchema   ) -> fail "GConf: setting schema types not supported"
    (GConfValueList   v') -> marshalGConfValueDynListToGConfValue v'
    (GConfValuePair   v') -> marshalGConfValueDynPairToGConfValue v'

gconfValueDynGetType :: GConfValueDyn -> GConfValueType
gconfValueDynGetType (GConfValueString _) = GconfValueString
gconfValueDynGetType (GConfValueInt    _) = GconfValueInt
gconfValueDynGetType (GConfValueFloat  _) = GconfValueFloat
gconfValueDynGetType (GConfValueBool   _) = GconfValueBool
gconfValueDynGetType (GConfValueList   _) = GconfValueList
gconfValueDynGetType (GConfValuePair   _) = GconfValuePair