{-# OPTIONS -fglasgow-exts -ffi  -#include <wchar.h> #-}
-- arch-tag: 72067bff-05e1-4c0e-94aa-34b54f437d92

module CWString (
    -- wchar stuff
    withCWString,
    withCWStringLen,
    newCWString,
    newCWStringLen,
    peekCWString,
    peekCWStringLen,
    wcharIsUnicode,
    CWchar,
    CWString, 
    CWStringLen,
    -- locale versions 
    withCString,
    withCStringLen,
    newCString,
    newCStringLen,
    peekCStringLen,
    peekCString,
    charIsRepresentable,
    module CWStringBasic


    ) where


import Data.Bits
import Foreign.C.String(CString, CStringLen)
import Foreign.C.Types
import Char
import Foreign
import Monad
import qualified CForeign
import GHC.Exts
import IO
import CWStringBasic

#if !defined(__STDC_ISO_10646__)
import IConv
#endif


-- x#ifndef CONFIG_INCLUDED
-- x#define CONFIG_INCLUDED
-- x#include <config.h>
-- x#endif
#include <wchar.h>
#include <limits.h>
#include <stdlib.h>


type CWString = Ptr CWchar
type CWStringLen = (CWString, Int)
                     
peekCString :: CString -> IO String
peekCStringLen :: CStringLen -> IO String
newCString :: String -> IO CString
newCStringLen :: String -> IO CStringLen
withCString :: String -> (CString -> IO a) -> IO a
withCStringLen :: String -> (CStringLen -> IO a) -> IO a
peekCWString :: CWString -> IO String
peekCWStringLen :: CWStringLen -> IO String
withCWStringLen :: String -> (CWStringLen -> IO a) -> IO a
withCWString :: String -> (CWString -> IO a) -> IO a
newCWStringLen :: String -> IO CWStringLen
newCWString :: String -> IO CWString

-- useful functions
fi x = fromIntegral x
--pairLength :: String -> CString -> CStringLen
pairLength  = flip (,) . length

-------------------
-- CWchar functions
-------------------

{-# INLINE wcharIsUnicode #-}
wcharIsUnicode :: Bool

#if defined(__STDC_ISO_10646__)

wcharIsUnicode = True

-- support functions 
wNUL :: CWchar
wNUL = 0
#ifndef __GLASGOW_HASKELL__

cwCharsToChars :: [CWchar] -> [Char]
cwCharsToChars xs  = map castCWcharToChar xs
charsToCWchars :: [Char] -> [CWchar]
charsToCWchars xs  = map castCharToCWchar xs


#endif

castCWcharToChar :: CWchar -> Char
castCWcharToChar ch = chr (fromIntegral ch )

castCharToCWchar :: Char -> CWchar
castCharToCWchar ch = fromIntegral (ord ch)


-- exported functions
#ifndef __GLASGOW_HASKELL__
peekCString cp  = do cs <- peekArray0 wNUL cp; return (cwCharsToChars cs)
#else
peekCWString cp = loop 0
  where
    loop i = do
        val <- peekElemOff cp i
        if val == wNUL then return [] else do
            rest <- loop (i+1)
            return (castCWcharToChar val : rest)
#endif

#ifndef __GLASGOW_HASKELL__
peekCWStringLen (cp, len)  = do cs <- peekArray len cp; return (cwCharsToChars cs)
#else
peekCWStringLen (cp, len) = loop 0
  where
    loop i | i == len  = return []
	   | otherwise = do
        	val <- peekElemOff cp i
        	rest <- loop (i+1)
        	return (castCWcharToChar val : rest)
#endif

#ifndef __GLASGOW_HASKELL__
newCWString  = newArray0 wNUL . charsToCWchars
#else
newCWString str = do
  ptr <- mallocArray0 (length str)
  let
	go [] n##   = pokeElemOff ptr (I## n##) wNUL
    	go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWchar c); go cs (n## +## 1##)
  go str 0##
  return ptr
#endif

#ifndef __GLASGOW_HASKELL__
newCWStringLen str  = do a <- newArray (charsToCWchars str)
			return (pairLength str a)
#else
newCWStringLen str = do
  ptr <- mallocArray0 len
  let
	go [] n##     = return ()
    	go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWchar c); go cs (n## +## 1##)
  go str 0##
  return (ptr, len)
  where
    len = length str
#endif

#ifndef __GLASGOW_HASKELL__
withCWString  = withArray0 wNUL . charsToCWchars
#else
withCWString str f =
  allocaArray0 (length str) $ \ptr ->
      let
	go [] n##     = pokeElemOff ptr (I## n##) wNUL
    	go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWchar c); go cs (n## +## 1##)
      in do
      go str 0##
      f ptr
#endif

#ifndef __GLASGOW_HASKELL__
withCWStringLen str act  = withArray (charsToCWchars str) $ act . pairLength str
#else
withCWStringLen str f =
  allocaArray len $ \ptr ->
      let
	go [] n##     = return ()
    	go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWchar c); go cs (n## +## 1##)
      in do
      go str 0##
      f (ptr,len)
  where
    len = length str
#endif

newtype MBState = MBState { _mbstate :: (Ptr MBState)}

withMBState :: (MBState -> IO a) -> IO a
withMBState act = allocaBytes (#const sizeof(mbstate_t)) (\mb -> c_memset mb 0 (#const sizeof(mbstate_t)) >> act (MBState mb)) 

clearMBState :: MBState -> IO ()
clearMBState (MBState mb) = c_memset mb 0 (#const sizeof(mbstate_t)) >> return ()




wcsrtombs :: CWString -> (CString, CSize) -> IO CSize
wcsrtombs wcs (cs,len) = alloca (\p -> poke p wcs >> withMBState (\mb -> wcsrtombs' p cs len mb)) where
    wcsrtombs'  p cs len mb = c_wcsrtombs cs p len mb >>= \x -> case x of 
        -1 -> do
            sp <- peek p 
            poke sp ((fi (ord '?'))::CWchar)
            poke p wcs
            clearMBState mb
            wcsrtombs' p cs len mb
        _ -> return x

#def inline HsInt hs_get_mb_cur_max () { return MB_CUR_MAX; }
foreign import ccall unsafe hs_get_mb_cur_max :: IO Int 

mb_cur_max :: Int
mb_cur_max = unsafePerformIO hs_get_mb_cur_max 


charIsRepresentable :: Char -> IO Bool
charIsRepresentable ch = fmap (/= -1) $ allocaBytes mb_cur_max (\cs -> c_wctomb cs (fi $ ord ch)) 

foreign import ccall unsafe "stdlib.h wctomb" c_wctomb :: CString -> CWchar -> IO CInt
foreign import ccall unsafe "stdlib.h wcsrtombs" c_wcsrtombs :: CString -> (Ptr (Ptr CWchar)) -> CSize -> MBState -> IO CSize
foreign import ccall unsafe "string.h memset" c_memset :: Ptr a -> CInt -> CSize -> IO (Ptr a)

foreign import ccall unsafe "stdlib.h mbstowcs" c_mbstowcs :: CWString -> CString -> CSize -> IO CSize

mbstowcs a b s = throwIf (== -1) (const "mbstowcs") $ c_mbstowcs a b s 


peekCString cp  = do 
    sz <- mbstowcs nullPtr cp 0
    allocaArray (fi $ sz + 1) (\wcp -> mbstowcs wcp cp (sz + 1) >> peekCWString wcp)

-- TODO fix for embeded NULs
peekCStringLen (cp, len)  =  allocaBytes (len + 1) $ \ncp -> do
    copyBytes ncp cp len
    pokeElemOff ncp len 0
    peekCString ncp

newCString s = withCWString s $ \wcs -> do mallocArray0 alen >>= \cs -> wcsrtombs wcs (cs, fi alen) >> return cs where
    alen = mb_cur_max * length s

newCStringLen str  = newCString str >>= \cs -> return (pairLength str cs)

withCString s a = withCWString s $ \wcs -> allocaArray0 alen (\cs -> wcsrtombs wcs (cs,fi alen) >> a cs) where
    alen = mb_cur_max * length s

withCStringLen s a = withCWString s $ \wcs -> allocaArray0 alen (\cs -> wcsrtombs wcs (cs,fi alen) >>= \sz -> a (cs,fi sz)) where
    alen = mb_cur_max * length s



#else

wcharIsUnicode = False  

charIsRepresentable :: Char -> IO Bool
charIsRepresentable ch = IConv.isRepresentable "" ch

 
withCString s action = stringToBytes s >>= \s -> withArray0 0 s (action . castPtr)
withCStringLen str act = (stringToBytes str) >>= \s -> withArray s $ act . pairLength str . castPtr
newCString s = stringToBytes s >>= \s -> newArray0 0 s >>= return . castPtr
newCStringLen str  = newCString str >>= \cs -> return (pairLength str (castPtr cs))
peekCString cp = do cs <- peekArray0 0 (castPtr cp);  bytesToString cs
peekCStringLen (cp, len)  = do cs <- peekArray len (castPtr cp);  (bytesToString cs)

withCWString s action = stringToCWchars s >>= \s -> withArray0 0 s action
withCWStringLen str act = (stringToCWchars str) >>= \s -> withArray s $ act . pairLength str
newCWString s = stringToCWchars s >>= newArray0 0 
newCWStringLen str  = newCWString str >>= \cs -> return (pairLength str cs)
peekCWString cp = do cs <- peekArray0 0 (castPtr cp);  (cwcharsToString cs)
peekCWStringLen (cp, len)  = do cs <- peekArray len (castPtr cp); (cwcharsToString cs)

#endif