{-# 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)
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 :: 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
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
""]
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
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)