From 24a77a5f8850201dfdc3661776cc0e69bc9bc6a0 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 16 Nov 2022 15:53:21 +1300 Subject: [PATCH] Get Value & Pattern types compiling correctly. --- Graphics/Text/Font/Choose/LangSet.hs | 5 ++- Graphics/Text/Font/Choose/Pattern.hs | 66 ++++++++++++++++++---------- Graphics/Text/Font/Choose/Range.hs | 8 +++- Graphics/Text/Font/Choose/Result.hs | 10 ++--- Graphics/Text/Font/Choose/Value.hs | 51 +++++++++++++-------- Graphics/Text/Font/Choose/Weight.hs | 7 +++ cbits/pattern.c | 24 ++++++++++ fontconfig-pure.cabal | 12 +++-- 8 files changed, 131 insertions(+), 52 deletions(-) create mode 100644 Graphics/Text/Font/Choose/Weight.hs create mode 100644 cbits/pattern.c diff --git a/Graphics/Text/Font/Choose/LangSet.hs b/Graphics/Text/Font/Choose/LangSet.hs index f510200..018ce94 100644 --- a/Graphics/Text/Font/Choose/LangSet.hs +++ b/Graphics/Text/Font/Choose/LangSet.hs @@ -29,11 +29,11 @@ foreign import ccall "FcLangSetCompare" fcLangSetCompare :: LangSet_ -> LangSet_ -> IO Int langNormalize :: String -> String -langNormalize = unsafePerformIO $ flip withCString (peekCString . fcLangNormalize) +langNormalize lang = unsafePerformIO $ withCString lang (peekCString . fcLangNormalize) foreign import ccall "FcLangNormalize" fcLangNormalize :: CString -> CString langCharSet :: String -> CharSet -langCharSet = unsafePerformIO $ flip withCString (thawCharSet . fcLangGetCharSet) +langCharSet lang = unsafePerformIO $ withCString lang (thawCharSet . fcLangGetCharSet) foreign import ccall "FcLangGetCharSet" fcLangGetCharSet :: CString -> CharSet_ ------ @@ -52,6 +52,7 @@ withLangSet :: LangSet -> (LangSet_ -> IO a) -> IO a withLangSet langs cb = withNewLangSet $ \langs' -> do forM (Set.elems langs) $ flip withCString $ fcLangSetAdd langs' cb langs' +foreign import ccall "FcLangSetAdd" fcLangSetAdd :: LangSet_ -> CString -> IO Bool thawLangSet :: LangSet_ -> IO LangSet thawLangSet langs' = thawStrSet =<< fcLangSetGetLangs langs' diff --git a/Graphics/Text/Font/Choose/Pattern.hs b/Graphics/Text/Font/Choose/Pattern.hs index 04556f9..559dc05 100644 --- a/Graphics/Text/Font/Choose/Pattern.hs +++ b/Graphics/Text/Font/Choose/Pattern.hs @@ -1,27 +1,37 @@ --- NOTE: Untested! -module Graphics.Text.Font.Choose.Pattern (Pattern(..), Strength(..), equalSubset, +{-# LANGUAGE DeriveGeneric #-} +module Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset, Pattern_, withPattern) where import Prelude hiding (filter) +import Data.List (nub) -import Graphics.Text.Font.Choose.Value (Value, withValue, thawValue, Value_) +import Graphics.Text.Font.Choose.Value (Value, withValue, thawValue, Value_, value'Size) import Graphics.Text.Font.Choose.ObjectSet (ObjectSet, ObjectSet_, withObjectSet) -import Data.Hashable (Hashable) +import Data.Hashable (Hashable(..)) +import GHC.Generics (Generic) import Foreign.Ptr (Ptr) +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Storable (Storable(..)) import Foreign.C.String (CString, withCString, peekCString) import Debug.Trace (trace) -- For reporting internal errors! +import System.IO.Unsafe (unsafePerformIO) -type Pattern = [(String, [(Binding, Value)])] deriving (Eq, Ord, Hashable, Show) -data Binding = Strong | Weak | Same deriving (Eq, Ord, Enum, Show) +import Control.Monad (forM) +import Data.Maybe (catMaybes) +import Control.Exception (bracket) + +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 +normalizePattern :: Pattern -> Pattern normalizePattern pat = - [(key, [val | (key', val) <- pat, key' == key]) | key <- nub $ map fst 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' -> @@ -41,7 +51,7 @@ substitute :: Pattern -> Pattern substitute pat = unsafePerformIO $ withPattern pat $ \pat' -> do ret <- fcDefaultSubstitute pat' thawPattern pat' -foreign import ccall "FcPatternSubstitute" fcPatternSubstitute :: Pattern_ -> IO () +foreign import ccall "FcDefaultSubstitute" fcDefaultSubstitute :: Pattern_ -> IO () nameParse :: String -> Pattern nameParse name = unsafePerformIO $ withCString name $ \name' -> do @@ -53,6 +63,7 @@ nameUnparse :: Pattern -> String nameUnparse pat = unsafePerformIO $ withPattern pat $ \pat' -> do ret <- fcNameUnparse pat' peekCString ret +foreign import ccall "FcNameUnparse" fcNameUnparse :: Pattern_ -> IO CString format :: Pattern -> String -> String format pat fmt = @@ -80,17 +91,19 @@ foreign import ccall "my_FCPatternAdd" fcPatternAdd_ :: Pattern_ -> CString -> Bool -> Bool -> Value_ -> IO Bool patternAsPointer :: Pattern -> IO Pattern_ -patternAsPointer = withPattern fcPatternCopy +patternAsPointer = flip withPattern fcPatternCopy foreign import ccall "FcPatternCopy" fcPatternCopy :: Pattern_ -> IO Pattern_ data PatternIter' -type PatternIter_ = Ptr PatternIter +type PatternIter_ = Ptr PatternIter' +foreign import ccall "size_PatternIter" patIter'Size :: Int thawPattern :: Pattern_ -> IO Pattern -thawPattern pat' = alloca $ \iter' -> do +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 <- fcPatternIterNext pat' iter' if ok then do @@ -105,19 +118,28 @@ foreign import ccall "FcPatternIterNext" fcPatternIterNext :: thawPattern' :: Pattern_ -> PatternIter_ -> IO (String, [(Binding, Value)]) thawPattern' pat' iter' = do - obj <- peekCString $ fcPatternIterGetObject pat' iter' + obj <- peekCString =<< fcPatternIterGetObject pat' iter' count <- fcPatternIterValueCount pat' iter' - values <- forM [0..pred count] $ \i -> alloca $ \val' -> alloca $ \binding' -> do - res <- fcPatternIterGetValue pat' iter' i val' binding' - if res then do - binding <- peek binding' - val <- thawValue val' - return $ Just (toEnum binding, val) - else trace - ("FontConfig: Error retrieving value for " ++ obj ++ - " code: " ++ show res) $ - return Nothing + values <- forM [0..pred count] $ \i -> + allocaBytes value'Size $ \val' -> alloca $ \binding' -> do + res <- fcPatternIterGetValue pat' iter' i val' binding' + if res == 0 then do + binding <- peek binding' + val' <- thawValue val' + return $ case val' of + Just val -> Just (toEnum binding, val) + Nothing -> Nothing + else trace + ("FontConfig: Error retrieving value for " ++ obj ++ + " code: " ++ show res) $ + return Nothing return (obj, catMaybes 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 withNewPattern cb = bracket fcPatternCreate fcPatternDestroy cb foreign import ccall "FcPatternCreate" fcPatternCreate :: IO Pattern_ diff --git a/Graphics/Text/Font/Choose/Range.hs b/Graphics/Text/Font/Choose/Range.hs index f1df94b..808c917 100644 --- a/Graphics/Text/Font/Choose/Range.hs +++ b/Graphics/Text/Font/Choose/Range.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} module Graphics.Text.Font.Choose.Range where import Foreign.Ptr (Ptr) @@ -5,9 +6,14 @@ import Control.Exception (bracket) import Foreign.Marshal.Alloc (alloca) import Foreign.Storable (peek) -data Range = Range Double Double +import GHC.Generics (Generic) +import Data.Hashable (Hashable) + +data Range = Range Double Double deriving (Eq, Show, Ord, Generic) iRange i j = toEnum i `Range` toEnum j +instance Hashable Range + ------ --- Low-level ------ diff --git a/Graphics/Text/Font/Choose/Result.hs b/Graphics/Text/Font/Choose/Result.hs index ed785ef..dda0344 100644 --- a/Graphics/Text/Font/Choose/Result.hs +++ b/Graphics/Text/Font/Choose/Result.hs @@ -1,7 +1,7 @@ module Graphics.Text.Font.Choose.Result (Result(..), resultFromPointer) where import Foreign.Storable (peek) -import Foreign.Ptr (Ptr, ptrNull) +import Foreign.Ptr (Ptr, nullPtr) import Control.Exception (throwIO, throw, Exception) data Result = Match | NoMatch | TypeMismatch | ResultNoId | OutOfMemory @@ -16,9 +16,9 @@ instance Exception Error throwResult :: Result -> IO a -> IO (Maybe a) throwResult Match x = Just <$> x throwResult NoMatch _ = return Nothing -throwResult TypeMismatch = throwIO ErrTypeMismatch -throwResult ResultNoId = throwIO ErrResultNoId -throwResult OutOfMemory = throwIO ErrOutOfMemory +throwResult TypeMismatch _ = throwIO ErrTypeMismatch +throwResult ResultNoId _ = throwIO ErrResultNoId +throwResult OutOfMemory _ = throwIO ErrOutOfMemory throwInt :: Int -> IO a -> IO (Maybe a) throwInt = throwResult . toEnum @@ -32,5 +32,5 @@ throwFalse' :: IO Bool -> IO () throwFalse' = (>>= throwFalse) throwNull :: Ptr a -> Ptr a -throwNull ptr | ptr == ptrNull = throw ErrOutOfMemory +throwNull ptr | ptr == nullPtr = throw ErrOutOfMemory | otherwise = ptr diff --git a/Graphics/Text/Font/Choose/Value.hs b/Graphics/Text/Font/Choose/Value.hs index 867b631..62f4b4e 100644 --- a/Graphics/Text/Font/Choose/Value.hs +++ b/Graphics/Text/Font/Choose/Value.hs @@ -1,25 +1,34 @@ --- NOTE: Untested! -module Data.Text.Font.Choose where +{-# LANGUAGE DeriveGeneric #-} +module Graphics.Text.Font.Choose.Value where import Linear.Matrix (M22) -import Graphics.Text.Font.Choose.CharSet (CharSet) +import Linear.V2 (V2(..)) +import Graphics.Text.Font.Choose.CharSet (CharSet, withCharSet, thawCharSet) import FreeType.Core.Base (FT_Face(..)) -import Graphics.Text.Font.Choose.LangSet (LangSet) -import Graphics.Text.Font.Choose.Range (Range) +import Graphics.Text.Font.Choose.LangSet (LangSet, withLangSet, thawLangSet) +import Graphics.Text.Font.Choose.Range (Range, withRange, thawRange) -import Foreign.Ptr (Ptr) +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (Storable(..)) +import Foreign.Marshal.Array (advancePtr) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.C.String (withCString, peekCString) + +import GHC.Generics (Generic) +import Data.Hashable (Hashable) data Value = ValueVoid | ValueInt Int | ValueDouble Double | ValueString String + | ValueBool Bool | ValueMatrix (M22 Double) | ValueCharSet CharSet | ValueFTFace FT_Face | ValueLangSet LangSet | ValueRange Range deriving (Eq, Show, Ord, Generic) -instance GHashable Value +instance Hashable Value ------ --- Low-level @@ -27,8 +36,8 @@ instance GHashable Value type Value_ = Ptr Int -value'Size = sizeof (undefined :: Int) * 2 -pokeUnion ptr x = castPtr (ptr `plusPtr` sizeof (undefined :: Int)) `poke` x +foreign import ccall "sizeof_Value" value'Size :: Int +pokeUnion ptr x = castPtr (ptr `advancePtr` 1) `poke` x withValue :: Value -> (Value_ -> IO a) -> IO a withValue ValueVoid cb = allocaBytes value'Size $ \val' -> do @@ -43,36 +52,40 @@ withValue (ValueDouble x) cb = allocaBytes value'Size $ \val' -> do pokeUnion val' x cb val' withValue (ValueString str) cb = - withCString str $ \str' allocaBytes value'Size $ \val' -> do + withCString str $ \str' -> allocaBytes value'Size $ \val' -> do poke val' 3 pokeUnion val' str' cb val' +withValue (ValueBool b) cb = allocaBytes value'Size $ \val' -> do + poke val' 4 + pokeUnion val' b + cb val' withValue (ValueMatrix mat) cb = withMatrix mat $ \mat' -> allocaBytes value'Size $ \val' -> do - poke val' 4 + poke val' 5 pokeUnion val' mat' cb val' withValue (ValueCharSet charsets) cb = - withCharSets charsets $ \charsets' -> allocaBytes value'Size $ \val' -> do - poke val' 5 + withCharSet charsets $ \charsets' -> allocaBytes value'Size $ \val' -> do + poke val' 6 pokeUnion val' charsets' cb val' withValue (ValueFTFace x) cb = allocaBytes value'Size $ \val' -> do - poke val' 6 + poke val' 7 pokeUnion val' x cb val' withValue (ValueLangSet langset) cb = withLangSet langset $ \langset' -> allocaBytes value'Size $ \val' -> do - poke val' 7 + poke val' 8 pokeUnion val' langset' cb val' withValue (ValueRange range) cb = withRange range $ \range' -> allocaBytes value'Size $ \val' -> do - poke val' 8 + poke val' 9 pokeUnion val' range' cb val' -mat22Size = sizeof (undefined :: Double) * 4 +foreign import ccall "size_matrix" mat22Size :: Int withMatrix (V2 (V2 xx yx) (V2 xy yy)) cb = allocaBytes mat22Size $ \mat' -> do pokeElemOff mat' 0 xx pokeElemOff mat' 1 xy @@ -83,9 +96,9 @@ withMatrix (V2 (V2 xx yx) (V2 xy yy)) cb = allocaBytes mat22Size $ \mat' -> do thawValue :: Value_ -> IO (Maybe Value) thawValue ptr = do kind <- peek ptr - let val' = castPtr (ptr `plusPtr` sizeof (undefined :: Int)) + let val' = castPtr (ptr `advancePtr` 1) case kind of - 0 -> return ValueVoid + 0 -> return $ Just ValueVoid 1 -> Just <$> ValueInt <$> peek val' 2 -> Just <$> ValueDouble <$> peek val' 3 -> Just <$> ValueString <$> peekCString val' diff --git a/Graphics/Text/Font/Choose/Weight.hs b/Graphics/Text/Font/Choose/Weight.hs new file mode 100644 index 0000000..411d248 --- /dev/null +++ b/Graphics/Text/Font/Choose/Weight.hs @@ -0,0 +1,7 @@ +module Graphics.Text.Font.Choose.Weight where + +foreign import ccall "FcWeightFromOpenTypeDouble" weightFromOpenTypeDouble :: + Double -> Double +foreign import ccall "FcWeightToOpenTypeDouble" weightToOpenTypeDouble :: + Double -> Double + diff --git a/cbits/pattern.c b/cbits/pattern.c new file mode 100644 index 0000000..39cab51 --- /dev/null +++ b/cbits/pattern.c @@ -0,0 +1,24 @@ +#include + +int my_FcCHARSET_MAP_SIZE() { + return FC_CHARSET_MAP_SIZE; +} + +FcBool my_FcPatternAdd(FcPattern *p, const char *object, + FcBool binding, FcBool append, FcValue *value) { + if (binding) { + return FcPatternAdd(p, object, *value, append); + } else { + return FcPatternAddWeak(p, object, *value, append); + } +} + +int size_value() { + return sizeof(FcValue); +} +int size_matrix() { + return sizeof(FcMatrix); +} +int size_PatternIter() { + return sizeof(FcPatternIter); +} diff --git a/fontconfig-pure.cabal b/fontconfig-pure.cabal index 27142d3..aeead85 100644 --- a/fontconfig-pure.cabal +++ b/fontconfig-pure.cabal @@ -51,9 +51,13 @@ cabal-version: >=1.10 library -- Modules exported by the library. - exposed-modules: Graphics.Text.Font.Choose.Init, + exposed-modules: Graphics.Text.Font.Choose.Result, Graphics.Text.Font.Choose.ObjectSet, Graphics.Text.Font.Choose.CharSet, - Graphics.Text.Font.Choose.Strings, Graphics.Text.Font.Choose.Range + Graphics.Text.Font.Choose.Strings, Graphics.Text.Font.Choose.Range, + Graphics.Text.Font.Choose.LangSet, Graphics.Text.Font.Choose.Value, + Graphics.Text.Font.Choose.Pattern + + c-sources: cbits/pattern.c -- Modules included in this library but not exported. -- other-modules: @@ -62,7 +66,9 @@ library -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base >=4.12 && <4.13, containers + build-depends: base >=4.12 && <4.13, containers >= 0.1 && <1, + linear >= 1.0.1 && <2, freetype2 >= 0.2 && < 0.3, + hashable >= 1.3 && <2 -- Directories containing source files. -- hs-source-dirs: -- 2.30.2