{-# 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 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)
type FontSet = [Pattern]
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
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
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 = [""]
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
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)