{-# LINE 1 "UI/HSCurses/CWString.hsc" #-}
-- Copyright (c) 2002-2004 John Meacham (john at repetae dot net)
{-# LINE 2 "UI/HSCurses/CWString.hsc" #-}
-- Copyright (c) 2004      Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA


module UI.HSCurses.CWString (

    -- * utf8 versions
    withUTF8String,
    withUTF8StringLen,
    newUTF8String,
    newUTF8StringLen,
    peekUTF8String,
    peekUTF8StringLen,

    -- * WChar stuff

{-# LINE 42 "UI/HSCurses/CWString.hsc" #-}
    -- * Locale versions
    withLCString,
    withLCStringLen,
    newLCString,
    newLCStringLen,
    peekLCStringLen,
    peekLCString,
--  charIsRepresentable

    ) where

import Data.Char            ( ord, chr )
import Data.Bits            ( Bits((.|.), (.&.), shift) )
import Foreign.C.String


{-# LINE 60 "UI/HSCurses/CWString.hsc" #-}


{-# LINE 303 "UI/HSCurses/CWString.hsc" #-}
-- -----------------------------------------------------------
-- no CF_WCHAR_SUPPORT (OpenBSD)

{-
charIsRepresentable :: Char -> IO Bool
charIsRepresentable ch = return $ isLatin1 ch
-}

withLCString :: String -> (Foreign.C.String.CString -> IO a) -> IO a
withLCString = withCString

withLCStringLen  :: String -> (Foreign.C.String.CStringLen -> IO a) -> IO a
withLCStringLen = withCStringLen

newLCString :: String -> IO Foreign.C.String.CString
newLCString = newCString

newLCStringLen :: String -> IO Foreign.C.String.CStringLen
newLCStringLen = newCStringLen

peekLCString :: Foreign.C.String.CString -> IO String
peekLCString = peekCString

peekLCStringLen :: Foreign.C.String.CStringLen -> IO String
peekLCStringLen = peekCStringLen


{-# LINE 330 "UI/HSCurses/CWString.hsc" #-}
-- no CF_WCHAR_SUPPORT

-----------------
-- UTF8 versions
-----------------

withUTF8String :: String -> (CString -> IO a) -> IO a
withUTF8String hsStr = withCString (toUTF hsStr)

withUTF8StringLen :: String -> (CStringLen -> IO a) -> IO a
withUTF8StringLen hsStr = withCStringLen (toUTF hsStr)

newUTF8String :: String -> IO CString
newUTF8String = newCString . toUTF

newUTF8StringLen :: String -> IO CStringLen
newUTF8StringLen = newCStringLen . toUTF

peekUTF8String :: CString -> IO String
peekUTF8String strPtr = fmap fromUTF $ peekCString strPtr

peekUTF8StringLen :: CStringLen -> IO String
peekUTF8StringLen strPtr = fmap fromUTF $ peekCStringLen strPtr

-- these should read and write directly from/to memory.
-- A first pass will be needed to determine the size of the allocated region

toUTF :: String -> String
toUTF [] = []
toUTF (x:xs) | ord x<=0x007F = x:toUTF xs
             | ord x<=0x07FF = chr (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)):
                               chr (0x80 .|. (ord x .&. 0x3F)):
                               toUTF xs
             | otherwise     = chr (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)):
                               chr (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)):
                               chr (0x80 .|. (ord x .&. 0x3F)):
                               toUTF xs

fromUTF :: String -> String
fromUTF [] = []
fromUTF (al@(x:xs)) | ord x<=0x7F = x:fromUTF xs
                     | ord x<=0xBF = err
                     | ord x<=0xDF = twoBytes al
                     | ord x<=0xEF = threeBytes al
                     | otherwise   = err
  where
    twoBytes (x1:x2:xs') = chr (((ord x1 .&. 0x1F) `shift` 6) .|.
                               (ord x2 .&. 0x3F)):fromUTF xs'
    twoBytes _ = error "fromUTF: illegal two byte sequence"

    threeBytes (x1:x2:x3:xs') = chr (((ord x1 .&. 0x0F) `shift` 12) .|.
                                    ((ord x2 .&. 0x3F) `shift` 6) .|.
                                    (ord x3 .&. 0x3F)):fromUTF xs'
    threeBytes _ = error "fromUTF: illegal three byte sequence"

    err = error "fromUTF: illegal UTF-8 character"