{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
module Util.ICStringLen(
ICStringLen,
UTF8(..),
toUTF8,
fromUTF8WE,
mkICStringLen,
mkICStringLenExtra,
withICStringLen,
bytesToICStringLen,
bytesFromICStringLen,
touchICStringLen,
readICStringLen,
writeToICStringLen,
) where
import System.IO.Unsafe
import Foreign.C.String
import Foreign.ForeignPtr
#if __GLASGOW_HASKELL__ > 706
import Foreign.ForeignPtr.Unsafe
#endif
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.C.Types
import Control.Monad.Trans
import Util.AtomString
import Util.Bytes
import Util.Binary
import Util.Computation
import Util.ExtendedPrelude
import Util.Dynamics
import Util.UTF8
data ICStringLen = ICStringLen (ForeignPtr CChar) Int deriving (Typeable)
newtype UTF8 bytes = UTF8 bytes
instance StringClass ICStringLen where
fromString str = unsafePerformIO (innerFromString str)
where
innerFromString :: String -> IO ICStringLen
innerFromString str =
do
let
len = length str
mkICStringLen len
(\ ptr -> pokeArray ptr
(map castCharToCChar str)
)
toString icsl = unsafePerformIO (innerToString icsl)
where
innerToString :: ICStringLen -> IO String
innerToString icsl =
withICStringLen icsl
(\ len ptr ->
do
cchars <- peekArray len ptr
return (map castCCharToChar cchars)
)
instance StringClass (UTF8 ICStringLen) where
fromString str = UTF8 (fromString (toUTF8 str))
toString (UTF8 icsl) = coerceWithError (fromUTF8WE (toString icsl))
instance Show ICStringLen where
show = show . toString
mkICStringLen :: Int -> (CString -> IO()) -> IO ICStringLen
mkICStringLen len writeFn =
do
ptr <- mallocArray len
writeFn ptr
createICStringLen ptr len
mkICStringLenExtra :: Int -> (CString -> IO extra) -> IO (ICStringLen,extra)
mkICStringLenExtra len writeFn =
do
ptr <- mallocArray len
extra <- writeFn ptr
icsl <- createICStringLen ptr len
return (icsl,extra)
withICStringLen :: ICStringLen -> (Int -> CString -> IO a) -> IO a
withICStringLen (ICStringLen foreignPtr len) readFn =
withForeignPtr foreignPtr (\ ptr -> readFn len ptr)
createICStringLen :: CString -> Int -> IO ICStringLen
createICStringLen ptr len =
do
foreignPtr <- newForeignPtr finalizerFree ptr
return (ICStringLen foreignPtr len)
bytesToICStringLen :: (Bytes,Int) -> IO ICStringLen
bytesToICStringLen (bytes,i) = createICStringLen (unMkBytes bytes) i
bytesFromICStringLen :: ICStringLen -> (Bytes,Int)
bytesFromICStringLen (ICStringLen foreignPtr len)
= (mkBytes (unsafeForeignPtrToPtr foreignPtr),len)
touchICStringLen :: ICStringLen -> IO ()
touchICStringLen (ICStringLen foreignPtr _) = touchForeignPtr foreignPtr
instance OrdIO ICStringLen where
compareIO (ICStringLen fptr1 len1) (ICStringLen fptr2 len2) =
case compare len1 len2 of
LT -> return LT
GT -> return GT
EQ -> compareBytes (mkBytes (unsafeForeignPtrToPtr fptr1))
(mkBytes (unsafeForeignPtrToPtr fptr2)) len1
instance EqIO ICStringLen where
eqIO icsl1 icsl2 =
do
ord <- compareIO icsl1 icsl2
return (ord == EQ)
instance Eq ICStringLen where
(==) icsl1 icsl2 = unsafePerformIO (eqIO icsl1 icsl2)
instance MonadIO m => HasBinary ICStringLen m where
writeBin wb icsl =
do
r <- writeBin wb (bytesFromICStringLen icsl)
seq r done
liftIO (touchICStringLen icsl)
return r
readBin rb =
do
bl <- readBin rb
icsl <- liftIO (bytesToICStringLen bl)
return icsl
readICStringLen :: HasBinary a StateBinArea => ICStringLen -> IO a
readICStringLen icsl =
do
let
bl = bytesFromICStringLen icsl
a <- readFromBytes bl
touchICStringLen icsl
return a
writeToICStringLen :: HasBinary a StateBinArea => a -> IO ICStringLen
writeToICStringLen a =
do
bl <- writeToBytes a
bytesToICStringLen bl