{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}

-- | This module provides immutable CStrings, which additionally have
-- the property that they are automatically freed when the garbage-collector
-- forgets about them.
module Util.ICStringLen(
   ICStringLen, -- instance of AtomString and Eq.

   UTF8(..),
      -- newtype alias.  UTF8 ICStringLen is also an instance of AtomString,
      -- but we assume the characters are UTF8-encoded.
   toUTF8,
      -- :: String -> String
   fromUTF8WE,
      -- :: String -> WithError String
      -- This can be used for an error-checking UTF8 conversion.

   -- general creation and reading.
   mkICStringLen, -- :: Int -> (Ptr CChar -> IO()) -> IO ICStringLen
   mkICStringLenExtra,
      -- :: Int -> (CString -> IO extra) -> IO (ICStringLen,extra)
   withICStringLen, -- :: ICStringLen -> (Int -> Ptr CChar -> IO a) -> IO a


   -- Conversion to/from (Bytes,Int)
   -- NB.  Once a bytes value is converted to an ICStringLen,
   -- that ICStringLen will automatically free the pointer when the
   -- ICStringLen value is garbage collected.
   bytesToICStringLen, -- :: (Bytes,Int) -> IO ICStringLen
   bytesFromICStringLen, -- :: ICStringLen -> (Bytes,Int)
   touchICStringLen, -- :: ICStringLen -> IO ()

   -- Conversion to and from other objects
   readICStringLen, -- :: HasBinary a StateBinArea => ICStringLen -> IO a
   writeToICStringLen, -- :: HasBinary a StateBinArea => a -> IO ICStringLen


   ) 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

-- ------------------------------------------------------------------
-- The datatype
-- ------------------------------------------------------------------

data ICStringLen = ICStringLen (ForeignPtr CChar) Int deriving (Typeable)

newtype UTF8 bytes = UTF8 bytes

-- ------------------------------------------------------------------
-- Creation and reading
-- ------------------------------------------------------------------

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

-- -------------------------------------------------------------------
-- General functions for Creating and reading ICStringLen's.
-- -------------------------------------------------------------------

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)
mkICStringLenExtra :: Int -> (CString -> IO extra) -> IO (ICStringLen, extra)
mkICStringLenExtra 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)


-- -------------------------------------------------------------------
-- Converting ICStringLen directly to its components.
-- -------------------------------------------------------------------

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 of EqIO, OrdIO.
-- -------------------------------------------------------------------

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)

-- -------------------------------------------------------------------
-- Oh very well.  We implement Eq for ICStringLen, using unsafePerformIO.
-- -------------------------------------------------------------------

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

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

-- -------------------------------------------------------------------
-- Conversion to and from other objects
-- -------------------------------------------------------------------

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