{-# LANGUAGE DeriveGeneric, OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
module Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset,
normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format,
Pattern_, withPattern, thawPattern, thawPattern_, patternAsPointer) where
import Prelude hiding (filter)
import Data.List (nub)
import Graphics.Text.Font.Choose.Value
import Graphics.Text.Font.Choose.ObjectSet (ObjectSet, ObjectSet_, withObjectSet)
import Data.Hashable (Hashable(..))
import GHC.Generics (Generic)
import Graphics.Text.Font.Choose.Result (throwFalse, throwNull, throwInt)
import Foreign.Ptr (Ptr)
import Foreign.Marshal.Alloc (alloca, allocaBytes, free)
import Foreign.Storable (Storable(..))
import Foreign.C.String (CString, withCString, peekCString)
import Debug.Trace (trace) -- For reporting internal errors!
import System.IO.Unsafe (unsafePerformIO)
import Control.Monad (forM, join)
import Data.Maybe (catMaybes)
import Control.Exception (bracket)
-- Imported for CSS bindings
import Data.CSS.Syntax.Tokens (Token(..))
import Data.Text (unpack)
import Stylist (PropertyParser(..))
type Pattern = [(String, [(Binding, Value)])]
data Binding = Strong | Weak | Same deriving (Eq, Ord, Enum, Show, Generic)
instance Hashable Binding where
hash Strong = 0
hash Weak = 1
hash Same = 2
addValue :: ToValue x => String -> Binding -> x -> Pattern -> Pattern
addValue key b value pat = normalizePattern ((key, [(b, toValue value)]):pat)
addValues :: ToValue x => String -> Binding -> [x] -> Pattern -> Pattern
addValues key b values pat =
normalizePattern ((key, [(b, toValue v) | v <- values]):pat)
normalizePattern :: Pattern -> Pattern
normalizePattern pat =
[(key, [val | (key', vals) <- pat, key' == key, val <- vals]) | key <- nub $ map fst pat]
equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool
equalSubset a b objs = unsafePerformIO $ withPattern a $ \a' -> withPattern b $ \b' ->
withObjectSet objs $ fcPatternEqualSubset a' b'
foreign import ccall "FcPatternEqualSubset" fcPatternEqualSubset ::
Pattern_ -> Pattern_ -> ObjectSet_ -> IO Bool
filter :: Pattern -> ObjectSet -> Pattern
filter pat objs =
unsafePerformIO $ withPattern pat $ \pat' -> withObjectSet objs $ \objs' ->
thawPattern_ $ fcPatternFilter pat' objs'
foreign import ccall "FcPatternFilter" fcPatternFilter ::
Pattern_ -> ObjectSet_ -> IO Pattern_
defaultSubstitute :: Pattern -> Pattern
defaultSubstitute pat = unsafePerformIO $ withPattern pat $ \pat' -> do
ret <- fcDefaultSubstitute pat'
thawPattern pat'
foreign import ccall "FcDefaultSubstitute" fcDefaultSubstitute :: Pattern_ -> IO ()
-- Is this correct memory management?
nameParse :: String -> Pattern
nameParse name = unsafePerformIO $ withCString name $ \name' ->
thawPattern_ $ fcNameParse name'
foreign import ccall "FcNameParse" fcNameParse :: CString -> IO Pattern_
nameUnparse :: Pattern -> String
nameUnparse pat = unsafePerformIO $ withPattern pat $ \pat' ->
bracket (throwNull <$> fcNameUnparse pat') free peekCString
foreign import ccall "FcNameUnparse" fcNameUnparse :: Pattern_ -> IO CString
format :: Pattern -> String -> String
format pat fmt =
unsafePerformIO $ withPattern pat $ \pat' -> withCString fmt $ \fmt' -> do
bracket (throwNull <$> fcPatternFormat pat' fmt') free peekCString
foreign import ccall "FcPatternFormat" fcPatternFormat ::
Pattern_ -> CString -> IO CString
------
--- Low-level
------
data Pattern'
type Pattern_ = Ptr Pattern'
withPattern :: Pattern -> (Pattern_ -> IO a) -> IO a
withPattern pat cb = withNewPattern $ \pat' -> do
forM pat $ \(obj, vals) -> withCString obj $ \obj' -> do
forM vals $ \(strength, val) -> throwFalse <$> withValue val
(fcPatternAdd_ pat' obj' (strength == Strong) True)
cb pat'
-- Does Haskell FFI support unboxed structs? Do I really need to write a C wrapper?
foreign import ccall "my_FcPatternAdd" fcPatternAdd_ ::
Pattern_ -> CString -> Bool -> Bool -> Value_ -> IO Bool
patternAsPointer :: Pattern -> IO Pattern_
patternAsPointer = flip withPattern $ \ret -> do
fcPatternReference ret
return ret
foreign import ccall "FcPatternReference" fcPatternReference :: Pattern_ -> IO ()
data PatternIter'
type PatternIter_ = Ptr PatternIter'
foreign import ccall "size_PatternIter" patIter'Size :: Int
thawPattern :: Pattern_ -> IO Pattern
thawPattern pat' = allocaBytes patIter'Size $ \iter' -> do
fcPatternIterStart pat' iter'
ret <- go iter'
return $ normalizePattern ret
where
go :: PatternIter_ -> IO Pattern
go iter' = do
ok <- fcPatternIterIsValid pat' iter'
if ok then do
x <- thawPattern' pat' iter'
ok' <- fcPatternIterNext pat' iter'
xs <- if ok' then go iter' else return []
return (x : xs)
else return []
foreign import ccall "FcPatternIterStart" fcPatternIterStart ::
Pattern_ -> PatternIter_ -> IO ()
foreign import ccall "FcPatternIterIsValid" fcPatternIterIsValid ::
Pattern_ -> PatternIter_ -> IO Bool
foreign import ccall "FcPatternIterNext" fcPatternIterNext ::
Pattern_ -> PatternIter_ -> IO Bool
thawPattern' :: Pattern_ -> PatternIter_ -> IO (String, [(Binding, Value)])
thawPattern' pat' iter' = do
obj <- peekCString =<< throwNull <$> fcPatternIterGetObject pat' iter'
count <- fcPatternIterValueCount pat' iter'
values <- forM [0..pred count] $ \i ->
allocaBytes value'Size $ \val' -> alloca $ \binding' -> do
res <- fcPatternIterGetValue pat' iter' i val' binding'
throwInt res $ do
binding <- peek binding'
val' <- thawValue val'
return $ case val' of
Just val | binding >= 0 && binding <= 2 -> Just (toEnum binding, val)
Just val -> Just (Same, val)
Nothing -> Nothing
return (obj, catMaybes $ map join values)
foreign import ccall "FcPatternIterGetObject" fcPatternIterGetObject ::
Pattern_ -> PatternIter_ -> IO CString
foreign import ccall "FcPatternIterValueCount" fcPatternIterValueCount ::
Pattern_ -> PatternIter_ -> IO Int
foreign import ccall "FcPatternIterGetValue" fcPatternIterGetValue ::
Pattern_ -> PatternIter_ -> Int -> Value_ -> Ptr Int -> IO Int
thawPattern_ cb = bracket (throwNull <$> cb) fcPatternDestroy thawPattern
withNewPattern cb = bracket (throwNull <$> fcPatternCreate) fcPatternDestroy cb
foreign import ccall "FcPatternCreate" fcPatternCreate :: IO Pattern_
foreign import ccall "FcPatternDestroy" fcPatternDestroy :: Pattern_ -> IO ()
------
--- Pattern
------
parseFontFamily :: [Token] -> ([String], Bool, [Token])
parseFontFamily (String font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail
in (unpack font:fonts, b, tail')
parseFontFamily (Ident font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail
in (unpack font:fonts, b, tail')
parseFontFamily (String font:tail) = ([unpack font], True, tail)
parseFontFamily (Ident font:tail) = ([unpack font], True, tail)
parseFontFamily toks = ([], False, toks) -- Invalid syntax!
adds a b c d = Just $ addValues a b c d
add a b c d = Just $ addValue a b c d
instance PropertyParser Pattern where
temp = []
longhand _ self "font-family" toks
| (fonts, True, []) <- parseFontFamily toks = adds "family" Strong fonts self
longhand _ _ _ _ = Nothing