{-# LINE 1 "UI/HSCurses/CWString.hsc" #-}
-- Copyright (c) 2002-2004 John Meacham (john at repetae dot net)
-- 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 41 "UI/HSCurses/CWString.hsc" #-}

    -- Locale versions
    withLCString,
    withLCStringLen,
    newLCString,
    newLCStringLen,
    peekLCStringLen,
    peekLCString,
) where

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


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


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

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

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

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

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

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

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


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

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

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

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

newUTF8String :: String -> IO CString
newUTF8String :: String -> IO CString
newUTF8String = String -> IO CString
newCString (String -> IO CString)
-> (String -> String) -> String -> IO CString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toUTF

newUTF8StringLen :: String -> IO CStringLen
newUTF8StringLen :: String -> IO CStringLen
newUTF8StringLen = String -> IO CStringLen
newCStringLen (String -> IO CStringLen)
-> (String -> String) -> String -> IO CStringLen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toUTF

peekUTF8String :: CString -> IO String
peekUTF8String :: CString -> IO String
peekUTF8String CString
strPtr = (String -> String) -> IO String -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
fromUTF (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ CString -> IO String
peekCString CString
strPtr

peekUTF8StringLen :: CStringLen -> IO String
peekUTF8StringLen :: CStringLen -> IO String
peekUTF8StringLen CStringLen
strPtr = (String -> String) -> IO String -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
fromUTF (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ CStringLen -> IO String
peekCStringLen CStringLen
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 :: String -> String
toUTF [] = []
toUTF (Char
x : String
xs)
    | Char -> Int
ord Char
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x007F = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toUTF String
xs
    | Char -> Int
ord Char
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x07FF =
        Int -> Char
chr (Int
0xC0 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. ((Char -> Int
ord Char
x Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` (-Int
6)) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x1F))
            Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> Char
chr (Int
0x80 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (Char -> Int
ord Char
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3F))
            Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toUTF String
xs
    | Bool
otherwise =
        Int -> Char
chr (Int
0xE0 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. ((Char -> Int
ord Char
x Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` (-Int
12)) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x0F))
            Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> Char
chr (Int
0x80 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. ((Char -> Int
ord Char
x Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` (-Int
6)) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3F))
            Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> Char
chr (Int
0x80 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (Char -> Int
ord Char
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3F))
            Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toUTF String
xs

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

    threeBytes :: String -> String
threeBytes (Char
x1 : Char
x2 : Char
x3 : String
xs') =
        Int -> Char
chr
            ( ((Char -> Int
ord Char
x1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x0F) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` Int
12)
                Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. ((Char -> Int
ord Char
x2 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3F) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` Int
6)
                Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (Char -> Int
ord Char
x3 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3F)
            )
            Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
fromUTF String
xs'
    threeBytes String
_ = String -> String
forall a. HasCallStack => String -> a
error String
"fromUTF: illegal three byte sequence"

    err :: a
err = String -> a
forall a. HasCallStack => String -> a
error String
"fromUTF: illegal UTF-8 character"