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