{-# 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 :: forall a. (FontSet_ -> IO a) -> IO a
withNewFontSet = 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 :: forall a. FontSet -> (FontSet_ -> IO a) -> IO a
withFontSet FontSet
fonts FontSet_ -> IO a
cb = forall a. (FontSet_ -> IO a) -> IO a
withNewFontSet forall a b. (a -> b) -> a -> b
$ \FontSet_
fonts' -> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM FontSet
fonts forall a b. (a -> b) -> a -> b
$ \Pattern
font -> do
        Pattern_
font' <- Pattern -> IO Pattern_
patternAsPointer Pattern
font
        Bool -> IO ()
throwFalse 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 :: forall a. [FontSet] -> (Ptr FontSet_ -> Int -> IO a) -> IO a
withFontSets [FontSet]
fontss Ptr FontSet_ -> Int -> IO a
cb = let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [FontSet]
fontss in
    forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: FontSet_) forall a. Num a => a -> a -> a
* Int
n) forall a b. (a -> b) -> a -> b
$ \Ptr FontSet_
fontss' ->
        forall a. [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a
withFontSets' [FontSet]
fontss Int
0 Ptr FontSet_
fontss' 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' :: forall a. [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a
withFontSets' [] Int
_ Ptr FontSet_
_ IO a
cb = IO a
cb
withFontSets' (FontSet
fonts:[FontSet]
fontss) Int
i Ptr FontSet_
fontss' IO a
cb = forall a. FontSet -> (FontSet_ -> IO a) -> IO a
withFontSet FontSet
fonts forall a b. (a -> b) -> a -> b
$ \FontSet_
fonts' -> do
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr FontSet_
fontss' Int
i FontSet_
fonts'
    forall a. [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a
withFontSets' [FontSet]
fontss (forall a. Enum a => a -> a
succ Int
i) Ptr FontSet_
fontss' IO a
cb

thawFontSet :: FontSet_ -> IO FontSet
thawFontSet :: FontSet_ -> IO FontSet
thawFontSet FontSet_
fonts' = do
    Int
n <- FontSet_ -> IO Int
get_fontSet_nfont FontSet_
fonts'
    if Int
n forall a. Eq a => a -> a -> Bool
== Int
0 then forall (m :: * -> *) a. Monad m => a -> m a
return []
    else
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0..forall a. Enum a => a -> a
pred Int
n] (\Int
i -> Pattern_ -> IO Pattern
thawPattern 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_ IO FontSet_
cb = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall a. Ptr a -> Ptr a
throwNull 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 { forall a. FontFaceParser a -> FontSet
cssFonts :: FontSet, forall a. FontFaceParser a -> a
cssInner :: a}

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

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

parseFontFaceSrc [Token]
_ = [String
""]

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

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

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

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

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

properties2font ((Text
"unicode-range", [Token]
toks):[(Text, [Token])]
props)
    | Just CharSet
chars <- String -> Maybe CharSet
parseCharSet forall a b. (a -> b) -> a -> b
$ Text -> String
unpack forall a b. (a -> b) -> a -> b
$ [Token] -> Text
serialize [Token]
toks =
        forall x. ToValue x => String -> Binding -> x -> Pattern -> Pattern
setValue String
"charset" Binding
Strong CharSet
chars 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 ((Text
"src", [Token]
toks):[(Text, [Token])]
props)
    | fonts :: [String]
fonts@(String
_:[String]
_) <- [Token] -> [String]
parseFontFaceSrc [Token]
toks, String
"" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
fonts =
        forall x. ToValue x => String -> Binding -> x -> Pattern -> Pattern
setValue String
"web-src" Binding
Strong (forall a. [a] -> [[a]] -> [a]
intercalate String
"\t" [String]
fonts) forall a b. (a -> b) -> a -> b
$ [(Text, [Token])] -> Pattern
properties2font [(Text, [Token])]
props

properties2font ((Text, [Token])
_:[(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 [Int]
v (FontFaceParser FontSet
x a
self) = forall a. FontSet -> a -> FontFaceParser a
FontFaceParser FontSet
x forall a b. (a -> b) -> a -> b
$ forall s. StyleSheet s => [Int] -> s -> s
setPriorities [Int]
v a
self
    addRule :: FontFaceParser a -> StyleRule -> FontFaceParser a
addRule (FontFaceParser FontSet
x a
self) StyleRule
rule = forall a. FontSet -> a -> FontFaceParser a
FontFaceParser FontSet
x forall a b. (a -> b) -> a -> b
$ forall s. StyleSheet s => s -> StyleRule -> s
addRule a
self StyleRule
rule

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