{-# 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 :: String -> ICStringLen
fromString String
str = IO ICStringLen -> ICStringLen
forall a. IO a -> a
unsafePerformIO (String -> IO ICStringLen
innerFromString String
str)
where
innerFromString :: String -> IO ICStringLen
innerFromString :: String -> IO ICStringLen
innerFromString String
str =
do
let
len :: Int
len = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str
Int -> (CString -> IO ()) -> IO ICStringLen
mkICStringLen Int
len
(\ CString
ptr -> CString -> [CChar] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray CString
ptr
((Char -> CChar) -> String -> [CChar]
forall a b. (a -> b) -> [a] -> [b]
map Char -> CChar
castCharToCChar String
str)
)
toString :: ICStringLen -> String
toString ICStringLen
icsl = IO String -> String
forall a. IO a -> a
unsafePerformIO (ICStringLen -> IO String
innerToString ICStringLen
icsl)
where
innerToString :: ICStringLen -> IO String
innerToString :: ICStringLen -> IO String
innerToString ICStringLen
icsl =
ICStringLen -> (Int -> CString -> IO String) -> IO String
forall a. ICStringLen -> (Int -> CString -> IO a) -> IO a
withICStringLen ICStringLen
icsl
(\ Int
len CString
ptr ->
do
[CChar]
cchars <- Int -> CString -> IO [CChar]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
len CString
ptr
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ((CChar -> Char) -> [CChar] -> String
forall a b. (a -> b) -> [a] -> [b]
map CChar -> Char
castCCharToChar [CChar]
cchars)
)
instance StringClass (UTF8 ICStringLen) where
fromString :: String -> UTF8 ICStringLen
fromString String
str = ICStringLen -> UTF8 ICStringLen
forall bytes. bytes -> UTF8 bytes
UTF8 (String -> ICStringLen
forall stringClass.
StringClass stringClass =>
String -> stringClass
fromString (String -> String
forall byte. Enum byte => String -> [byte]
toUTF8 String
str))
toString :: UTF8 ICStringLen -> String
toString (UTF8 ICStringLen
icsl) = WithError String -> String
forall a. WithError a -> a
coerceWithError (String -> WithError String
forall byte (m :: * -> *).
(Enum byte, MonadFail m) =>
[byte] -> m String
fromUTF8WE (ICStringLen -> String
forall stringClass.
StringClass stringClass =>
stringClass -> String
toString ICStringLen
icsl))
instance Show ICStringLen where
show :: ICStringLen -> String
show = String -> String
forall a. Show a => a -> String
show (String -> String)
-> (ICStringLen -> String) -> ICStringLen -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ICStringLen -> String
forall stringClass.
StringClass stringClass =>
stringClass -> String
toString
mkICStringLen :: Int -> (CString -> IO()) -> IO ICStringLen
mkICStringLen :: Int -> (CString -> IO ()) -> IO ICStringLen
mkICStringLen Int
len CString -> IO ()
writeFn =
do
CString
ptr <- Int -> IO CString
forall a. Storable a => Int -> IO (Ptr a)
mallocArray Int
len
CString -> IO ()
writeFn CString
ptr
CString -> Int -> IO ICStringLen
createICStringLen CString
ptr Int
len
mkICStringLenExtra :: Int -> (CString -> IO extra) -> IO (ICStringLen,extra)
Int
len CString -> IO extra
writeFn =
do
CString
ptr <- Int -> IO CString
forall a. Storable a => Int -> IO (Ptr a)
mallocArray Int
len
extra
extra <- CString -> IO extra
writeFn CString
ptr
ICStringLen
icsl <- CString -> Int -> IO ICStringLen
createICStringLen CString
ptr Int
len
(ICStringLen, extra) -> IO (ICStringLen, extra)
forall (m :: * -> *) a. Monad m => a -> m a
return (ICStringLen
icsl,extra
extra)
withICStringLen :: ICStringLen -> (Int -> CString -> IO a) -> IO a
withICStringLen :: ICStringLen -> (Int -> CString -> IO a) -> IO a
withICStringLen (ICStringLen ForeignPtr CChar
foreignPtr Int
len) Int -> CString -> IO a
readFn =
ForeignPtr CChar -> (CString -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
foreignPtr (\ CString
ptr -> Int -> CString -> IO a
readFn Int
len CString
ptr)
createICStringLen :: CString -> Int -> IO ICStringLen
createICStringLen :: CString -> Int -> IO ICStringLen
createICStringLen CString
ptr Int
len =
do
ForeignPtr CChar
foreignPtr <- FinalizerPtr CChar -> CString -> IO (ForeignPtr CChar)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr CChar
forall a. FinalizerPtr a
finalizerFree CString
ptr
ICStringLen -> IO ICStringLen
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr CChar -> Int -> ICStringLen
ICStringLen ForeignPtr CChar
foreignPtr Int
len)
bytesToICStringLen :: (Bytes,Int) -> IO ICStringLen
bytesToICStringLen :: (Bytes, Int) -> IO ICStringLen
bytesToICStringLen (Bytes
bytes,Int
i) = CString -> Int -> IO ICStringLen
createICStringLen (Bytes -> CString
unMkBytes Bytes
bytes) Int
i
bytesFromICStringLen :: ICStringLen -> (Bytes,Int)
bytesFromICStringLen :: ICStringLen -> (Bytes, Int)
bytesFromICStringLen (ICStringLen ForeignPtr CChar
foreignPtr Int
len)
= (CString -> Bytes
mkBytes (ForeignPtr CChar -> CString
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr CChar
foreignPtr),Int
len)
touchICStringLen :: ICStringLen -> IO ()
touchICStringLen :: ICStringLen -> IO ()
touchICStringLen (ICStringLen ForeignPtr CChar
foreignPtr Int
_) = ForeignPtr CChar -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr ForeignPtr CChar
foreignPtr
instance OrdIO ICStringLen where
compareIO :: ICStringLen -> ICStringLen -> IO Ordering
compareIO (ICStringLen ForeignPtr CChar
fptr1 Int
len1) (ICStringLen ForeignPtr CChar
fptr2 Int
len2) =
case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
len1 Int
len2 of
Ordering
LT -> Ordering -> IO Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
LT
Ordering
GT -> Ordering -> IO Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
GT
Ordering
EQ -> Bytes -> Bytes -> Int -> IO Ordering
compareBytes (CString -> Bytes
mkBytes (ForeignPtr CChar -> CString
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr CChar
fptr1))
(CString -> Bytes
mkBytes (ForeignPtr CChar -> CString
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr CChar
fptr2)) Int
len1
instance EqIO ICStringLen where
eqIO :: ICStringLen -> ICStringLen -> IO Bool
eqIO ICStringLen
icsl1 ICStringLen
icsl2 =
do
Ordering
ord <- ICStringLen -> ICStringLen -> IO Ordering
forall v. OrdIO v => v -> v -> IO Ordering
compareIO ICStringLen
icsl1 ICStringLen
icsl2
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Ordering
ord Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ)
instance Eq ICStringLen where
== :: ICStringLen -> ICStringLen -> Bool
(==) ICStringLen
icsl1 ICStringLen
icsl2 = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (ICStringLen -> ICStringLen -> IO Bool
forall v. EqIO v => v -> v -> IO Bool
eqIO ICStringLen
icsl1 ICStringLen
icsl2)
instance MonadIO m => HasBinary ICStringLen m where
writeBin :: WriteBinary m -> ICStringLen -> m ()
writeBin WriteBinary m
wb ICStringLen
icsl =
do
()
r <- WriteBinary m -> (Bytes, Int) -> m ()
forall a (m :: * -> *). HasBinary a m => WriteBinary m -> a -> m ()
writeBin WriteBinary m
wb (ICStringLen -> (Bytes, Int)
bytesFromICStringLen ICStringLen
icsl)
() -> m () -> m ()
seq ()
r m ()
forall (m :: * -> *). Monad m => m ()
done
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ICStringLen -> IO ()
touchICStringLen ICStringLen
icsl)
() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
r
readBin :: ReadBinary m -> m ICStringLen
readBin ReadBinary m
rb =
do
(Bytes, Int)
bl <- ReadBinary m -> m (Bytes, Int)
forall a (m :: * -> *). HasBinary a m => ReadBinary m -> m a
readBin ReadBinary m
rb
ICStringLen
icsl <- IO ICStringLen -> m ICStringLen
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((Bytes, Int) -> IO ICStringLen
bytesToICStringLen (Bytes, Int)
bl)
ICStringLen -> m ICStringLen
forall (m :: * -> *) a. Monad m => a -> m a
return ICStringLen
icsl
readICStringLen :: HasBinary a StateBinArea => ICStringLen -> IO a
readICStringLen :: ICStringLen -> IO a
readICStringLen ICStringLen
icsl =
do
let
bl :: (Bytes, Int)
bl = ICStringLen -> (Bytes, Int)
bytesFromICStringLen ICStringLen
icsl
a
a <- (Bytes, Int) -> IO a
forall a. HasBinary a StateBinArea => (Bytes, Int) -> IO a
readFromBytes (Bytes, Int)
bl
ICStringLen -> IO ()
touchICStringLen ICStringLen
icsl
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
writeToICStringLen :: HasBinary a StateBinArea => a -> IO ICStringLen
writeToICStringLen :: a -> IO ICStringLen
writeToICStringLen a
a =
do
(Bytes, Int)
bl <- a -> IO (Bytes, Int)
forall a. HasBinary a StateBinArea => a -> IO (Bytes, Int)
writeToBytes a
a
(Bytes, Int) -> IO ICStringLen
bytesToICStringLen (Bytes, Int)
bl