module CString (
	module Foreign.C.String,

  -- -------------------------------------------------------------------------
  -- chak: the following old interface is DEPRECATED, use PackedString instead
  -- -------------------------------------------------------------------------
    unpackCStringIO     -- :: Addr -> IO [Char]	
  , unpackCStringLenIO  -- :: Addr -> Int -> IO String
  , unpackCStringBA     -- :: ByteArray Int -> [Char]
  , unpackCStringBA#    -- :: ByteArray#    -> Int# -> [Char]
  , unpackCString#      -- :: Addr# -> [Char]

  , unpackNBytes        -- :: Addr -> Int -> [Char]
  , unpackNBytesST      -- :: Addr -> Int -> ST s [Char]
  , unpackNBytesAccST   -- :: Addr -> Int -> [Char] -> ST s [Char]
  , unpackNBytesAccIO   -- :: Addr -> Int -> [Char] -> IO [Char]
  , unpackNBytesBA      -- :: ByteArray Int -> Int  -> [Char]

  , unpackNBytes#       -- :: Addr# -> Int# -> [Char] **
  , unpackNBytesST#     -- :: Addr# -> Int# -> ST s [Char]
  , unpackNBytesBA#     -- :: ByteArray#    -> Int# -> [Char]

  , packString	        -- :: [Char] -> ByteArray Int
  , packStringIO	-- :: [Char] -> IO (ByteArray Int)
  , packStringST	-- :: [Char] -> ST s (ByteArray Int)
  , packNBytesST	-- :: Int -> [Char] -> ByteArray Int
  , packCString#	-- :: [Char] -> ByteArray#

  , new_ps_array	-- :: Int# -> ST s (MutableByteArray s Int)
  , write_ps_array	-- :: MutableByteArray s Int -> Int# -> Char# -> ST s () 
  , freeze_ps_array	-- :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)

    -- unmarshaling (char*) vectors.
  , unvectorize         -- :: Addr -> Int -> IO [String]
  , vectorize	        -- :: [[Char]] -> IO (ByteArray Int)


  , allocChars          -- :: Int -> IO (MutableByteArray RealWorld Int)
  , allocWords          -- :: Int -> IO (MutableByteArray RealWorld Int)
  , freeze	        -- :: MutableByteArray RealWorld Int -> IO (ByteArray Int)
  , strcpy	        -- :: Addr -> IO String
  ) where

import Foreign.C.String
import GlaExts
import Addr
import GHC.Ptr
import GHC.Pack
import GHC.ST

packString :: [Char] -> ByteArray Int
packString str = runST (packStringST str)

packStringST :: [Char] -> ST s (ByteArray Int)
packStringST str =
  let len = length str  in
  packNBytesST len str

packNBytesST :: Int -> [Char] -> ST s (ByteArray Int)
packNBytesST (I# length#) str =
  {- 
   allocate an array that will hold the string
   (not forgetting the NUL byte at the end)
  -}
 new_ps_array (length# +# 1#) >>= \ ch_array ->
   -- fill in packed string from "str"
 fill_in ch_array 0# str   >>
   -- freeze the puppy:
 freeze_ps_array ch_array length#
 where
  fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
  fill_in arr_in# idx [] =
   write_ps_array arr_in# idx (chr# 0#) >>
   return ()

  fill_in arr_in# idx (C# c : cs) =
   write_ps_array arr_in# idx c	 >>
   fill_in arr_in# (idx +# 1#) cs

new_ps_array	:: Int# -> ST s (MutableByteArray s Int)
write_ps_array	:: MutableByteArray s Int -> Int# -> Char# -> ST s () 
freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)

new_ps_array size = ST $ \ s ->
    case (newByteArray# size s)	  of { (# s2#, barr# #) ->
    (# s2#, MutableByteArray bot bot barr# #) }
  where
    bot = error "new_ps_array"

write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
    case writeCharArray# barr# n ch s#	of { s2#   ->
    (# s2#, () #) }

-- same as unsafeFreezeByteArray
freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
    case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
    (# s2#, ByteArray 0 (I# len#) frozen# #) }


unpackNBytesST# :: Addr# -> Int# -> ST s [Char]
unpackNBytesST# addr# l#   = unpackNBytesAccST# addr# l# []

unpackNBytesAccST# :: Addr# -> Int# -> [Char] -> ST s [Char]
unpackNBytesAccST# _addr 0#   rest = return rest
unpackNBytesAccST#  addr len# rest = unpack rest (len# -# 1#)
  where
    unpack acc i# 
      | i# <# 0#  = return acc
      | otherwise  = 
	 case indexCharOffAddr# addr i# of
	  ch -> unpack (C# ch : acc) (i# -# 1#)

unpackCStringBA :: ByteArray Int -> [Char]
unpackCStringBA (ByteArray l@(I# l#) u@(I# u#) bytes) 
 | l > u     = []
 | otherwise = unpackCStringBA# bytes (u# -# l# +# 1#)

{-
 unpack until NUL or end of BA is reached, whatever comes first.
-}
unpackCStringBA# :: ByteArray# -> Int# -> [Char]
unpackCStringBA# bytes len
 = unpack 0#
 where
    unpack nh
      | nh >=# len         || 
        ch `eqChar#` '\0'#    = []
      | otherwise	      = C# ch : unpack (nh +# 1#)
      where
	ch = indexCharArray# bytes nh

unpackNBytesBA :: ByteArray Int -> Int -> [Char]
unpackNBytesBA (ByteArray l u bytes) i
 = unpackNBytesBA# bytes len#
   where
    len# = case max 0 (min i len) of I# v# -> v#
    len | l > u     = 0
        | otherwise = u-l+1

unpackNBytesBA# :: ByteArray# -> Int# -> [Char]
unpackNBytesBA# _bytes 0#   = []
unpackNBytesBA#  bytes len# = unpack [] (len# -# 1#)
   where
    unpack acc i#
     | i# <# 0#  = acc
     | otherwise = 
          case indexCharArray# bytes i# of
	    ch -> unpack (C# ch : acc) (i# -# 1#)

-- ----------------------------------------------------------------------------
-- chak: Old DEPRECATED routines - do not use, they might just vanish
-- ----------------------------------------------------------------------------

{-# DEPRECATED unpackCString "Use the module PackedString instead" #-}
unpackCString     (A# a)       = GHC.Pack.unpackCString     (Ptr a)
{-# DEPRECATED unpackNBytes "Use the module PackedString instead" #-}
unpackNBytes      (A# a) l     = unpackNBytes# a l
{-# DEPRECATED unpackNBytesST "Use the module PackedString instead" #-}
unpackNBytesST    (A# a) l     = unpackNBytesST#  a l
{-# DEPRECATED unpackNBytesAccST "Use the module PackedString instead" #-}
unpackNBytesAccST (A# a) l acc = unpackNBytesAccST# a l acc

{-# DEPRECATED unpackCStringST "Use the module PackedString instead" #-}
unpackCStringST  :: Addr -> ST s [Char]
unpackCStringST a@(A# addr)
  | a == nullAddr  = return []
  | otherwise	   = unpack 0#
  where
    unpack nh
      | ch `eqChar#` '\0'# = return []
      | otherwise	   = do
		ls <- unpack (nh +# 1#)
		return ((C# ch ) : ls)
      where
	ch = indexCharOffAddr# addr nh


{-# DEPRECATED packStringIO "Use the module PackedString instead" #-}
packStringIO :: [Char] -> IO (ByteArray Int)
packStringIO str = stToIO (packStringST str)


-- NOTE: unpackCStringIO must traverse the entire string before
-- returning, since it is often used on dynamically allocated strings
-- which need to be deallocated after unpacking.

{-# DEPRECATED unpackCStringIO "Use the module PackedString instead" #-}
unpackCStringIO :: Addr -> IO String
unpackCStringIO addr
 | addr == nullAddr = return "(null)"
 | otherwise        = unpack 0#
  where
    unpack nh = do
       ch <- readCharOffAddr addr (I# nh)
       if ch == '\0'
        then return []
        else do
         ls <- unpack (nh +# 1#)
         return (ch : ls)

{-# DEPRECATED unpackCStringLenIO "Use the module PackedString instead" #-}
-- unpack 'len' chars
unpackCStringLenIO :: Addr -> Int -> IO String
unpackCStringLenIO addr l@(I# len#)
 | len# <# 0#  = ioError (userError ("CString.unpackCStringLenIO: negative length (" ++ show l ++ ")"))
 | len# ==# 0# = return ""
 | otherwise   = unpack [] (len# -# 1#)
  where
    unpack acc 0# = do
       ch <- readCharOffAddr addr (I# 0#)
       return (ch:acc)
    unpack acc nh = do
       ch <- readCharOffAddr addr (I# nh)
       unpack (ch:acc) (nh -# 1#)

{-# DEPRECATED unpackNBytesAccIO "Use the module PackedString instead" #-}
unpackNBytesAccIO :: Addr -> Int -> [Char] -> IO [Char]
unpackNBytesAccIO (A# a) (I# len) acc = stToIO (unpackNBytesAccST# a len acc)

-- Turn a NULL-terminated vector of null-terminated strings into a string list
-- (ToDo: create a module of common marshaling functions)

{-# DEPRECATED unvectorize "Use the module PackedString instead" #-}
unvectorize :: Addr -> Int -> IO [String]
unvectorize ptr n
  | str == nullAddr = return []
  | otherwise       = do
	x  <- unpackCStringIO str
	xs <- unvectorize ptr (n+1)
	return (x : xs)
  where
   str = indexAddrOffAddr ptr n


--  Turn a string list into a NULL-terminated vector of null-terminated
-- strings No indices...I hate indices.  Death to Ix.

{-# DEPRECATED vectorize "Use the module PackedString instead" #-}
vectorize :: [String] -> IO (ByteArray Int)
vectorize vs = do
  arr <- allocWords (len + 1)
  fill arr 0 vs
  freeze arr
 where
    len :: Int
    len = length vs

    fill :: MutableByteArray RealWorld Int -> Int -> [String] -> IO ()
    fill arr n [] =
	_casm_ ``((PP_)%0)[%1] = NULL;'' arr n
    fill arr n (x:xs) = do
	barr <- packStringIO x
        _casm_ ``((PP_)%0)[%1] = (P_)%2;'' arr n barr
	fill arr (n+1) xs


-- Allocating chunks of memory in the Haskell heap, leaving
-- out the bounds - use with care.

{-# DEPRECATED allocChars "Use the module PackedString instead" #-}
-- Allocate a mutable array of characters with no indices.
allocChars :: Int -> IO (MutableByteArray RealWorld Int)
allocChars size = stToIO (newCharArray (0,size))

{-# DEPRECATED allocWords "Use the module PackedString instead" #-}
allocWords :: Int -> IO (MutableByteArray RealWorld Int)
allocWords size = stToIO (newIntArray (0,size))

{-# DEPRECATED freeze "Use the module PackedString instead" #-}
-- Freeze these index-free mutable arrays
freeze :: MutableByteArray RealWorld Int -> IO (ByteArray Int)
freeze mb = stToIO (unsafeFreezeByteArray mb)

{-# DEPRECATED strcpy "Use the module PackedString instead" #-}
-- Copy a null-terminated string from outside the heap to
-- Haskellized nonsense inside the heap
strcpy :: Addr -> IO String
strcpy str = unpackCStringIO str
