module Graphics.Text.Font.Choose.LangSet where

import Data.Set (Set)
import qualified Data.Set as Set
import Graphics.Text.Font.Choose.Strings (thawStrSet, StrSet_)
import Graphics.Text.Font.Choose.CharSet (thawCharSet, CharSet_, CharSet)

import Foreign.Ptr (Ptr)
import Foreign.C.String (CString, withCString, peekCString)
import Control.Exception (bracket)
import Control.Monad (forM)
import System.IO.Unsafe (unsafePerformIO)

type LangSet = Set String

defaultLangs :: IO LangSet
defaultLangs = thawStrSet =<< fcGetDefaultLangs
foreign import ccall "FcGetDefaultLangs" fcGetDefaultLangs :: IO StrSet_

langs :: LangSet
langs = unsafePerformIO (thawStrSet =<< fcGetLangs)
foreign import ccall "FcGetLangs" fcGetLangs :: IO StrSet_

data LangResult = SameLang | DifferentTerritory | DifferentLang deriving Enum
langSetCompare :: LangSet -> LangSet -> LangResult
langSetCompare a b = unsafePerformIO $ withLangSet a $ \a' -> withLangSet b $ \b' ->
    (toEnum <$> fcLangSetCompare a' b')
foreign import ccall "FcLangSetCompare" fcLangSetCompare ::
    LangSet_ -> LangSet_ -> IO Int

langNormalize :: String -> String
langNormalize lang = unsafePerformIO $ withCString lang (peekCString . fcLangNormalize)
foreign import ccall "FcLangNormalize" fcLangNormalize :: CString -> CString

langCharSet :: String -> CharSet
langCharSet lang = unsafePerformIO $ withCString lang (thawCharSet . fcLangGetCharSet)
foreign import ccall "FcLangGetCharSet" fcLangGetCharSet :: CString -> CharSet_

------
--- Low-level
------

data LangSet'
type LangSet_ = Ptr LangSet'

withNewLangSet :: (LangSet_ -> IO a) -> IO a
withNewLangSet = bracket fcLangSetCreate fcLangSetDestroy
foreign import ccall "FcLangSetCreate" fcLangSetCreate :: IO LangSet_
foreign import ccall "FcLangSetDestroy" fcLangSetDestroy :: LangSet_ -> IO ()

withLangSet :: LangSet -> (LangSet_ -> IO a) -> IO a
withLangSet langs cb = withNewLangSet $ \langs' -> do
    forM (Set.elems langs) $ flip withCString $ fcLangSetAdd langs'
    cb langs'
foreign import ccall "FcLangSetAdd" fcLangSetAdd :: LangSet_ -> CString -> IO Bool

thawLangSet :: LangSet_ -> IO LangSet
thawLangSet langs' = thawStrSet =<< fcLangSetGetLangs langs'
foreign import ccall "FcLangSetGetLangs" fcLangSetGetLangs :: LangSet_ -> IO StrSet_