LibZip を ByteString と String に両対応させようとしてコンパイルが通らない何か

LibZip'.hs

{- | Polymorphic version of @Codec.Archive.LibZip@.

Codec.Archive.Libzip is with useful and simple API, and a high-leveled library to deal with zip archives.

...Although, in the library, specification way of the path to a file inside a zip archive is `String`.
This limitation is inconvenient especially when dealing with zip archived file
of which path contains foreign system's multi-byte characters.

This module provides APIs of polymorphic version,
which can specify and receive archived file's path as String or Data.ByteString (as you like).

This module is made from subset of
original version Codec.Archive.LibZip: https://bitbucket.org/astanin/hs-libzip ,
with modifying type signatures only.
-}

module Codec.Archive.Polymorphic.LibZip
    (
    -- * Types
      Archive
    , Entry
    , ZipStat(..)
    -- * Archive operations
    , withArchive, getZip
    , numFiles, fileName, nameLocate, fileNames
    , fileSize, fileSizeIx
    , fileStat, fileStatIx
    , deleteFile, deleteFileIx
    , renameFile, renameFileIx
    , addFile, addDirectory
    , replaceFile, replaceFileIx
    , sourceBuffer, sourceFile, sourceZip
    , PureSource(..), sourcePure
    , getComment, setComment, removeComment
    , getFileComment, getFileCommentIx
    , setFileComment, setFileCommentIx
    , removeFileComment, removeFileCommentIx
    , unchangeFile, unchangeFileIx
    , unchangeArchive, unchangeAll
    -- * File reading operations
    , fromFile, fromFileIx
    , readBytes, skipBytes, readContents
    , fileContents, fileContentsIx
    -- * Flags and options
    , OpenFlag(..)
    , FileFlag(..)
    , ZipCompMethod(..)
    , ZipEncryptionMethod(..)
    -- * Exception handling
    , ZipError(..)
    , catchZipError
    -- * Re-exports
    , lift
    ) where

import Bindings.LibZip
import Codec.Archive.LibZip hiding (
  fileName, nameLocate, fileNames
  , fileSize
  , fileStat
  , deleteFile
  , renameFile
  , addFile, addDirectory
  , replaceFile
  , sourceFile
  , getComment, setComment
  , getFileComment, getFileCommentIx
  , setFileComment, setFileCommentIx
  , removeFileComment
  , unchangeFile
  , fromFile
  , fileContents
  )
import Codec.Archive.LibZip.Types
-- import Codec.Archive.LibZip.Errors

import Control.Monad.State.Strict
    (lift, liftM, runStateT)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (nullPtr)
import Foreign.Storable (peek)
import qualified Control.Exception as E

import qualified Data.ByteString as B

import qualified Foreign.C.String as FCS
import Foreign.C.Types (CInt)

--
-- Types
--

class CStringMutual s where
  withCString :: s -> (FCS.CString -> IO a) -> IO a
  withCStringLen :: s -> (FCS.CStringLen -> IO a) -> IO a
  peekCString :: FCS.CString -> IO s

instance CStringMutual (B.ByteString) where
  withCString = B.useAsCString
  withCStringLen = B.useAsCStringLen
  peekCString = B.packCString

instance CStringMutual (String) where
  withCString = FCS.withCString
  withCStringLen = FCS.withCStringLen
  peekCString = FCS.peekCString

--
-- Archive operations
--

-- | Get name of an entry in the archive by its index.
fileName :: (CStringMutual filePath)
         => [FileFlag]  -- ^ 'FileUNCHANGED' flag can be used.
         -> Int         -- ^ Position index of a file in the archive.
         -> Archive filePath  -- ^ Name of the file in the archive.
fileName flags i = do
  z <- getZip
  lift $ do
    n <- c'zip_get_name z (fromIntegral i) (combine flags)
    doIf' (n /= nullPtr) z $ peekCString n

-- | Locate an entry (get its index) in the archive by its name.
nameLocate :: (CStringMutual filePath)
           => [FileFlag]  -- ^ Filename lookup mode.
           -> filePath    -- ^ Name of the file in the archive.
           -> Archive (Maybe Int)  -- ^ 'Just' position index if found.
nameLocate flags name = do
  z <- getZip
  lift $
    withCString name $ \name' -> do
    i <- fromIntegral `liftM` c'zip_name_locate z name' (combine flags)
    if i < 0
       then return Nothing
       else return (Just i)

-- | Get names of all entries (files and directories) in the archive.
fileNames :: (CStringMutual filePath)
          => [FileFlag]  -- ^ 'FileUNCHANGED' flag is accepted.
          -> Archive [filePath]
fileNames flags = do
  n <- numFiles
  mapM (fileName flags) [0..n-1]

-- | Get size of a file in the archive.
fileSize :: (CStringMutual filePath)
         => [FileFlag]  -- ^ Filename lookup mode, 'FileUNCHANGED' can be used.
         -> filePath    -- ^ Name of the file in the archive.
         -> Archive Int -- ^ File size.
fileSize flags name = fileStat flags name >>= return . zs'size

-- | Get information about a file in the archive.
fileStat :: (CStringMutual filePath)
         => [FileFlag]  -- ^ Filename lookup mode, 'FileUNCHANGED' can be used.
         -> filePath    -- ^ Name of the file in the archive.
         -> Archive ZipStat  -- ^ Infomation about the file.
fileStat flags name = do
  z <- getZip
  lift $
       withCString name $ \name' ->
       alloca $ \stat -> do
       c'zip_stat_init stat
       r <- c'zip_stat z name' (combine flags) stat
       doIf' (r == 0) z $ toZipStat =<< peek stat

-- | Delete file from the archive.
deleteFile :: (CStringMutual filePath)
           => [FileFlag]  -- ^ Filename lookup mode.
           -> filePath    -- ^ Filename.
           -> Archive ()
deleteFile flags name = do
  mbi <- nameLocate flags name
  maybe (lift $ E.throwIO ErrNOENT) deleteFileIx mbi

-- | Rename file in the archive.
renameFile :: (CStringMutual filePath)
           => [FileFlag]  -- ^ Filename lookup mode.
           -> filePath    -- ^ Old name.
           -> filePath    -- ^ New name.
           -> Archive ()
renameFile flags oldname newname = do
  mbi <- nameLocate flags oldname
  maybe (lift $ E.throwIO ErrNOENT) (\i -> renameFileIx i newname) mbi

-- | Add a file to the archive.
addFile :: (CStringMutual filePath)
        => filePath   -- ^ Name of the file to create.
        -> ZipSource  -- ^ Source where file data is obtained from.
        -> Archive Int  -- ^ Position index of the new file.
addFile name src = do
  z <- getZip
  lift $ withCString name $ \name' -> do
    i <- c'zip_add z name' src
    if i < 0
       then c'zip_source_free src >> get_error z >>= E.throwIO
       else return $ fromIntegral i

-- | Add a directory to the archive.
addDirectory :: (CStringMutual filePath)
             => filePath     -- ^ Directory's name in the archive.
             -> Archive Int  -- ^ Position index of the new directory entry.
addDirectory name = do
  z <- getZip
  r <- lift $ withCString name $ c'zip_add_dir z
  if r < 0
     then lift $ get_error z >>= E.throwIO
     else return (fromIntegral r)

-- | Replace a file in the archive.
replaceFile :: (CStringMutual filePath)
            => [FileFlag]  -- ^ Filename lookup mode.
            -> filePath    -- ^ File to replace.
            -> ZipSource   -- ^ Source where the new file data is obtained from.
            -> Archive ()
replaceFile flags name src = do
  mbi <- nameLocate flags name
  maybe (lift $ c'zip_source_free src >> E.throwIO ErrNOENT)
        (\i -> replaceFileIx i src >> return ()) mbi

-- | Create a data source from a file.
sourceFile :: (CStringMutual filePath)
           => filePath   -- ^ File to open.
           -> Int        -- ^ Offset from the beginning of the file.
           -> Int        -- ^ The number of bytes to read. If @0@ or @-1@,
                         -- the read till the end of file.
           -> Archive ZipSource
sourceFile name offset len = do
  z <- getZip
  lift $ withCString name $ \name' -> do
      zs <- c'zip_source_file z name' (fromIntegral offset) (fromIntegral len)
      if zs == nullPtr
         then get_error z >>= E.throwIO
         else return zs

-- | Set zip archive comment.
setComment :: (CStringMutual string)
           => string   -- ^ Comment message.
           -> Archive ()
setComment msg = do
  z <- getZip
  r <- lift $ withCStringLen msg $ \(msg',i') ->
       c'zip_set_archive_comment z msg' (fromIntegral i')
  if r < 0
     then lift $ get_error z >>= E.throwIO
     else return ()

-- | Get comment for a file in the archive.
getFileComment :: (CStringMutual filePath, CStringMutual string)
               => [FileFlag]  -- ^ Filename lookup mode.
               -> filePath    -- ^ Filename
               -> Archive (Maybe string)
getFileComment flags name = do
  mbi <- nameLocate flags name
  maybe (lift $ E.throwIO ErrNOENT) (getFileCommentIx flags) mbi

-- | Get comment for a file in the archive (referenced by position index).
getFileCommentIx :: (CStringMutual string)
                 => [FileFlag]  -- ^ FileUNCHANGED can be used.
                 -> Int         -- ^ Position index of the file.
                 -> Archive (Maybe string)
getFileCommentIx flags i = do
  z <- getZip
  (c,n) <- lift $ alloca $ \lenp -> do
           c <- c'zip_get_file_comment z (fromIntegral i) lenp (combine flags)
           n <- peek lenp
           return (c,n)
  if c == nullPtr
     then return Nothing
     else lift $ peekCString c >>= return . Just . take (fromIntegral n)

-- | Set comment for a file in the archive.
setFileComment :: (CStringMutual filePath, CStringMutual string)
               => [FileFlag]   -- ^ Name lookup mode.
               -> filePath     -- ^ Filename.
               -> string       -- ^ New file comment.
               -> Archive ()
setFileComment flags path comment = do
  mbi <- nameLocate flags path
  maybe (lift $ E.throwIO ErrNOENT) (flip setFileCommentIx comment) mbi

-- | Set comment for a file in the archive (referenced by position index).
setFileCommentIx :: (CStringMutual string)
                 => Int        -- ^ Position index of a file in the archive.
                 -> string     -- ^ New file comment. 
                 -> Archive ()
setFileCommentIx i comment = do
  z <- getZip
  r <- lift $ withCStringLen comment $ \(msg,len) ->
       c'zip_set_file_comment z (fromIntegral i) msg (fromIntegral len)
  if r < 0
     then lift $ get_error z >>= E.throwIO
     else return ()

-- | Remove comment for a file in the archive.
removeFileComment :: (CStringMutual filePath)
                  => [FileFlag]  -- ^ Filename lookup mode.
                  -> filePath    -- ^ Filename.
                  -> Archive ()
removeFileComment flags path = do
  mbi <- nameLocate flags path
  maybe (lift $ E.throwIO ErrNOENT) removeFileCommentIx mbi

-- | Undo changes to a file in the archive.
unchangeFile :: (CStringMutual filePath)
             => [FileFlag]  -- ^ Filename lookup mode.
             -> filePath    -- ^ Filename.
             -> Archive ()
unchangeFile flags name = do
  mbi <- nameLocate flags name
  maybe (lift $ E.throw ErrNOENT) unchangeFileIx mbi

--
-- File reading operations
--

-- | Wrapper for operations with a file in the archive. 'fromFile' is normally
-- called from within an 'Archive' action (see also 'withArchive').
-- 'fromFile' can be replaced with 'fileContents' to read an entire file at
-- once.
fromFile :: (CStringMutual filePath)
         => [FileFlag]  -- ^ Filename lookup mode,
                        -- 'FileCOMPRESSED' and 'FileUNCHANGED' can be used.
         -> filePath    -- ^ Name of the file in the arhive.
         -> Entry a     -- ^ Action with the file.
         -> Archive a
fromFile flags name action = do
    z <- getZip
    nameLocate flags name >>= maybe (lift $ get_error z >>= E.throwIO) runAction
  where
    runAction i = do
      z <- getZip
      zf <- lift $ withCString name $ \n -> c'zip_fopen z n (combine flags)
      if zf == nullPtr
        then lift $ get_error z >>= E.throwIO
        else do
          r <- fst `liftM` runStateT action (zf,i,flags)
          e <- lift $ c'zip_fclose zf
          if e /= 0
            then lift $ E.throwIO $ (toEnum . fromIntegral $ e :: ZipError)
            else return r

-- | Read entire file. Shortcut for 'readContents' from within 'Archive' monad.
fileContents :: (Enum a, CStringMutual filePath)
    => [FileFlag]
    -> filePath
    -> Archive [a]
fileContents flags name = fromFile flags name readContents


--
-- copy hidden module's implementation
--
errFromCInt :: CInt -> ZipError
errFromCInt = toEnum . fromEnum

get_error :: Zip -> IO ZipError
get_error z | z == nullPtr = E.throwIO ErrINVAL
get_error z = alloca $ \zep -> do
   c'zip_error_get z zep nullPtr
   peek zep >>= return . errFromCInt
-- | Get and throw a 'ZipError' if condition fails. Otherwise work normally.
doIf :: Bool -> Zip -> (Zip -> IO a) -> IO a
doIf cnd z action =
    if cnd
       then action z
       else get_error z >>= E.throwIO

-- | Get and throw a 'ZipError' if condition fails. See also 'doIf'.
doIf' :: Bool -> Zip -> (IO a) -> IO a
doIf' cnd z action = doIf cnd z (const action)

Compile Error:

LibZip/Codec/Archive/Polymorphic/LibZip.hs:107:10:
    Illegal instance declaration for `CStringMutual String'
      (All instance types must be of the form (T t1 ... tn)
       where T is not a synonym.
       Use -XTypeSynonymInstances if you want to disable this.)
    In the instance declaration for `CStringMutual (String)'