    {-# LANGUAGE TypeFamilies #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE OverloadedStrings #-}
    --  GIMP Toolkit (GTK) UTF aware string marshalling
    --
    --  Author : Axel Simon
    --
    --  Created: 22 June 2001
    --
    --  Copyright (c) 1999..2002 Axel Simon
    --
    --  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.
    --
    -- |
    -- Maintainer  : gtk2hs-users@lists.sourceforge.net
    -- Stability   : provisional
    -- Portability : portable (depends on GHC)
    --
    -- This module adds CString-like functions that handle UTF8 strings.
    --

    module System.Glib.UTFString (
      GlibString(..),
      readUTFString,
      readCString,
      withUTFStrings,
      withUTFStringArray,
      withUTFStringArray0,
      peekUTFStringArray,
      peekUTFStringArray0,
      readUTFStringArray0,
      UTFCorrection,
      ofsToUTF,
      ofsFromUTF,

      glibToString,
      stringToGlib,

      DefaultGlibString,

      GlibFilePath(..),
      withUTFFilePaths,
      withUTFFilePathArray,
      withUTFFilePathArray0,
      peekUTFFilePathArray0,
      readUTFFilePathArray0
      ) where

    import Codec.Binary.UTF8.String
    import Control.Applicative ((<$>))
    import Control.Monad (liftM)
    import Data.Char (ord, chr)
    import Data.Maybe (maybe)
    import Data.String (IsString)
    import Data.Monoid (Monoid)
    import System.Glib.FFI
    import qualified Data.Text as T (replace, length, pack, unpack, Text)
    import qualified Data.Text.Foreign as T
           (withCStringLen, peekCStringLen)
    import Data.ByteString (useAsCString)
    import Data.Text.Encoding (encodeUtf8)

    class (IsString s, Monoid s, Show s) => GlibString s where
        -- | Like 'withCString' but using the UTF-8 encoding.
        --
        withUTFString :: s -> (CString -> IO a) -> IO a

        -- | Like 'withCStringLen' but using the UTF-8 encoding.
        --
        withUTFStringLen :: s -> (CStringLen -> IO a) -> IO a

        -- | Like 'peekCString' but using the UTF-8 encoding.
        --
        peekUTFString :: CString -> IO s

        -- | Like 'maybePeek' 'peekCString' but using the UTF-8 encoding to retrieve
        -- UTF-8 from a 'CString' which may be the 'nullPtr'.
        --
        maybePeekUTFString :: CString -> IO (Maybe s)

        -- | Like 'peekCStringLen' but using the UTF-8 encoding.
        --
        peekUTFStringLen :: CStringLen -> IO s

        -- | Like 'newCString' but using the UTF-8 encoding.
        --
        newUTFString :: s -> IO CString

        -- | Like  Define newUTFStringLen to emit UTF-8.
        --
        newUTFStringLen :: s -> IO CStringLen

        -- | Create a list of offset corrections.
        --
        genUTFOfs :: s -> UTFCorrection

        -- | Length of the string in characters
        --
        stringLength :: s -> Int

        -- Escape percent signs (used in MessageDialog)
        unPrintf :: s -> s

    -- GTK+ has a lot of asserts that the ptr is not NULL even if the length is 0
    -- Until they fix this we need to fudge pointer values to keep the noise level
    -- in the logs.
    noNullPtrs :: CStringLen -> CStringLen
    noNullPtrs (p, 0) | p == nullPtr = (plusPtr p 1, 0)
    noNullPtrs s = s

    instance GlibString [Char] where
        withUTFString = withCAString . encodeString
        withUTFStringLen s f = withCAStringLen (encodeString s) (f . noNullPtrs)
        peekUTFString = liftM decodeString . peekCAString
        maybePeekUTFString = liftM (maybe Nothing (Just . decodeString)) . maybePeek peekCAString
        peekUTFStringLen = liftM decodeString . peekCAStringLen
        newUTFString = newCAString . encodeString
        newUTFStringLen = newCAStringLen . encodeString
        genUTFOfs str = UTFCorrection (gUO 0 str)
          where
          gUO n [] = []
          gUO n (x:xs) | ord x<=0x007F = gUO (n+1) xs
                       | ord x<=0x07FF = n:gUO (n+1) xs
                       | ord x<=0xFFFF = n:n:gUO (n+1) xs
                       | otherwise     = n:n:n:gUO (n+1) xs
        stringLength = length
        unPrintf s = s >>= replace
            where
                replace '%' = "%%"
                replace c = return c

    foreign import ccall unsafe "string.h strlen" c_strlen
        :: CString -> IO CSize

    instance GlibString T.Text where
        withUTFString = useAsCString . encodeUtf8
        withUTFStringLen s f = T.withCStringLen s (f . noNullPtrs)
        peekUTFString s = do
            len <- c_strlen s
            T.peekCStringLen (s, fromIntegral len)
        maybePeekUTFString = maybePeek peekUTFString
        peekUTFStringLen = T.peekCStringLen
        newUTFString = newUTFString . T.unpack -- TODO optimize
        newUTFStringLen = newUTFStringLen . T.unpack -- TODO optimize
        genUTFOfs = genUTFOfs . T.unpack -- TODO optimize
        stringLength = T.length
        unPrintf = T.replace "%" "%%"

    glibToString :: T.Text -> String
    glibToString = T.unpack

    stringToGlib :: String -> T.Text
    stringToGlib = T.pack

    -- | Like like 'peekUTFString' but then frees the string using g_free
    --
    readUTFString :: GlibString s => CString -> IO s
    readUTFString strPtr = do
      str <- peekUTFString strPtr
      g_free strPtr
      return str

    -- | Like 'peekCString' but then frees the string using @g_free@.
    --
    readCString :: CString -> IO String
    readCString strPtr = do
      str <- peekCAString strPtr
      g_free strPtr
      return str

    foreign import ccall unsafe "g_free"
      g_free :: Ptr a -> IO ()

    -- | Temporarily allocate a list of UTF-8 'CString's.
    --
    withUTFStrings :: GlibString s => [s] -> ([CString] -> IO a) -> IO a
    withUTFStrings hsStrs = withUTFStrings' hsStrs []
      where withUTFStrings' :: GlibString s => [s] -> [CString] -> ([CString] -> IO a) -> IO a
            withUTFStrings' []     cs body = body (reverse cs)
            withUTFStrings' (s:ss) cs body = withUTFString s $ \c ->
                                             withUTFStrings' ss (c:cs) body

    -- | Temporarily allocate an array of UTF-8 encoded 'CString's.
    --
    withUTFStringArray :: GlibString s => [s] -> (Ptr CString -> IO a) -> IO a
    withUTFStringArray hsStr body =
      withUTFStrings hsStr $ \cStrs -> do
      withArray cStrs body

    -- | Temporarily allocate a null-terminated array of UTF-8 encoded 'CString's.
    --
    withUTFStringArray0 :: GlibString s => [s] -> (Ptr CString -> IO a) -> IO a
    withUTFStringArray0 hsStr body =
      withUTFStrings hsStr $ \cStrs -> do
      withArray0 nullPtr cStrs body

    -- | Convert an array (of the given length) of UTF-8 encoded 'CString's to a
    --   list of Haskell 'String's.
    --
    peekUTFStringArray :: GlibString s => Int -> Ptr CString -> IO [s]
    peekUTFStringArray len cStrArr = do
      cStrs <- peekArray len cStrArr
      mapM peekUTFString cStrs

    -- | Convert a null-terminated array of UTF-8 encoded 'CString's to a list of
    --   Haskell 'String's.
    --
    peekUTFStringArray0 :: GlibString s => Ptr CString -> IO [s]
    peekUTFStringArray0 cStrArr = do
      cStrs <- peekArray0 nullPtr cStrArr
      mapM peekUTFString cStrs

    -- | Like 'peekUTFStringArray0' but then free the string array including all
    -- strings.
    --
    -- To be used when functions indicate that their return value should be freed
    -- with @g_strfreev@.
    --
    readUTFStringArray0 :: GlibString s => Ptr CString -> IO [s]
    readUTFStringArray0 cStrArr | cStrArr == nullPtr = return []
                                | otherwise = do
      cStrs <- peekArray0 nullPtr cStrArr
      strings <- mapM peekUTFString cStrs
      g_strfreev cStrArr
      return strings

    foreign import ccall unsafe "g_strfreev"
      g_strfreev :: Ptr a -> IO ()

    -- | Offset correction for String to UTF8 mapping.
    --
    newtype UTFCorrection = UTFCorrection [Int] deriving Show

    ofsToUTF :: Int -> UTFCorrection -> Int
    ofsToUTF n (UTFCorrection oc) = oTU oc
      where
      oTU [] = n
      oTU (x:xs) | n<=x = n
                 | otherwise = 1+oTU xs

    ofsFromUTF :: Int -> UTFCorrection -> Int
    ofsFromUTF n (UTFCorrection oc) = oFU n oc
      where
      oFU n [] = n
      oFU n (x:xs) | n<=x = n
                   | otherwise = oFU (n-1) xs

    type DefaultGlibString = T.Text

    class fp ~ FilePath => GlibFilePath fp where
        withUTFFilePath :: fp -> (CString -> IO a) -> IO a
        peekUTFFilePath :: CString -> IO fp

    instance GlibFilePath FilePath where
        withUTFFilePath = withUTFString . T.pack
        peekUTFFilePath f = T.unpack <$> peekUTFString f

    withUTFFilePaths :: GlibFilePath fp => [fp] -> ([CString] -> IO a) -> IO a
    withUTFFilePaths hsStrs = withUTFFilePath' hsStrs []
      where withUTFFilePath' :: GlibFilePath fp => [fp] -> [CString] -> ([CString] -> IO a) -> IO a
            withUTFFilePath' []       cs body = body (reverse cs)
            withUTFFilePath' (fp:fps) cs body = withUTFFilePath fp $ \c ->
                                                withUTFFilePath' fps (c:cs) body

    withUTFFilePathArray :: GlibFilePath fp => [fp] -> (Ptr CString -> IO a) -> IO a
    withUTFFilePathArray hsFP body =
      withUTFFilePaths hsFP $ \cStrs -> do
      withArray cStrs body

    withUTFFilePathArray0 :: GlibFilePath fp => [fp] -> (Ptr CString -> IO a) -> IO a
    withUTFFilePathArray0 hsFP body =
      withUTFFilePaths hsFP $ \cStrs -> do
      withArray0 nullPtr cStrs body

    peekUTFFilePathArray0 :: GlibFilePath fp => Ptr CString -> IO [fp]
    peekUTFFilePathArray0 cStrArr = do
      cStrs <- peekArray0 nullPtr cStrArr
      mapM peekUTFFilePath cStrs

    readUTFFilePathArray0 :: GlibFilePath fp => Ptr CString -> IO [fp]
    readUTFFilePathArray0 cStrArr | cStrArr == nullPtr = return []
                                  | otherwise = do
      cStrs <- peekArray0 nullPtr cStrArr
      fps <- mapM peekUTFFilePath cStrs
      g_strfreev cStrArr
      return fps