{-# LANGUAGE OverloadedStrings #-}
module Graphics.Text.Font.Choose.FontSet where

import Graphics.Text.Font.Choose.Pattern
import Graphics.Text.Font.Choose.Result (throwFalse, throwNull)

import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Storable (pokeElemOff, sizeOf)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Marshal.Array (peekArray)
import Control.Monad (forM)
import Control.Exception (bracket)

-- For CSS bindings
import Stylist.Parse (StyleSheet(..), parseProperties)
import Data.CSS.Syntax.Tokens (Token(..), serialize)
import Data.Text (unpack, Text)
import Graphics.Text.Font.Choose.Range (iRange)
import Graphics.Text.Font.Choose.CharSet (parseCharSet)
import Data.List (intercalate)

-- | An `FontSet` contains a list of `Pattern`s.
-- Internally fontconfig uses this data structure to hold sets of fonts.
-- Externally, fontconfig returns the results of listing fonts in this format.
type FontSet = [Pattern]

------
--- Low-level
------
data FontSet'
type FontSet_ = Ptr FontSet'

withNewFontSet :: (FontSet_ -> IO a) -> IO a
withNewFontSet :: (FontSet_ -> IO a) -> IO a
withNewFontSet = IO FontSet_ -> (FontSet_ -> IO ()) -> (FontSet_ -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO FontSet_
fcFontSetCreate FontSet_ -> IO ()
fcFontSetDestroy
foreign import ccall "FcFontSetCreate" fcFontSetCreate :: IO FontSet_
foreign import ccall "FcFontSetDestroy" fcFontSetDestroy :: FontSet_ -> IO ()

withFontSet :: FontSet -> (FontSet_ -> IO a) -> IO a
withFontSet :: FontSet -> (FontSet_ -> IO a) -> IO a
withFontSet fonts :: FontSet
fonts cb :: FontSet_ -> IO a
cb = (FontSet_ -> IO a) -> IO a
forall a. (FontSet_ -> IO a) -> IO a
withNewFontSet ((FontSet_ -> IO a) -> IO a) -> (FontSet_ -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \fonts' :: FontSet_
fonts' -> do
    FontSet -> (Pattern -> IO (IO ())) -> IO [IO ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM FontSet
fonts ((Pattern -> IO (IO ())) -> IO [IO ()])
-> (Pattern -> IO (IO ())) -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ \font :: Pattern
font -> do
        Pattern_
font' <- Pattern -> IO Pattern_
patternAsPointer Pattern
font
        Bool -> IO ()
throwFalse (Bool -> IO ()) -> IO Bool -> IO (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FontSet_ -> Pattern_ -> IO Bool
fcFontSetAdd FontSet_
fonts' Pattern_
font'
    FontSet_ -> IO a
cb FontSet_
fonts'
foreign import ccall "FcFontSetAdd" fcFontSetAdd :: FontSet_ -> Pattern_ -> IO Bool

withFontSets :: [FontSet] -> (Ptr FontSet_ -> Int -> IO a) -> IO a
withFontSets :: [FontSet] -> (Ptr FontSet_ -> Int -> IO a) -> IO a
withFontSets fontss :: [FontSet]
fontss cb :: Ptr FontSet_ -> Int -> IO a
cb = let n :: Int
n = [FontSet] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FontSet]
fontss in
    Int -> (Ptr FontSet_ -> IO a) -> IO a
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (FontSet_ -> Int
forall a. Storable a => a -> Int
sizeOf (FontSet_
forall a. HasCallStack => a
undefined :: FontSet_) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n) ((Ptr FontSet_ -> IO a) -> IO a) -> (Ptr FontSet_ -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \fontss' :: Ptr FontSet_
fontss' ->
        [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a
forall a. [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a
withFontSets' [FontSet]
fontss 0 Ptr FontSet_
fontss' (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Ptr FontSet_ -> Int -> IO a
cb Ptr FontSet_
fontss' Int
n
withFontSets' :: [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a
withFontSets' :: [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a
withFontSets' [] _ _ cb :: IO a
cb = IO a
cb
withFontSets' (fonts :: FontSet
fonts:fontss :: [FontSet]
fontss) i :: Int
i fontss' :: Ptr FontSet_
fontss' cb :: IO a
cb = FontSet -> (FontSet_ -> IO a) -> IO a
forall a. FontSet -> (FontSet_ -> IO a) -> IO a
withFontSet FontSet
fonts ((FontSet_ -> IO a) -> IO a) -> (FontSet_ -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \fonts' :: FontSet_
fonts' -> do
    Ptr FontSet_ -> Int -> FontSet_ -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr FontSet_
fontss' Int
i FontSet_
fonts'
    [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a
forall a. [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a
withFontSets' [FontSet]
fontss (Int -> Int
forall a. Enum a => a -> a
succ Int
i) Ptr FontSet_
fontss' IO a
cb

thawFontSet :: FontSet_ -> IO FontSet
thawFontSet :: FontSet_ -> IO FontSet
thawFontSet fonts' :: FontSet_
fonts' = do
    -- Very hacky, but these debug statements must be in here to avoid segfaults.
    -- FIXME: Is there an alternative?
    Int
n <- FontSet_ -> IO Int
get_fontSet_nfont FontSet_
fonts'
    if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then FontSet -> IO FontSet
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else
        [Int] -> (Int -> IO Pattern) -> IO FontSet
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [0..Int -> Int
forall a. Enum a => a -> a
pred Int
n] (\i :: Int
i -> Pattern_ -> IO Pattern
thawPattern (Pattern_ -> IO Pattern) -> IO Pattern_ -> IO Pattern
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FontSet_ -> Int -> IO Pattern_
get_fontSet_font FontSet_
fonts' Int
i)
foreign import ccall "get_fontSet_nfont" get_fontSet_nfont :: FontSet_ -> IO Int
foreign import ccall "get_fontSet_font" get_fontSet_font :: FontSet_ -> Int -> IO Pattern_

thawFontSet_ :: IO FontSet_ -> IO FontSet
thawFontSet_ :: IO FontSet_ -> IO FontSet
thawFontSet_ cb :: IO FontSet_
cb = IO FontSet_
-> (FontSet_ -> IO ()) -> (FontSet_ -> IO FontSet) -> IO FontSet
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FontSet_ -> FontSet_
forall a. Ptr a -> Ptr a
throwNull (FontSet_ -> FontSet_) -> IO FontSet_ -> IO FontSet_
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FontSet_
cb) FontSet_ -> IO ()
fcFontSetDestroy FontSet_ -> IO FontSet
thawFontSet

------
--- CSS Bindings
------

-- | `StyleSheet` wrapper to parse @font-face rules.
data FontFaceParser a = FontFaceParser { FontFaceParser a -> FontSet
cssFonts :: FontSet, FontFaceParser a -> a
cssInner :: a}

parseFontFaceSrc :: [Token] -> [[Char]]
parseFontFaceSrc (Function "local":Ident name :: Text
name:RightParen:Comma:rest :: [Token]
rest) =
    ("local:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
name)[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[Token] -> [[Char]]
parseFontFaceSrc [Token]
rest
parseFontFaceSrc (Function "local":String name :: Text
name:RightParen:Comma:rest :: [Token]
rest) =
    ("local:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
name)[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[Token] -> [[Char]]
parseFontFaceSrc [Token]
rest
parseFontFaceSrc (Function "local":Ident name :: Text
name:RightParen:[]) = ["local:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
name]
parseFontFaceSrc (Function "local":String name :: Text
name:RightParen:[]) = ["local:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
name]

parseFontFaceSrc (Url link :: Text
link:toks :: [Token]
toks)
    | Comma:rest :: [Token]
rest <- [Token] -> [Token]
skipMeta [Token]
toks = Text -> [Char]
unpack Text
link[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[Token] -> [[Char]]
parseFontFaceSrc [Token]
rest
    | [] <- [Token] -> [Token]
skipMeta [Token]
toks = [Text -> [Char]
unpack Text
link]
    | Bool
otherwise = [""] -- Error indicator!
  where
    skipMeta :: [Token] -> [Token]
skipMeta (Function "format":Ident _:RightParen:rest :: [Token]
rest) = [Token] -> [Token]
skipMeta [Token]
rest
    skipMeta (Function "format":String _:RightParen:rest :: [Token]
rest) = [Token] -> [Token]
skipMeta [Token]
rest
    skipMeta (Function "tech":Ident _:RightParen:rest :: [Token]
rest) = [Token] -> [Token]
skipMeta [Token]
rest
    skipMeta (Function "tech":String _:RightParen:rest :: [Token]
rest) = [Token] -> [Token]
skipMeta [Token]
rest
    skipMeta toks :: [Token]
toks = [Token]
toks

parseFontFaceSrc _ = [""]

properties2font :: [(Text, [Token])] -> Pattern
properties2font :: [(Text, [Token])] -> Pattern
properties2font (("font-family", [String font :: Text
font]):props :: [(Text, [Token])]
props) =
    [Char] -> Binding -> [Char] -> Pattern -> Pattern
forall x. ToValue x => [Char] -> Binding -> x -> Pattern -> Pattern
setValue "family" Binding
Strong (Text -> [Char]
unpack Text
font) (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [(Text, [Token])] -> Pattern
properties2font [(Text, [Token])]
props
properties2font (("font-family", [Ident font :: Text
font]):props :: [(Text, [Token])]
props) =
    [Char] -> Binding -> [Char] -> Pattern -> Pattern
forall x. ToValue x => [Char] -> Binding -> x -> Pattern -> Pattern
setValue "family" Binding
Strong (Text -> [Char]
unpack Text
font) (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [(Text, [Token])] -> Pattern
properties2font [(Text, [Token])]
props

properties2font (("font-stretch", [tok :: Token
tok]):props :: [(Text, [Token])]
props) | Just x :: Int
x <- Token -> Maybe Int
parseFontStretch Token
tok =
    [Char] -> Binding -> Int -> Pattern -> Pattern
forall x. ToValue x => [Char] -> Binding -> x -> Pattern -> Pattern
setValue "width" Binding
Strong Int
x (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [(Text, [Token])] -> Pattern
properties2font [(Text, [Token])]
props
properties2font (("font-stretch", [start :: Token
start, end :: Token
end]):props :: [(Text, [Token])]
props)
    | Just x :: Int
x <- Token -> Maybe Int
parseFontStretch Token
start, Just y :: Int
y <- Token -> Maybe Int
parseFontStretch Token
end =
        [Char] -> Binding -> Range -> Pattern -> Pattern
forall x. ToValue x => [Char] -> Binding -> x -> Pattern -> Pattern
setValue "width" Binding
Strong (Int
x Int -> Int -> Range
`iRange` Int
y) (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [(Text, [Token])] -> Pattern
properties2font [(Text, [Token])]
props

properties2font (("font-weight", [tok :: Token
tok]):props :: [(Text, [Token])]
props) | Just x :: Int
x <- Token -> Maybe Int
parseFontWeight Token
tok =
    [Char] -> Binding -> Int -> Pattern -> Pattern
forall x. ToValue x => [Char] -> Binding -> x -> Pattern -> Pattern
setValue "width" Binding
Strong Int
x (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [(Text, [Token])] -> Pattern
properties2font [(Text, [Token])]
props
properties2font (("font-weight", [start :: Token
start, end :: Token
end]):props :: [(Text, [Token])]
props)
    | Just x :: Int
x <- Token -> Maybe Int
parseFontStretch Token
start, Just y :: Int
y <- Token -> Maybe Int
parseFontStretch Token
end =
        [Char] -> Binding -> Range -> Pattern -> Pattern
forall x. ToValue x => [Char] -> Binding -> x -> Pattern -> Pattern
setValue "weight" Binding
Strong (Int
x Int -> Int -> Range
`iRange` Int
y) (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [(Text, [Token])] -> Pattern
properties2font [(Text, [Token])]
props

properties2font (("font-feature-settings", toks :: [Token]
toks):props :: [(Text, [Token])]
props)
    | (features :: [([Char], Int)]
features, True, []) <- [Token] -> ([([Char], Int)], Bool, [Token])
parseFontFeatures [Token]
toks =
        [Char] -> Binding -> [Char] -> Pattern -> Pattern
forall x. ToValue x => [Char] -> Binding -> x -> Pattern -> Pattern
setValue "fontfeatures" Binding
Strong ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate "," ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (([Char], Int) -> [Char]) -> [([Char], Int)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Int) -> [Char]
forall a b. (a, b) -> a
fst [([Char], Int)]
features) (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$
            [(Text, [Token])] -> Pattern
properties2font [(Text, [Token])]
props

properties2font (("font-variation-settings", toks :: [Token]
toks):props :: [(Text, [Token])]
props)
    | (_, True, []) <- [Token] -> ([([Char], Double)], Bool, [Token])
parseFontVars [Token]
toks =
        [Char] -> Binding -> Bool -> Pattern -> Pattern
forall x. ToValue x => [Char] -> Binding -> x -> Pattern -> Pattern
setValue "variable" Binding
Strong Bool
True (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [(Text, [Token])] -> Pattern
properties2font [(Text, [Token])]
props

properties2font (("unicode-range", toks :: [Token]
toks):props :: [(Text, [Token])]
props)
    | Just chars :: Set Char
chars <- [Char] -> Maybe (Set Char)
parseCharSet ([Char] -> Maybe (Set Char)) -> [Char] -> Maybe (Set Char)
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ [Token] -> Text
serialize [Token]
toks =
        [Char] -> Binding -> Set Char -> Pattern -> Pattern
forall x. ToValue x => [Char] -> Binding -> x -> Pattern -> Pattern
setValue "charset" Binding
Strong Set Char
chars (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [(Text, [Token])] -> Pattern
properties2font [(Text, [Token])]
props

-- Ignoring metadata & trusting in FreeType's broad support for fonts.
properties2font (("src", toks :: [Token]
toks):props :: [(Text, [Token])]
props)
    | fonts :: [[Char]]
fonts@(_:_) <- [Token] -> [[Char]]
parseFontFaceSrc [Token]
toks, "" [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]]
fonts =
        [Char] -> Binding -> [Char] -> Pattern -> Pattern
forall x. ToValue x => [Char] -> Binding -> x -> Pattern -> Pattern
setValue "web-src" Binding
Strong ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate "\t" [[Char]]
fonts) (Pattern -> Pattern) -> Pattern -> Pattern
forall a b. (a -> b) -> a -> b
$ [(Text, [Token])] -> Pattern
properties2font [(Text, [Token])]
props

properties2font (_:props :: [(Text, [Token])]
props) = [(Text, [Token])] -> Pattern
properties2font [(Text, [Token])]
props
properties2font [] = []

instance StyleSheet a => StyleSheet (FontFaceParser a) where
    setPriorities :: [Int] -> FontFaceParser a -> FontFaceParser a
setPriorities v :: [Int]
v (FontFaceParser x :: FontSet
x self :: a
self) = FontSet -> a -> FontFaceParser a
forall a. FontSet -> a -> FontFaceParser a
FontFaceParser FontSet
x (a -> FontFaceParser a) -> a -> FontFaceParser a
forall a b. (a -> b) -> a -> b
$ [Int] -> a -> a
forall s. StyleSheet s => [Int] -> s -> s
setPriorities [Int]
v a
self
    addRule :: FontFaceParser a -> StyleRule -> FontFaceParser a
addRule (FontFaceParser x :: FontSet
x self :: a
self) rule :: StyleRule
rule = FontSet -> a -> FontFaceParser a
forall a. FontSet -> a -> FontFaceParser a
FontFaceParser FontSet
x (a -> FontFaceParser a) -> a -> FontFaceParser a
forall a b. (a -> b) -> a -> b
$ a -> StyleRule -> a
forall s. StyleSheet s => s -> StyleRule -> s
addRule a
self StyleRule
rule

    addAtRule :: FontFaceParser a -> Text -> [Token] -> (FontFaceParser a, [Token])
addAtRule (FontFaceParser fonts :: FontSet
fonts self :: a
self) "font-face" toks :: [Token]
toks =
        let ((props :: [(Text, [Token])]
props, _), toks' :: [Token]
toks') = Parser ([(Text, [Token])], Text)
parseProperties [Token]
toks
        in (FontSet -> a -> FontFaceParser a
forall a. FontSet -> a -> FontFaceParser a
FontFaceParser ([(Text, [Token])] -> Pattern
properties2font [(Text, [Token])]
propsPattern -> FontSet -> FontSet
forall a. a -> [a] -> [a]
:FontSet
fonts) a
self, [Token]
toks')
    addAtRule (FontFaceParser x :: FontSet
x self :: a
self) key :: Text
key toks :: [Token]
toks =
        let (a :: a
a, b :: [Token]
b) = a -> Text -> [Token] -> (a, [Token])
forall s. StyleSheet s => s -> Text -> [Token] -> (s, [Token])
addAtRule a
self Text
key [Token]
toks in (FontSet -> a -> FontFaceParser a
forall a. FontSet -> a -> FontFaceParser a
FontFaceParser FontSet
x a
a, [Token]
b)