{-# LANGUAGE CApiFFI #-}
-- | Languages supported by different fonts.
module Graphics.Text.Font.Choose.LangSet(
        LangSet, LangSet'(..), module S, LangComparison(..), validLangSet, validLangSet',
        cmp, cmp', has, defaultLangs, langs, normalize, langCharSet) where

import Data.Set as S hiding (valid)

import Data.Hashable (Hashable(..))
import Data.MessagePack (MessagePack(..))
import Test.QuickCheck (Arbitrary(..), elements, listOf)
import Graphics.Text.Font.Choose.StrSet (StrSet(..))
import Graphics.Text.Font.Choose.CharSet as CS (CharSet'(..), empty)

import Foreign.C.String (CString)
import Foreign.Ptr (Ptr)
import Graphics.Text.Font.Choose.Internal.FFI (withMessage, fromMessage0, withCString', peekCString')
import Graphics.Text.Font.Choose.Result
import Control.Exception (throw)

-- | 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
-- | Wrapper around LangSet adding useful typeclasses
newtype LangSet' = LangSet' { LangSet' -> LangSet
unLangSet :: LangSet } deriving (LangSet' -> LangSet' -> Bool
(LangSet' -> LangSet' -> Bool)
-> (LangSet' -> LangSet' -> Bool) -> Eq LangSet'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LangSet' -> LangSet' -> Bool
== :: LangSet' -> LangSet' -> Bool
$c/= :: LangSet' -> LangSet' -> Bool
/= :: LangSet' -> LangSet' -> Bool
Eq, Int -> LangSet' -> ShowS
[LangSet'] -> ShowS
LangSet' -> String
(Int -> LangSet' -> ShowS)
-> (LangSet' -> String) -> ([LangSet'] -> ShowS) -> Show LangSet'
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LangSet' -> ShowS
showsPrec :: Int -> LangSet' -> ShowS
$cshow :: LangSet' -> String
show :: LangSet' -> String
$cshowList :: [LangSet'] -> ShowS
showList :: [LangSet'] -> ShowS
Show, ReadPrec [LangSet']
ReadPrec LangSet'
Int -> ReadS LangSet'
ReadS [LangSet']
(Int -> ReadS LangSet')
-> ReadS [LangSet']
-> ReadPrec LangSet'
-> ReadPrec [LangSet']
-> Read LangSet'
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS LangSet'
readsPrec :: Int -> ReadS LangSet'
$creadList :: ReadS [LangSet']
readList :: ReadS [LangSet']
$creadPrec :: ReadPrec LangSet'
readPrec :: ReadPrec LangSet'
$creadListPrec :: ReadPrec [LangSet']
readListPrec :: ReadPrec [LangSet']
Read)

instance Hashable LangSet' where
    hashWithSalt :: Int -> LangSet' -> Int
hashWithSalt Int
salt (LangSet' LangSet
self) = Int -> LangSet -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt LangSet
self

-- | Can the given LangSet be processed by FontConfig?
validLangSet :: LangSet -> Bool
validLangSet :: LangSet -> Bool
validLangSet LangSet
x = (String -> Bool) -> LangSet -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all String -> Bool
validLang LangSet
x Bool -> Bool -> Bool
&& Bool -> Bool
not (LangSet -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null LangSet
x)
-- | Can the given LangSet' be processed by FontConfig?
validLangSet' :: LangSet' -> Bool
validLangSet' :: LangSet' -> Bool
validLangSet' = LangSet -> Bool
validLangSet (LangSet -> Bool) -> (LangSet' -> LangSet) -> LangSet' -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LangSet' -> LangSet
unLangSet
-- | Can the given language code be processed by FontConfig?
validLang :: String -> Bool
validLang :: String -> Bool
validLang = (String -> LangSet -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` StrSet -> LangSet
unStrSet StrSet
langs)

instance MessagePack LangSet' where
    toObject :: LangSet' -> Object
toObject = [String] -> Object
forall a. MessagePack a => a -> Object
toObject ([String] -> Object)
-> (LangSet' -> [String]) -> LangSet' -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LangSet -> [String]
forall a. Set a -> [a]
S.toList (LangSet -> [String])
-> (LangSet' -> LangSet) -> LangSet' -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LangSet' -> LangSet
unLangSet
    fromObject :: Object -> Maybe LangSet'
fromObject Object
msg = LangSet -> LangSet'
LangSet' (LangSet -> LangSet')
-> ([String] -> LangSet) -> [String] -> LangSet'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> LangSet
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> LangSet') -> Maybe [String] -> Maybe LangSet'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Maybe [String]
forall a. MessagePack a => Object -> Maybe a
fromObject Object
msg
instance Arbitrary LangSet' where
    arbitrary :: Gen LangSet'
arbitrary = LangSet -> LangSet'
LangSet' (LangSet -> LangSet')
-> ([String] -> LangSet) -> [String] -> LangSet'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> LangSet
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> LangSet') -> Gen [String] -> Gen LangSet'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String -> Gen [String]
forall a. Gen a -> Gen [a]
listOf ([String] -> Gen String
forall a. HasCallStack => [a] -> Gen a
elements ([String] -> Gen String) -> [String] -> Gen String
forall a b. (a -> b) -> a -> b
$ LangSet -> [String]
forall a. Set a -> [a]
S.toList (LangSet -> [String]) -> LangSet -> [String]
forall a b. (a -> b) -> a -> b
$ StrSet -> LangSet
unStrSet StrSet
langs)

-- | The result of `cmp`.
data LangComparison = DifferentLang -- ^ The locales share no languages in common
    | SameLang -- ^ The locales share any language and territory pair
    | DifferentTerritory -- ^ The locales share a language but differ in which territory that language is for
    deriving (ReadPrec [LangComparison]
ReadPrec LangComparison
Int -> ReadS LangComparison
ReadS [LangComparison]
(Int -> ReadS LangComparison)
-> ReadS [LangComparison]
-> ReadPrec LangComparison
-> ReadPrec [LangComparison]
-> Read LangComparison
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS LangComparison
readsPrec :: Int -> ReadS LangComparison
$creadList :: ReadS [LangComparison]
readList :: ReadS [LangComparison]
$creadPrec :: ReadPrec LangComparison
readPrec :: ReadPrec LangComparison
$creadListPrec :: ReadPrec [LangComparison]
readListPrec :: ReadPrec [LangComparison]
Read, Int -> LangComparison -> ShowS
[LangComparison] -> ShowS
LangComparison -> String
(Int -> LangComparison -> ShowS)
-> (LangComparison -> String)
-> ([LangComparison] -> ShowS)
-> Show LangComparison
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LangComparison -> ShowS
showsPrec :: Int -> LangComparison -> ShowS
$cshow :: LangComparison -> String
show :: LangComparison -> String
$cshowList :: [LangComparison] -> ShowS
showList :: [LangComparison] -> ShowS
Show, LangComparison -> LangComparison -> Bool
(LangComparison -> LangComparison -> Bool)
-> (LangComparison -> LangComparison -> Bool) -> Eq LangComparison
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LangComparison -> LangComparison -> Bool
== :: LangComparison -> LangComparison -> Bool
$c/= :: LangComparison -> LangComparison -> Bool
/= :: LangComparison -> LangComparison -> Bool
Eq, Int -> LangComparison
LangComparison -> Int
LangComparison -> [LangComparison]
LangComparison -> LangComparison
LangComparison -> LangComparison -> [LangComparison]
LangComparison
-> LangComparison -> LangComparison -> [LangComparison]
(LangComparison -> LangComparison)
-> (LangComparison -> LangComparison)
-> (Int -> LangComparison)
-> (LangComparison -> Int)
-> (LangComparison -> [LangComparison])
-> (LangComparison -> LangComparison -> [LangComparison])
-> (LangComparison -> LangComparison -> [LangComparison])
-> (LangComparison
    -> LangComparison -> LangComparison -> [LangComparison])
-> Enum LangComparison
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: LangComparison -> LangComparison
succ :: LangComparison -> LangComparison
$cpred :: LangComparison -> LangComparison
pred :: LangComparison -> LangComparison
$ctoEnum :: Int -> LangComparison
toEnum :: Int -> LangComparison
$cfromEnum :: LangComparison -> Int
fromEnum :: LangComparison -> Int
$cenumFrom :: LangComparison -> [LangComparison]
enumFrom :: LangComparison -> [LangComparison]
$cenumFromThen :: LangComparison -> LangComparison -> [LangComparison]
enumFromThen :: LangComparison -> LangComparison -> [LangComparison]
$cenumFromTo :: LangComparison -> LangComparison -> [LangComparison]
enumFromTo :: LangComparison -> LangComparison -> [LangComparison]
$cenumFromThenTo :: LangComparison
-> LangComparison -> LangComparison -> [LangComparison]
enumFromThenTo :: LangComparison
-> LangComparison -> LangComparison -> [LangComparison]
Enum, LangComparison
LangComparison -> LangComparison -> Bounded LangComparison
forall a. a -> a -> Bounded a
$cminBound :: LangComparison
minBound :: LangComparison
$cmaxBound :: LangComparison
maxBound :: LangComparison
Bounded)
i2cmp :: Int -> LangComparison
i2cmp :: Int -> LangComparison
i2cmp Int
0 = LangComparison
DifferentLang
i2cmp Int
1 = LangComparison
SameLang
i2cmp Int
2 = LangComparison
DifferentTerritory
i2cmp Int
_ = FcException -> LangComparison
forall a e. Exception e => e -> a
throw FcException
ErrOOM

-- | Variation of `cmp` which operates on `LangSet'`.
cmp' :: LangSet' -> LangSet' -> LangComparison
cmp' :: LangSet' -> LangSet' -> LangComparison
cmp' LangSet'
a LangSet'
b | LangSet' -> Bool
valid LangSet'
a Bool -> Bool -> Bool
&& LangSet' -> Bool
valid LangSet'
b = Int -> LangComparison
i2cmp (Int -> LangComparison) -> Int -> LangComparison
forall a b. (a -> b) -> a -> b
$ (CString -> Int -> Int) -> [LangSet'] -> Int
forall a b. MessagePack a => (CString -> Int -> b) -> a -> b
withMessage CString -> Int -> Int
fcLangSetCompare [LangSet'
a, LangSet'
b]
    | Bool
otherwise = LangComparison
DifferentLang
  where valid :: LangSet' -> Bool
valid = LangSet' -> Bool
validLangSet'
-- | Compares language coverage for the 2 given LangSets.
cmp :: LangSet -> LangSet -> LangComparison
cmp :: LangSet -> LangSet -> LangComparison
cmp LangSet
a LangSet
b = LangSet -> LangSet'
LangSet' LangSet
a LangSet' -> LangSet' -> LangComparison
`cmp'` LangSet -> LangSet'
LangSet' LangSet
b

foreign import capi "fontconfig-wrap.h" fcLangSetCompare :: CString -> Int -> Int

-- | returns True if `a` contains every language in `b`.
-- `a`` will contain a language from `b` if `a` has exactly the language,
-- or either the language or `a` has no territory.
has :: LangSet' -> String -> LangComparison
has :: LangSet' -> String -> LangComparison
has LangSet'
a String
b | LangSet' -> Bool
validLangSet' LangSet'
a Bool -> Bool -> Bool
&& String -> Bool
validLang String
b =
        Int -> LangComparison
i2cmp (Int -> LangComparison) -> Int -> LangComparison
forall a b. (a -> b) -> a -> b
$ ((CString -> Int) -> String -> Int)
-> String -> (CString -> Int) -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip (CString -> Int) -> String -> Int
forall a. (CString -> a) -> String -> a
withCString' String
b ((CString -> Int) -> Int) -> (CString -> Int) -> Int
forall a b. (a -> b) -> a -> b
$ (CString -> Int -> CString -> Int) -> LangSet' -> CString -> Int
forall a b. MessagePack a => (CString -> Int -> b) -> a -> b
withMessage CString -> Int -> CString -> Int
fcLangSetHasLang LangSet'
a
    | Bool
otherwise = LangComparison
DifferentLang

foreign import capi "fontconfig-wrap.h" fcLangSetHasLang :: CString -> Int -> CString -> Int

-- | 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 :: StrSet
defaultLangs :: StrSet
defaultLangs = (Ptr Int -> CString) -> StrSet
forall a. MessagePack a => (Ptr Int -> CString) -> a
fromMessage0 Ptr Int -> CString
fcGetDefaultLangs

foreign import capi "fontconfig-wrap.h" fcGetDefaultLangs :: Ptr Int -> CString

-- | Returns a string set of all languages.
langs :: StrSet
langs :: StrSet
langs = (Ptr Int -> CString) -> StrSet
forall a. MessagePack a => (Ptr Int -> CString) -> a
fromMessage0 Ptr Int -> CString
fcGetLangs

foreign import capi "fontconfig-wrap.h" fcGetLangs :: Ptr Int -> CString

-- | Returns a string to make lang suitable on fontconfig.
normalize :: String -> String
normalize :: ShowS
normalize = CString -> String
peekCString' (CString -> String) -> (String -> CString) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CString -> CString) -> String -> CString
forall a. (CString -> a) -> String -> a
withCString' CString -> CString
fcLangNormalize

foreign import capi "fontconfig-wrap.h" fcLangNormalize :: CString -> CString

-- | Returns the CharSet for a language.
langCharSet :: String -> CharSet'
langCharSet :: String -> CharSet'
langCharSet String
a | String -> Bool
validLang String
a = (Ptr Int -> CString) -> CharSet'
forall a. MessagePack a => (Ptr Int -> CString) -> a
fromMessage0 ((Ptr Int -> CString) -> CharSet')
-> (Ptr Int -> CString) -> CharSet'
forall a b. (a -> b) -> a -> b
$ (CString -> Ptr Int -> CString) -> String -> Ptr Int -> CString
forall a. (CString -> a) -> String -> a
withCString' CString -> Ptr Int -> CString
fcLangGetCharSet String
a
    | Bool
otherwise = CharSet -> CharSet'
CharSet' CharSet
CS.empty

foreign import capi "fontconfig-wrap.h" fcLangGetCharSet :: CString -> Ptr Int -> CString