{-# 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 = bracket fcFontSetCreate fcFontSetDestroy
foreign import ccall "FcFontSetCreate" fcFontSetCreate :: IO FontSet_
foreign import ccall "FcFontSetDestroy" fcFontSetDestroy :: FontSet_ -> IO ()
withFontSet :: FontSet -> (FontSet_ -> IO a) -> IO a
withFontSet fonts cb = withNewFontSet $ \fonts' -> do
forM fonts $ \font -> do
font' <- patternAsPointer font
throwFalse <$> fcFontSetAdd fonts' font'
cb fonts'
foreign import ccall "FcFontSetAdd" fcFontSetAdd :: FontSet_ -> Pattern_ -> IO Bool
withFontSets :: [FontSet] -> (Ptr FontSet_ -> Int -> IO a) -> IO a
withFontSets fontss cb = let n = length fontss in
allocaBytes (sizeOf (undefined :: FontSet_) * n) $ \fontss' ->
withFontSets' fontss 0 fontss' $ cb fontss' n
withFontSets' :: [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a
withFontSets' [] _ _ cb = cb
withFontSets' (fonts:fontss) i fontss' cb = withFontSet fonts $ \fonts' -> do
pokeElemOff fontss' i fonts'
withFontSets' fontss (succ i) fontss' cb
thawFontSet :: FontSet_ -> IO FontSet
thawFontSet fonts' = do
print "a"
n <- get_fontSet_nfont fonts'
print "b"
if n == 0 then return []
else do
print "c"
ret <- forM [0..pred n] (\i -> thawPattern =<< get_fontSet_font fonts' i)
print "d"
return ret
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_ cb = bracket (throwNull <$> cb) fcFontSetDestroy thawFontSet
data FontFaceParser a = FontFaceParser { cssFonts :: FontSet, cssInner :: a}
parseFontFaceSrc (Function "local":Ident name:RightParen:Comma:rest) =
("local:" ++ unpack name):parseFontFaceSrc rest
parseFontFaceSrc (Function "local":String name:RightParen:Comma:rest) =
("local:" ++ unpack name):parseFontFaceSrc rest
parseFontFaceSrc (Function "local":Ident name:RightParen:[]) = ["local:" ++ unpack name]
parseFontFaceSrc (Function "local":String name:RightParen:[]) = ["local:" ++ unpack name]
parseFontFaceSrc (Url link:toks)
| Comma:rest <- skipMeta toks = unpack link:parseFontFaceSrc rest
| [] <- skipMeta toks = [unpack link]
| otherwise = [""]
where
skipMeta (Function "format":Ident _:RightParen:rest) = skipMeta rest
skipMeta (Function "format":String _:RightParen:rest) = skipMeta rest
skipMeta (Function "tech":Ident _:RightParen:rest) = skipMeta rest
skipMeta (Function "tech":String _:RightParen:rest) = skipMeta rest
skipMeta toks = toks
parseFontFaceSrc _ = [""]
properties2font :: [(Text, [Token])] -> Pattern
properties2font (("font-family", [String font]):props) =
setValue "family" Strong (unpack font) $ properties2font props
properties2font (("font-family", [Ident font]):props) =
setValue "family" Strong (unpack font) $ properties2font props
properties2font (("font-stretch", [tok]):props) | Just x <- parseFontStretch tok =
setValue "width" Strong x $ properties2font props
properties2font (("font-stretch", [start, end]):props)
| Just x <- parseFontStretch start, Just y <- parseFontStretch end =
setValue "width" Strong (x `iRange` y) $ properties2font props
properties2font (("font-weight", [tok]):props) | Just x <- parseFontWeight tok =
setValue "width" Strong x $ properties2font props
properties2font (("font-weight", [start, end]):props)
| Just x <- parseFontStretch start, Just y <- parseFontStretch end =
setValue "weight" Strong (x `iRange` y) $ properties2font props
properties2font (("font-feature-settings", toks):props)
| (features, True, []) <- parseFontFeatures toks =
setValue "fontfeatures" Strong (intercalate "," $ map fst features) $
properties2font props
properties2font (("font-variation-settings", toks):props)
| (_, True, []) <- parseFontVars toks =
setValue "variable" Strong True $ properties2font props
properties2font (("unicode-range", toks):props)
| Just chars <- parseCharSet $ unpack $ serialize toks =
setValue "charset" Strong chars $ properties2font props
properties2font (("src", toks):props)
| fonts@(_:_) <- parseFontFaceSrc toks, "" `notElem` fonts =
setValue "web-src" Strong (intercalate "\t" fonts) $ properties2font props
properties2font (_:props) = properties2font props
properties2font [] = []
instance StyleSheet a => StyleSheet (FontFaceParser a) where
setPriorities v (FontFaceParser x self) = FontFaceParser x $ setPriorities v self
addRule (FontFaceParser x self) rule = FontFaceParser x $ addRule self rule
addAtRule (FontFaceParser fonts self) "font-face" toks =
let ((props, _), toks') = parseProperties toks
in (FontFaceParser (properties2font props:fonts) self, toks')
addAtRule (FontFaceParser x self) key toks =
let (a, b) = addAtRule self key toks in (FontFaceParser x a, b)