8 files changed, 131 insertions(+), 52 deletions(-)

M Graphics/Text/Font/Choose/LangSet.hs
M Graphics/Text/Font/Choose/Pattern.hs
M Graphics/Text/Font/Choose/Range.hs
M Graphics/Text/Font/Choose/Result.hs
M Graphics/Text/Font/Choose/Value.hs
A Graphics/Text/Font/Choose/Weight.hs
A cbits/pattern.c
M fontconfig-pure.cabal

@@ 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'

@@ 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_

@@ 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
 ------

@@ 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

@@ 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'

@@ 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
+

@@ 0,0 1,24 @@
+#include <fontconfig/fontconfig.h>
+
+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);
+}

@@ 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: