From e21707cbfcfa7ca64988c599b160d867debaf9a9 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 12 Nov 2022 16:53:41 +1300 Subject: [PATCH] First! --- CHANGELOG.md | 5 + Graphics/Text/Font/Choose/CharSet.hs | 50 ++++++++++ Graphics/Text/Font/Choose/Config.hs | 0 Graphics/Text/Font/Choose/Constant.hs | 3 + Graphics/Text/Font/Choose/FontSet.hs | 76 +++++++++++++++ Graphics/Text/Font/Choose/FreeType.hs | 60 ++++++++++++ Graphics/Text/Font/Choose/Init.hs | 14 +++ Graphics/Text/Font/Choose/LangResult.hs | 0 Graphics/Text/Font/Choose/LangSet.hs | 51 ++++++++++ Graphics/Text/Font/Choose/ObjectSet.hs | 27 ++++++ Graphics/Text/Font/Choose/ObjectType.hs | 5 + Graphics/Text/Font/Choose/Pattern.hs | 124 ++++++++++++++++++++++++ Graphics/Text/Font/Choose/Range.hs | 30 ++++++ Graphics/Text/Font/Choose/Result.hs | 9 ++ Graphics/Text/Font/Choose/SetName.hs | 0 Graphics/Text/Font/Choose/Strings.hs | 63 ++++++++++++ Graphics/Text/Font/Choose/Value.hs | 103 ++++++++++++++++++++ LICENSE | 20 ++++ Main.hs | 4 + Setup.hs | 2 + fontconfig-pure.cabal | 92 ++++++++++++++++++ 21 files changed, 738 insertions(+) create mode 100644 CHANGELOG.md create mode 100644 Graphics/Text/Font/Choose/CharSet.hs create mode 100644 Graphics/Text/Font/Choose/Config.hs create mode 100644 Graphics/Text/Font/Choose/Constant.hs create mode 100644 Graphics/Text/Font/Choose/FontSet.hs create mode 100644 Graphics/Text/Font/Choose/FreeType.hs create mode 100644 Graphics/Text/Font/Choose/Init.hs create mode 100644 Graphics/Text/Font/Choose/LangResult.hs create mode 100644 Graphics/Text/Font/Choose/LangSet.hs create mode 100644 Graphics/Text/Font/Choose/ObjectSet.hs create mode 100644 Graphics/Text/Font/Choose/ObjectType.hs create mode 100644 Graphics/Text/Font/Choose/Pattern.hs create mode 100644 Graphics/Text/Font/Choose/Range.hs create mode 100644 Graphics/Text/Font/Choose/Result.hs create mode 100644 Graphics/Text/Font/Choose/SetName.hs create mode 100644 Graphics/Text/Font/Choose/Strings.hs create mode 100644 Graphics/Text/Font/Choose/Value.hs create mode 100644 LICENSE create mode 100644 Main.hs create mode 100644 Setup.hs create mode 100644 fontconfig-pure.cabal diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..a8cbb41 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for fontconfig-pure + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/Graphics/Text/Font/Choose/CharSet.hs b/Graphics/Text/Font/Choose/CharSet.hs new file mode 100644 index 0000000..67aa4d2 --- /dev/null +++ b/Graphics/Text/Font/Choose/CharSet.hs @@ -0,0 +1,50 @@ +module Graphics.Text.Font.Choose.CharSet where + +import Data.Set (Set) +import qualified Data.Set as Set + +import Data.Word (Word32) +import Foreign.Ptr +import Control.Exception (bracket) +import Control.Monad (forM) +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import GHC.Base (unsafeChr) +import Data.Char (ord) + +type CharSet = Set Char + +------ +--- Low-level +------ + +data CharSet' +type CharSet_ = Ptr CharSet' + +withNewCharSet :: (CharSet_ -> IO a) -> IO a +withNewCharSet cb = bracket fcCharSetCreate fcCharSetDestroy cb +foreign import ccall "FcCharSetCreate" fcCharSetCreate :: IO CharSet_ +foreign import ccall "FcCharSetDestroy" fcCharSetDestroy :: CharSet_ -> IO () + +withCharSet :: CharSet -> (CharSet_ -> IO a) -> IO a +withCharSet chars cb = withNewCharSet $ \chars' -> do + forM (Set.elems chars) $ fcCharSetAddChar chars' . fromIntegral . ord + cb chars' +foreign import ccall "FcCharSetAddChar" fcCharSetAddChar :: CharSet_ -> Word32 -> IO Bool + +thawCharSet :: CharSet_ -> IO CharSet +thawCharSet chars' = allocaBytes fcCHARSET_MAP_SIZE $ \iter' -> alloca $ \next' -> do + first <- fcCharSetFirstPage chars' iter' next' + let go = do { + ch <- fcCharSetNextPage chars' iter' next'; + if ch == maxBound then return [] + else do + chs <- go + return (ch:chs) + } + rest <- go + return $ Set.fromList $ map (unsafeChr . fromIntegral) (first:rest) +foreign import ccall "FcCharSetFirstPage" fcCharSetFirstPage :: + CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32 +foreign import ccall "FcCharSetNextPage" fcCharSetNextPage :: + CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32 +foreign import ccall "my_FcCHARSET_MAP_SIZE" fcCHARSET_MAP_SIZE :: Int diff --git a/Graphics/Text/Font/Choose/Config.hs b/Graphics/Text/Font/Choose/Config.hs new file mode 100644 index 0000000..e69de29 diff --git a/Graphics/Text/Font/Choose/Constant.hs b/Graphics/Text/Font/Choose/Constant.hs new file mode 100644 index 0000000..b076045 --- /dev/null +++ b/Graphics/Text/Font/Choose/Constant.hs @@ -0,0 +1,3 @@ +module Graphics.Text.Font.Choose.Constant where + +data Constant = Constant { name :: String, object :: String, value :: Int } diff --git a/Graphics/Text/Font/Choose/FontSet.hs b/Graphics/Text/Font/Choose/FontSet.hs new file mode 100644 index 0000000..5af77f3 --- /dev/null +++ b/Graphics/Text/Font/Choose/FontSet.hs @@ -0,0 +1,76 @@ +-- NOTE: Untested! +module Graphics.Text.Font.Choose.FontSet where + +import Graphics.Text.Font.Choose.Pattern +import Graphics.Text.Font.Choose.Config +import Graphics.Text.Font.Choose.ObjectSet + +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (pokeElemOff, sizeOf, peek) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Array (advancePtr) +import Control.Monad (forM) +import Control.Exception (bracket) + +type FontSet = [Pattern] + +fontSetList :: Config -> [FontSet] -> Pattern -> ObjectSet +fontSetList config fontss pattern objs = withConfig config $ \config' -> + withFontSets fontss $ \fontss' -> withPattern $ \pattern' -> + withObjectSet objs $ \objs' -> do + ret <- fcFontSetList config' fontss' n pattern' objs' + thawFontSet ret +foreign import ccall "FcFontSetList" fcFontSetList :: + Config_ -> Ptr FontSet_ -> Int -> Pattern_ -> ObjectSet_ -> IO FontSet_ + +fontSetMatch :: Config -> [FontSet] -> Pattern -> Maybe Pattern +fontSetMatch config fontss pattern = withConfig config $ \config' -> + withFontSets fontss $ \fontss' -> withPattern $ \pattern' -> alloca $ \res' -> do + ret <- fcFontSetMatch config' fontss' n pattern' res' + res <- peek res' + -- FIXME Is this correct success code? + if res == 0 then Just <$> thawPattern ret else return Nothing + +fontSetSort :: Config -> [FontSet] -> Pattern -> Bool -> CharSet -> Maybe FontSet +fontSetSort config fontss pattern trim csp cb = withConfig config $ \config' -> + withFontSets fontss $ \fontss' withPattern $ \pattern' -> + withCharSet csp $ \csp' -> alloca $ \res' -> do + ret' <- fcFontSetSort config' fontss' n pattern' trim csp' res' + res <- peek res' + ret <- if res == 0 then Just <$> thawFontSet ret' else return Nothing + fcFontSetDestroy ret' + return ret + +------ +--- Low-level +------ +type FontSet' = Int +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' -> + forM fonts $ \font -> (fcFontSetAdd fonts' =<< patternAsPointer font) + cb fonts' + +withFontSets :: [FontSet] -> (Ptr FontSet_ -> IO a) -> IO a +withFontSets fontss cb = let n = length fontss in + allocaBytes (sizeOf (undefined :: FontSet_) * n) $ \fontss' -> + withFontSets' fontss 0 fontss' -> cb fontss' +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 + n <- peek fonts' + array <- peek $ castPtr $ advancePtr fonts' 2 + if n == 0 || array == nullPtr + then return [] + else forM [0..pred n] $ \i -> thawPattern (advancePtr array i) diff --git a/Graphics/Text/Font/Choose/FreeType.hs b/Graphics/Text/Font/Choose/FreeType.hs new file mode 100644 index 0000000..320b092 --- /dev/null +++ b/Graphics/Text/Font/Choose/FreeType.hs @@ -0,0 +1,60 @@ +-- NOTE: Not tested +module Graphics.Text.Font.Choose.FreeType where + +import Graphics.Text.Font.Choose.CharSet (CharSet, CharSet_, thawCharSet) +import Graphics.Text.Font.Choose.Pattern (Pattern, Pattern_, thawPattern) +import Graphics.Text.Font.Choose.FontSet (FontSet, FontSet_, withFontSet, thawFontSet) +import FreeType.Core.Base (FT_Face(..)) +import Data.Word (Word32, Word) + +import Foreign.Ptr (nullPtr) +import Foreign.Storable (peek) +import Foreign.Marshal.Alloc (alloca) +import Foreign.C.String (CString, withCString) +import System.IO.Unsafe (unsafePerformIO) + +c2w :: Char -> Word32 +c2w = fromIntegral + +ftCharIndex :: FT_Face -> Char -> Word +ftCharIndex face = fcFreeTypeCharIndex face . c2w +foreign import ccall "FcFreeTypeCharIndex" fcFreeTypeCharIndex :: FT_Face -> Word32 -> Word + +ftCharSet :: FT_Face -> CharSet +ftCharSet face = unsafePerformIO $ thawCharSet $ fcFreeTypeCharSet face nullPtr +foreign import ccall "FcFreeTypeCharSet" fcFreeTypeCharSet + :: FT_Face -> Ptr () -> FcCharSet_ -- 2nd arg's deprecated! + +ftCharSetAndSpacing :: FT_Face -> (CharSet, Int) +ftCharSetAndSpacing face = unsafePerformIO $ alloca $ \spacing' -> do + chars' <- fcFreeTypeCharSetAndSpacing face nullPtr spacing' + chars <- thawCharSet chars' + spacing <- peek spacing' + return (chars, spacing) +foreign import ccall "FcFreeTypeCharSetAndSpacing" fcFreeTypeCharSetAndSpacing :: + FT_Face -> Ptr () -> Ptr Int -> IO CharSet_ -- 2nd arg's deprecated! + +ftQuery :: FilePath -> Int -> IO (Pattern, Int) +ftQuery filename id = withCString filename $ \filename' -> alloca $ \count' -> do + pattern' <- fcFreeTypeQuery filename' id nullPtr count' + pattern <- thawPattern pattern' + count <- peek count' + return (pattern, count) +foreign import call "FcFreeTypeQuery" fcFreeTypeQuery :: + CString -> Int -> Ptr () -> Ptr Int -> IO Pattern_ -- 3rd arg's deprecated! + +ftQueryAll :: FilePath -> Int -> IO (FontSet, Int) +ftQueryAll filename id = withCString filename $ \filename' -> alloca \count' -> + withFontSet [] $ \fonts' -> do + fcFreeTypeQueryAll filename' id nullPtr count' fonts' + fonts <- thawFontSet fonts' + count <- peek count' + return (fonts, count) +foreign import ccall "FcFreeTypeQueryAll" fcFreeTypeQueryAll :: + CString -> Int -> Ptr () -> Ptr Count -> FontSet_ -> IO Word -- 2nd arg's deprecated! + +ftQueryFace :: FT_Face -> FilePath -> Int -> Pattern +ftQueryFace face filename id = withCString filename $ \filename' -> + thawPattern $ fcFreeTypeQueryFace face filename' id nullPtr +foreign import ccall "FcFreeTypeQueryFace" fcFreeTypeQueryFace :: + FT_Face -> CString -> Int -> Ptr () -> Pattern_ -- Final arg's deprecated! diff --git a/Graphics/Text/Font/Choose/Init.hs b/Graphics/Text/Font/Choose/Init.hs new file mode 100644 index 0000000..860283b --- /dev/null +++ b/Graphics/Text/Font/Choose/Init.hs @@ -0,0 +1,14 @@ +module Graphics.Text.Font.Choose.Init ({-Config, initLoadConfig, initLoadConfigAndFonts, -} + init, fini, reinit, bringUptoDate, version) where + +import Prelude hiding (init) + +{-foreign import ccall "FcInitLoadConfig" initLoadConfig :: IO Config +foreign import ccall "FcInitLoadConfigAndFonts" initLoadConfigAndFonts :: IO Config-} + +foreign import ccall "FcInit" init :: IO Bool +foreign import ccall "FcFini" fini :: IO () +foreign import ccall "FcInitReinitialize" reinit :: IO Bool +foreign import ccall "FcInitBringUptoDate" bringUptoDate :: IO Bool + +foreign import ccall "FcGetVersion" version :: Int diff --git a/Graphics/Text/Font/Choose/LangResult.hs b/Graphics/Text/Font/Choose/LangResult.hs new file mode 100644 index 0000000..e69de29 diff --git a/Graphics/Text/Font/Choose/LangSet.hs b/Graphics/Text/Font/Choose/LangSet.hs new file mode 100644 index 0000000..d3faf27 --- /dev/null +++ b/Graphics/Text/Font/Choose/LangSet.hs @@ -0,0 +1,51 @@ +module Graphics.Text.Font.Choose.LangSet where + +import Data.Set (Set) +import qualified Data.Set as Set +import Graphics.Text.Font.Choose.Strings (thawStrSet, StrSet_) +import Graphics.Text.Font.Choose.CharSet (thawCharSet, CharSet_, CharSet) + +import Foreign.Ptr (Ptr) +import Foreign.C.String (CString, withCString, peekCString) +import Control.Exception (bracket) +import Control.Monad (forM) +import System.IO.Unsafe (unsafePerformIO) + +type LangSet = Set String + +defaultLangs :: IO LangSet +defaultLangs = thawStrSet =<< fcGetDefaultLangs +foreign import ccall "FcGetDefaultLangs" fcGetDefaultLangs :: IO StrSet_ + +langs :: LangSet +langs = unsafePerformIO (thawStrSet =<< fcGetLangs) +foreign import ccall "FcGetLangs" fcGetLangs :: IO StrSet_ + +langNormalize :: String -> String +langNormalize = unsafePerformIO $ flip withCString (peekCString . fcLangNormalize) +foreign import ccall "FcLangNormalize" fcLangNormalize :: CString -> CString + +langCharSet :: String -> CharSet +langCharSet = unsafePerformIO $ flip withCString (thawCharSet . fcLangGetCharSet) +foreign import ccall "FcLangGetCharSet" fcLangGetCharSet :: CString -> CharSet_ + +------ +--- Low-level +------ + +data LangSet' +type LangSet_ = Ptr LangSet' + +withNewLangSet :: (LangSet_ -> IO a) -> IO a +withNewLangSet = bracket fcLangSetCreate fcLangSetDestroy +foreign import ccall "FcLangSetCreate" fcLangSetCreate :: IO LangSet_ +foreign import ccall "FcLangSetDestroy" fcLangSetDestroy :: LangSet_ -> IO () + +withLangSet :: LangSet -> (LangSet_ -> IO a) -> IO a +withLangSet langs cb = withNewLangSet $ \langs' -> do + forM (Set.elems langs) $ flip withCString $ fcLangSetAdd langs' + cb langs' + +thawLangSet :: LangSet_ -> IO LangSet +thawLangSet langs' = thawStrSet =<< fcLangSetGetLangs langs' +foreign import ccall "FcLangSetGetLangs" fcLangSetGetLangs :: LangSet_ -> IO StrSet_ diff --git a/Graphics/Text/Font/Choose/ObjectSet.hs b/Graphics/Text/Font/Choose/ObjectSet.hs new file mode 100644 index 0000000..ef93a5b --- /dev/null +++ b/Graphics/Text/Font/Choose/ObjectSet.hs @@ -0,0 +1,27 @@ +module Graphics.Text.Font.Choose.ObjectSet where + +import Foreign.Ptr (Ptr) +import Foreign.C.String (CString, withCString) + +import Control.Monad (forM) +import Control.Exception (bracket) + +type ObjectSet = [String] + +------ +--- LowLevel +------ +data ObjectSet' +type ObjectSet_ = Ptr ObjectSet' + +withObjectSet :: ObjectSet -> (ObjectSet_ -> IO a) -> IO a +withObjectSet objs cb = withNewObjectSet $ \objs' -> do + forM objs $ \obj -> withCString obj $ fcObjectSetAdd objs' + cb objs' +foreign import ccall "FcObjectSetAdd" fcObjectSetAdd :: + ObjectSet_ -> CString -> IO Bool + +withNewObjectSet :: (ObjectSet_ -> IO a) -> IO a +withNewObjectSet cb = bracket fcObjectSetCreate fcObjectSetDestroy cb +foreign import ccall "FcObjectSetCreate" fcObjectSetCreate :: IO ObjectSet_ +foreign import ccall "FcObjectSetDestroy" fcObjectSetDestroy :: ObjectSet_ -> IO () diff --git a/Graphics/Text/Font/Choose/ObjectType.hs b/Graphics/Text/Font/Choose/ObjectType.hs new file mode 100644 index 0000000..f78c4b3 --- /dev/null +++ b/Graphics/Text/Font/Choose/ObjectType.hs @@ -0,0 +1,5 @@ +module Graphics.Text.Font.Choose.ObjectType + +import Graphics.Text.Font.Choose.Value (Value) + +data ObjectType = ObjectType String Value diff --git a/Graphics/Text/Font/Choose/Pattern.hs b/Graphics/Text/Font/Choose/Pattern.hs new file mode 100644 index 0000000..04556f9 --- /dev/null +++ b/Graphics/Text/Font/Choose/Pattern.hs @@ -0,0 +1,124 @@ +-- NOTE: Untested! +module Graphics.Text.Font.Choose.Pattern (Pattern(..), Strength(..), equalSubset, + Pattern_, withPattern) where + +import Prelude hiding (filter) + +import Graphics.Text.Font.Choose.Value (Value, withValue, thawValue, Value_) +import Graphics.Text.Font.Choose.ObjectSet (ObjectSet, ObjectSet_, withObjectSet) +import Data.Hashable (Hashable) + +import Foreign.Ptr (Ptr) +import Foreign.C.String (CString, withCString, peekCString) +import Debug.Trace (trace) -- For reporting internal errors! + +type Pattern = [(String, [(Binding, Value)])] deriving (Eq, Ord, Hashable, Show) +data Binding = Strong | Weak | Same deriving (Eq, Ord, Enum, Show) + +instance Hashable Binding where + hash Strong = 0 + hash Weak = 1 + hash Same = 2 + +normalizePattern pat = + [(key, [val | (key', val) <- pat, key' == key]) | 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' -> do + ret <- fcPatternFilter pat' objs' + thawPattern ret +foreign import ccall "FcPatternFilter" fcPatternFilter :: + Pattern_ -> ObjectSet_ -> IO Pattern_ + +substitute :: Pattern -> Pattern +substitute pat = unsafePerformIO $ withPattern pat $ \pat' -> do + ret <- fcDefaultSubstitute pat' + thawPattern pat' +foreign import ccall "FcPatternSubstitute" fcPatternSubstitute :: Pattern_ -> IO () + +nameParse :: String -> Pattern +nameParse name = unsafePerformIO $ withCString name $ \name' -> do + ret <- fcNameParse name' + thawPattern ret +foreign import ccall "FcNameParse" fcNameParse :: CString -> IO Pattern_ + +nameUnparse :: Pattern -> String +nameUnparse pat = unsafePerformIO $ withPattern pat $ \pat' -> do + ret <- fcNameUnparse pat' + peekCString ret + +format :: Pattern -> String -> String +format pat fmt = + unsafePerformIO $ withPattern pat $ \pat' -> withCString fmt $ \fmt' -> do + ret <- fcPatternFormat pat' fmt' + peekCString ret +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) -> 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 = withPattern fcPatternCopy +foreign import ccall "FcPatternCopy" fcPatternCopy :: Pattern_ -> IO Pattern_ + +data PatternIter' +type PatternIter_ = Ptr PatternIter +thawPattern :: Pattern_ -> IO Pattern +thawPattern pat' = alloca $ \iter' -> do + fcPatternIterStart pat' iter' + ret <- go iter' + return $ normalizePattern ret + where + go iter' = do + ok <- fcPatternIterNext pat' iter' + if ok then do + x <- thawPattern' pat' iter' + xs <- go iter' + return (x : xs) + else return [] +foreign import ccall "FcPatternIterStart" fcPatternIterStart :: + Pattern_ -> PatternIter_ -> IO () +foreign import ccall "FcPatternIterNext" fcPatternIterNext :: + Pattern_ -> PatternIter_ -> IO Bool + +thawPattern' :: Pattern_ -> PatternIter_ -> IO (String, [(Binding, Value)]) +thawPattern' pat' iter' = do + 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 + return (obj, catMaybes values) + +withNewPattern cb = bracket fcPatternCreate fcPatternDestroy cb +foreign import ccall "FcPatternCreate" fcPatternCreate :: IO Pattern_ +foreign import ccall "FcPatternDestroy" fcPatternDestroy :: Pattern_ -> IO () diff --git a/Graphics/Text/Font/Choose/Range.hs b/Graphics/Text/Font/Choose/Range.hs new file mode 100644 index 0000000..f1df94b --- /dev/null +++ b/Graphics/Text/Font/Choose/Range.hs @@ -0,0 +1,30 @@ +module Graphics.Text.Font.Choose.Range where + +import Foreign.Ptr (Ptr) +import Control.Exception (bracket) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Storable (peek) + +data Range = Range Double Double +iRange i j = toEnum i `Range` toEnum j + +------ +--- Low-level +------ +data Range' +type Range_ = Ptr Range' + +withRange :: Range -> (Range_ -> IO a) -> IO a +withRange (Range i j) = bracket (fcRangeCreateDouble i j) fcRangeDestroy +foreign import ccall "FcRangeCreateDouble" fcRangeCreateDouble :: + Double -> Double -> IO Range_ +foreign import ccall "FcRangeDestroy" fcRangeDestroy :: Range_ -> IO () + +thawRange :: Range_ -> IO Range +thawRange range' = alloca $ \i' -> alloca $ \j' -> do + fcRangeGetDouble range' i' j' + i <- peek i' + j <- peek j' + return $ Range i j +foreign import ccall "FcRangeGetDouble" fcRangeGetDouble :: + Range_ -> Ptr Double -> Ptr Double -> IO Bool diff --git a/Graphics/Text/Font/Choose/Result.hs b/Graphics/Text/Font/Choose/Result.hs new file mode 100644 index 0000000..a451e5c --- /dev/null +++ b/Graphics/Text/Font/Choose/Result.hs @@ -0,0 +1,9 @@ +module Graphics.Text.Font.Choose.Result (Result(..), resultFromPointer) where + +import Foreign.Storable (peek) + +data Result = Match | NoMatch | TypeMismatch | ResultNoId | OutOfMemory + deriving (Eq, Show, Read, Enum) + +resultFromPointer :: Ptr Int -> IO Result +resultFromPointer res = toEnum <$> peek res diff --git a/Graphics/Text/Font/Choose/SetName.hs b/Graphics/Text/Font/Choose/SetName.hs new file mode 100644 index 0000000..e69de29 diff --git a/Graphics/Text/Font/Choose/Strings.hs b/Graphics/Text/Font/Choose/Strings.hs new file mode 100644 index 0000000..b64f3e7 --- /dev/null +++ b/Graphics/Text/Font/Choose/Strings.hs @@ -0,0 +1,63 @@ +module Graphics.Text.Font.Choose.Strings (StrSet, StrSet_, StrList, StrList_, + withStrSet, withFilenameSet, thawStrSet, withStrList, thawStrList) where + +import Data.Set (Set) +import qualified Data.Set as Set + +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.C.String (CString, withCString, peekCString) +import Control.Exception (bracket) +import Control.Monad (forM) + +type StrSet = Set String + +data StrSet' +type StrSet_ = Ptr StrSet' + +withNewStrSet :: (StrSet_ -> IO a) -> IO a +withNewStrSet = bracket fcStrSetCreate fcStrSetDestroy +foreign import ccall "FcStrSetCreate" fcStrSetCreate :: IO StrSet_ +foreign import ccall "FcStrSetDestroy" fcStrSetDestroy :: StrSet_ -> IO () + +withStrSet :: StrSet -> (StrSet_ -> IO a) -> IO a +withStrSet strs cb = withNewStrSet $ \strs' -> do + forM (Set.elems strs) $ flip withCString $ fcStrSetAdd strs' + cb strs' +foreign import ccall "FcStrSetAdd" fcStrSetAdd :: StrSet_ -> CString -> IO Bool + +withFilenameSet :: StrSet -> (StrSet_ -> IO a) -> IO a +withFilenameSet paths cb = withNewStrSet $ \paths' -> do + forM (Set.elems paths) $ flip withCString $ fcStrSetAddFilename paths' + cb paths' +foreign import ccall "FcStrSetAddFilename" fcStrSetAddFilename :: + StrSet_ -> CString -> IO Bool + +thawStrSet :: StrSet_ -> IO StrSet +thawStrSet strs = Set.fromList <$> withStrList strs thawStrList + +------------ + +type StrList = [String] + +data StrList' +type StrList_ = Ptr StrList' + +withStrList :: StrSet_ -> (StrList_ -> IO a) -> IO a +withStrList strs = bracket (fcStrListCreate strs) fcStrListDone +foreign import ccall "FcStrListCreate" fcStrListCreate :: StrSet_ -> IO StrList_ +foreign import ccall "FcStrListDone" fcStrListDone :: StrList_ -> IO () + +thawStrList :: StrList_ -> IO StrList +thawStrList strs' = do + fcStrListFirst strs' + go + where + go = do + item' <- fcStrListNext strs' + if item' == nullPtr then return [] + else do + item <- peekCString item' + items <- go + return (item : items) +foreign import ccall "FcStrListFirst" fcStrListFirst :: StrList_ -> IO () +foreign import ccall "FcStrListNext" fcStrListNext :: StrList_ -> IO CString diff --git a/Graphics/Text/Font/Choose/Value.hs b/Graphics/Text/Font/Choose/Value.hs new file mode 100644 index 0000000..867b631 --- /dev/null +++ b/Graphics/Text/Font/Choose/Value.hs @@ -0,0 +1,103 @@ +-- NOTE: Untested! +module Data.Text.Font.Choose where + +import Linear.Matrix (M22) +import Graphics.Text.Font.Choose.CharSet (CharSet) +import FreeType.Core.Base (FT_Face(..)) +import Graphics.Text.Font.Choose.LangSet (LangSet) +import Graphics.Text.Font.Choose.Range (Range) + +import Foreign.Ptr (Ptr) + +data Value = ValueVoid + | ValueInt Int + | ValueDouble Double + | ValueString String + | ValueMatrix (M22 Double) + | ValueCharSet CharSet + | ValueFTFace FT_Face + | ValueLangSet LangSet + | ValueRange Range deriving (Eq, Show, Ord, Generic) + +instance GHashable Value + +------ +--- Low-level +------ + +type Value_ = Ptr Int + +value'Size = sizeof (undefined :: Int) * 2 +pokeUnion ptr x = castPtr (ptr `plusPtr` sizeof (undefined :: Int)) `poke` x + +withValue :: Value -> (Value_ -> IO a) -> IO a +withValue ValueVoid cb = allocaBytes value'Size $ \val' -> do + poke val' 0 + cb val' +withValue (ValueInt x) cb = allocaBytes value'Size $ \val' -> do + poke val' 1 + pokeElemOff val' 1 x + cb val' +withValue (ValueDouble x) cb = allocaBytes value'Size $ \val' -> do + poke val' 2 + pokeUnion val' x + cb val' +withValue (ValueString str) cb = + withCString str $ \str' allocaBytes value'Size $ \val' -> do + poke val' 3 + pokeUnion val' str' + cb val' +withValue (ValueMatrix mat) cb = + withMatrix mat $ \mat' -> allocaBytes value'Size $ \val' -> do + poke val' 4 + pokeUnion val' mat' + cb val' +withValue (ValueCharSet charsets) cb = + withCharSets charsets $ \charsets' -> allocaBytes value'Size $ \val' -> do + poke val' 5 + pokeUnion val' charsets' + cb val' +withValue (ValueFTFace x) cb = allocaBytes value'Size $ \val' -> do + poke val' 6 + pokeUnion val' x + cb val' +withValue (ValueLangSet langset) cb = + withLangSet langset $ \langset' -> allocaBytes value'Size $ \val' -> do + poke val' 7 + pokeUnion val' langset' + cb val' +withValue (ValueRange range) cb = + withRange range $ \range' -> allocaBytes value'Size $ \val' -> do + poke val' 8 + pokeUnion val' range' + cb val' + +mat22Size = sizeof (undefined :: Double) * 4 +withMatrix (V2 (V2 xx yx) (V2 xy yy)) cb = allocaBytes mat22Size $ \mat' -> do + pokeElemOff mat' 0 xx + pokeElemOff mat' 1 xy + pokeElemOff mat' 2 yx + pokeElemOff mat' 3 yy + cb mat' + +thawValue :: Value_ -> IO (Maybe Value) +thawValue ptr = do + kind <- peek ptr + let val' = castPtr (ptr `plusPtr` sizeof (undefined :: Int)) + case kind of + 0 -> return ValueVoid + 1 -> Just <$> ValueInt <$> peek val' + 2 -> Just <$> ValueDouble <$> peek val' + 3 -> Just <$> ValueString <$> peekCString val' + 4 -> do + mat' <- peek val' + xx <- peekElemOff mat' 0 + xy <- peekElemOff mat' 1 + yx <- peekElemOff mat' 2 + yy <- peekElemOff mat' 3 + return $ Just $ ValueMatrix $ V2 (V2 xx yx) (V2 xy yy) + 5 -> Just <$> ValueCharSet <$> thawCharSet val' + 6 -> return $ Just $ ValueFTFace $ val' + 7 -> Just <$> ValueLangSet <$> thawLangSet val' + 8 -> Just <$> ValueRange <$> thawRange val' + _ -> return Nothing diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..1a79030 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2022 Adrian Cochrane + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..65ae4a0 --- /dev/null +++ b/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fontconfig-pure.cabal b/fontconfig-pure.cabal new file mode 100644 index 0000000..27142d3 --- /dev/null +++ b/fontconfig-pure.cabal @@ -0,0 +1,92 @@ +-- Initial fontconfig-pure.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: fontconfig-pure + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- https://wiki.haskell.org/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Pure-functional language bindings to FontConfig + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: https://www.freedesktop.org/wiki/Software/fontconfig/ + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Adrian Cochrane + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: adrian@openwork.nz + +-- A copyright notice. +-- copyright: + +category: Text + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +extra-source-files: CHANGELOG.md + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +library + -- Modules exported by the library. + exposed-modules: Graphics.Text.Font.Choose.Init, + Graphics.Text.Font.Choose.ObjectSet, Graphics.Text.Font.Choose.CharSet, + Graphics.Text.Font.Choose.Strings, Graphics.Text.Font.Choose.Range + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base >=4.12 && <4.13, containers + + -- Directories containing source files. + -- hs-source-dirs: + + -- Base language which the package is written in. + default-language: Haskell2010 + + +executable fontconfig-pure + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base >=4.12 && <4.13 + + -- Directories containing source files. + -- hs-source-dirs: + + -- Base language which the package is written in. + default-language: Haskell2010 + -- 2.30.2