module Graphics.Text.Font.Choose.LangSet (LangSet, defaultLangs, langs,
    langSetCompare, langNormalize, langCharSet,
    LangSet_, withLangSet, thawLangSet) where

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

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

-- | An `LangSet` is a set of language names (each of which include language and
-- an optional territory). They are used when selecting fonts to indicate which
-- languages the fonts need to support. Each font is marked, using language
-- orthography information built into fontconfig, with the set of supported languages.
type LangSet = Set String

-- | Returns a string set of the default languages according to the environment
-- variables on the system. This function looks for them in order of FC_LANG,
-- LC_ALL, LC_CTYPE and LANG then. If there are no valid values in those
-- environment variables, "en" will be set as fallback.
defaultLangs :: IO LangSet
defaultLangs :: IO LangSet
defaultLangs = StrSet_ -> IO LangSet
thawStrSet (StrSet_ -> IO LangSet) -> IO StrSet_ -> IO LangSet
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO StrSet_
fcGetDefaultLangs
foreign import ccall "FcGetDefaultLangs" fcGetDefaultLangs :: IO StrSet_

-- | Returns a string set of all known languages.
langs :: LangSet
langs :: LangSet
langs = IO LangSet -> LangSet
forall a. IO a -> a
unsafePerformIO (IO LangSet -> LangSet) -> IO LangSet -> LangSet
forall a b. (a -> b) -> a -> b
$ IO StrSet_ -> IO LangSet
thawStrSet_ (IO StrSet_ -> IO LangSet) -> IO StrSet_ -> IO LangSet
forall a b. (a -> b) -> a -> b
$ IO StrSet_
fcGetLangs
foreign import ccall "FcGetLangs" fcGetLangs :: IO StrSet_

-- | Result of language comparisons.
data LangResult = SameLang | DifferentTerritory | DifferentLang
    deriving (Int -> LangResult
LangResult -> Int
LangResult -> [LangResult]
LangResult -> LangResult
LangResult -> LangResult -> [LangResult]
LangResult -> LangResult -> LangResult -> [LangResult]
(LangResult -> LangResult)
-> (LangResult -> LangResult)
-> (Int -> LangResult)
-> (LangResult -> Int)
-> (LangResult -> [LangResult])
-> (LangResult -> LangResult -> [LangResult])
-> (LangResult -> LangResult -> [LangResult])
-> (LangResult -> LangResult -> LangResult -> [LangResult])
-> Enum LangResult
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: LangResult -> LangResult -> LangResult -> [LangResult]
$cenumFromThenTo :: LangResult -> LangResult -> LangResult -> [LangResult]
enumFromTo :: LangResult -> LangResult -> [LangResult]
$cenumFromTo :: LangResult -> LangResult -> [LangResult]
enumFromThen :: LangResult -> LangResult -> [LangResult]
$cenumFromThen :: LangResult -> LangResult -> [LangResult]
enumFrom :: LangResult -> [LangResult]
$cenumFrom :: LangResult -> [LangResult]
fromEnum :: LangResult -> Int
$cfromEnum :: LangResult -> Int
toEnum :: Int -> LangResult
$ctoEnum :: Int -> LangResult
pred :: LangResult -> LangResult
$cpred :: LangResult -> LangResult
succ :: LangResult -> LangResult
$csucc :: LangResult -> LangResult
Enum, LangResult -> LangResult -> Bool
(LangResult -> LangResult -> Bool)
-> (LangResult -> LangResult -> Bool) -> Eq LangResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LangResult -> LangResult -> Bool
$c/= :: LangResult -> LangResult -> Bool
== :: LangResult -> LangResult -> Bool
$c== :: LangResult -> LangResult -> Bool
Eq, ReadPrec [LangResult]
ReadPrec LangResult
Int -> ReadS LangResult
ReadS [LangResult]
(Int -> ReadS LangResult)
-> ReadS [LangResult]
-> ReadPrec LangResult
-> ReadPrec [LangResult]
-> Read LangResult
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LangResult]
$creadListPrec :: ReadPrec [LangResult]
readPrec :: ReadPrec LangResult
$creadPrec :: ReadPrec LangResult
readList :: ReadS [LangResult]
$creadList :: ReadS [LangResult]
readsPrec :: Int -> ReadS LangResult
$creadsPrec :: Int -> ReadS LangResult
Read, Int -> LangResult -> ShowS
[LangResult] -> ShowS
LangResult -> String
(Int -> LangResult -> ShowS)
-> (LangResult -> String)
-> ([LangResult] -> ShowS)
-> Show LangResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LangResult] -> ShowS
$cshowList :: [LangResult] -> ShowS
show :: LangResult -> String
$cshow :: LangResult -> String
showsPrec :: Int -> LangResult -> ShowS
$cshowsPrec :: Int -> LangResult -> ShowS
Show)
-- | `langSetCompare` compares language coverage for ls_a and ls_b.
-- If they share any language and territory pair, returns `SameLang`.
-- If they share a language but differ in which territory that language is for,
-- this function returns `DifferentTerritory`.
-- If they share no languages in common, this function returns `DifferentLang`.
langSetCompare :: LangSet -> LangSet -> LangResult
langSetCompare :: LangSet -> LangSet -> LangResult
langSetCompare a :: LangSet
a b :: LangSet
b = IO LangResult -> LangResult
forall a. IO a -> a
unsafePerformIO (IO LangResult -> LangResult) -> IO LangResult -> LangResult
forall a b. (a -> b) -> a -> b
$ LangSet -> (LangSet_ -> IO LangResult) -> IO LangResult
forall a. LangSet -> (LangSet_ -> IO a) -> IO a
withLangSet LangSet
a ((LangSet_ -> IO LangResult) -> IO LangResult)
-> (LangSet_ -> IO LangResult) -> IO LangResult
forall a b. (a -> b) -> a -> b
$ \a' :: LangSet_
a' -> LangSet -> (LangSet_ -> IO LangResult) -> IO LangResult
forall a. LangSet -> (LangSet_ -> IO a) -> IO a
withLangSet LangSet
b ((LangSet_ -> IO LangResult) -> IO LangResult)
-> (LangSet_ -> IO LangResult) -> IO LangResult
forall a b. (a -> b) -> a -> b
$ \b' :: LangSet_
b' ->
    (Int -> LangResult
forall a. Enum a => Int -> a
toEnum (Int -> LangResult) -> IO Int -> IO LangResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LangSet_ -> LangSet_ -> IO Int
fcLangSetCompare LangSet_
a' LangSet_
b')
foreign import ccall "FcLangSetCompare" fcLangSetCompare ::
    LangSet_ -> LangSet_ -> IO Int

-- | `langSetContains` returns FcTrue if ls_a contains every language in ls_b.
-- ls_a will 'contain' a language from ls_b if ls_a has exactly the language,
-- or either the language or ls_a has no territory.
langSetContains :: LangSet -> LangSet -> Bool
langSetContains :: LangSet -> LangSet -> Bool
langSetContains a :: LangSet
a b :: LangSet
b = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LangSet -> (LangSet_ -> IO Bool) -> IO Bool
forall a. LangSet -> (LangSet_ -> IO a) -> IO a
withLangSet LangSet
a ((LangSet_ -> IO Bool) -> IO Bool)
-> (LangSet_ -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \a' :: LangSet_
a' -> LangSet -> (LangSet_ -> IO Bool) -> IO Bool
forall a. LangSet -> (LangSet_ -> IO a) -> IO a
withLangSet LangSet
b ((LangSet_ -> IO Bool) -> IO Bool)
-> (LangSet_ -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$
    LangSet_ -> LangSet_ -> IO Bool
fcLangSetContains LangSet_
a'
foreign import ccall "FcLangSetContains" fcLangSetContains ::
    LangSet_ -> LangSet_ -> IO Bool

-- | FcLangSetHasLang checks whether ls supports lang.
-- If ls has a matching language and territory pair, this function returns
-- `SameLang`. If ls has a matching language but differs in which territory
-- that language is for, this function returns `DifferentTerritory`. If ls has
-- no matching language, this function returns `DifferentLang`.
langSetHasLang :: LangSet -> String -> LangResult
langSetHasLang :: LangSet -> String -> LangResult
langSetHasLang a :: LangSet
a b :: String
b = IO LangResult -> LangResult
forall a. IO a -> a
unsafePerformIO (IO LangResult -> LangResult) -> IO LangResult -> LangResult
forall a b. (a -> b) -> a -> b
$ LangSet -> (LangSet_ -> IO LangResult) -> IO LangResult
forall a. LangSet -> (LangSet_ -> IO a) -> IO a
withLangSet LangSet
a ((LangSet_ -> IO LangResult) -> IO LangResult)
-> (LangSet_ -> IO LangResult) -> IO LangResult
forall a b. (a -> b) -> a -> b
$ \a' :: LangSet_
a' -> String -> (CString -> IO LangResult) -> IO LangResult
forall a. String -> (CString -> IO a) -> IO a
withCString String
b ((CString -> IO LangResult) -> IO LangResult)
-> (CString -> IO LangResult) -> IO LangResult
forall a b. (a -> b) -> a -> b
$ \b' :: CString
b' ->
    (Int -> LangResult
forall a. Enum a => Int -> a
toEnum (Int -> LangResult) -> IO Int -> IO LangResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LangSet_ -> CString -> IO Int
fcLangSetHasLang LangSet_
a' CString
b')
foreign import ccall "FcLangSetHasLang" fcLangSetHasLang :: LangSet_ -> CString -> IO Int

-- | Returns a string to make lang suitable on FontConfig.
langNormalize :: String -> String
langNormalize :: ShowS
langNormalize "" = ""
langNormalize lang :: String
lang = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ String -> (CString -> IO String) -> IO String
forall a. String -> (CString -> IO a) -> IO a
withCString String
lang (CString -> IO String
peekCString_ (CString -> IO String)
-> (CString -> CString) -> CString -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> CString
fcLangNormalize)
foreign import ccall "FcLangNormalize" fcLangNormalize :: CString -> CString
peekCString_ :: CString -> IO String
peekCString_ str' :: CString
str' = do
    String
str <- CString -> IO String
peekCString (CString -> IO String) -> CString -> IO String
forall a b. (a -> b) -> a -> b
$ CString -> CString
forall a. Ptr a -> Ptr a
throwNull CString
str'
    CString -> IO ()
forall a. Ptr a -> IO ()
free CString
str'
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
str

-- | Returns the FcCharMap for a language.
langCharSet :: String -> CharSet
langCharSet :: String -> CharSet
langCharSet lang :: String
lang = IO CharSet -> CharSet
forall a. IO a -> a
unsafePerformIO (IO CharSet -> CharSet) -> IO CharSet -> CharSet
forall a b. (a -> b) -> a -> b
$
    String -> (CString -> IO CharSet) -> IO CharSet
forall a. String -> (CString -> IO a) -> IO a
withCString String
lang (CharSet_ -> IO CharSet
thawCharSet (CharSet_ -> IO CharSet)
-> (CString -> CharSet_) -> CString -> IO CharSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharSet_ -> CharSet_
forall a. Ptr a -> Ptr a
throwNull (CharSet_ -> CharSet_)
-> (CString -> CharSet_) -> CString -> CharSet_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> CharSet_
fcLangGetCharSet)
foreign import ccall "FcLangGetCharSet" fcLangGetCharSet :: CString -> CharSet_

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

data LangSet'
type LangSet_ = Ptr LangSet'

withNewLangSet :: (LangSet_ -> IO a) -> IO a
withNewLangSet :: (LangSet_ -> IO a) -> IO a
withNewLangSet = IO LangSet_ -> (LangSet_ -> IO ()) -> (LangSet_ -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (LangSet_ -> LangSet_
forall a. Ptr a -> Ptr a
throwNull (LangSet_ -> LangSet_) -> IO LangSet_ -> IO LangSet_
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO LangSet_
fcLangSetCreate) LangSet_ -> IO ()
fcLangSetDestroy
foreign import ccall "FcLangSetCreate" fcLangSetCreate :: IO LangSet_
foreign import ccall "FcLangSetDestroy" fcLangSetDestroy :: LangSet_ -> IO ()

withLangSet :: LangSet -> (LangSet_ -> IO a) -> IO a
withLangSet :: LangSet -> (LangSet_ -> IO a) -> IO a
withLangSet langs :: LangSet
langs cb :: LangSet_ -> IO a
cb = (LangSet_ -> IO a) -> IO a
forall a. (LangSet_ -> IO a) -> IO a
withNewLangSet ((LangSet_ -> IO a) -> IO a) -> (LangSet_ -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \langs' :: LangSet_
langs' -> do
    [String] -> (String -> IO (IO ())) -> IO [IO ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (LangSet -> [String]
forall a. Set a -> [a]
Set.elems LangSet
langs) ((String -> IO (IO ())) -> IO [IO ()])
-> (String -> IO (IO ())) -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ (String -> (CString -> IO (IO ())) -> IO (IO ()))
-> (CString -> IO (IO ())) -> String -> IO (IO ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> (CString -> IO (IO ())) -> IO (IO ())
forall a. String -> (CString -> IO a) -> IO a
withCString ((CString -> IO (IO ())) -> String -> IO (IO ()))
-> (CString -> IO (IO ())) -> String -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \lang' :: CString
lang' ->
        Bool -> IO ()
throwFalse (Bool -> IO ()) -> IO Bool -> IO (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LangSet_ -> CString -> IO Bool
fcLangSetAdd LangSet_
langs' CString
lang'
    LangSet_ -> IO a
cb LangSet_
langs'
foreign import ccall "FcLangSetAdd" fcLangSetAdd :: LangSet_ -> CString -> IO Bool

thawLangSet :: LangSet_ -> IO LangSet
thawLangSet :: LangSet_ -> IO LangSet
thawLangSet = IO StrSet_ -> IO LangSet
thawStrSet_ (IO StrSet_ -> IO LangSet)
-> (LangSet_ -> IO StrSet_) -> LangSet_ -> IO LangSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LangSet_ -> IO StrSet_
fcLangSetGetLangs
foreign import ccall "FcLangSetGetLangs" fcLangSetGetLangs :: LangSet_ -> IO StrSet_