{-# 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)
import System.IO.Unsafe (unsafeInterleaveIO)

-- 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)
  where
    thawPattern' :: Pattern_ -> IO Pattern
thawPattern' Pattern_
pat = do
        Pattern_ -> IO ()
fcPatternReference Pattern_
pat
        forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ Pattern_ -> IO Pattern
thawPattern Pattern_
pat
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)