module Graphics.Text.TrueType.FontFolders
( loadUnixFontFolderList
, loadWindowsFontFolderList
, fontFolders
, findFont
, FontCache( .. )
, FontDescriptor( .. )
, emptyFontCache
, buildFontCache
, enumerateFonts
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( (<*>), (<$>) )
#endif
import Control.Monad( when, replicateM )
import System.Directory( getDirectoryContents
, getHomeDirectory
, doesDirectoryExist
, doesFileExist
)
import qualified Data.ByteString as B
import Data.Binary( Binary( .. ) )
import Data.Binary.Get( Get
, getWord32be
, getByteString
)
import Data.Binary.Put( Put
, putWord32be
, putByteString )
import qualified Data.Map.Strict as M
import System.Environment( lookupEnv )
import System.FilePath( (</>) )
import qualified Data.Text as T
import Graphics.Text.TrueType.FontType
import Graphics.Text.TrueType.Header
import Graphics.Text.TrueType.Name
loadUnixFontFolderList :: IO [FilePath]
loadUnixFontFolderList =
return ["/usr/share/fonts", "/usr/local/share/fonts", "~/.fonts"]
loadWindowsFontFolderList :: IO [FilePath]
loadWindowsFontFolderList = toFontFolder <$> lookupEnv "Windir"
where toFontFolder (Just a) = [a </> "Fonts"]
toFontFolder Nothing = []
loadOsXFontFolderList :: IO [FilePath]
loadOsXFontFolderList = do
home <- getHomeDirectory
return [home </> "Library" </> "Fonts"
,"/" </> "Library" </> "Fonts"
,"/" </> "System" </> "Library" </> "Fonts"
,"/" </> "System Folder" </> "Fonts"
]
fontFolders :: IO [FilePath]
fontFolders = do
unix <- loadUnixFontFolderList
win <- loadWindowsFontFolderList
osx <- loadOsXFontFolderList
return $ unix ++ win ++ osx
data FontDescriptor = FontDescriptor
{
_descriptorFamilyName :: T.Text
, _descriptorStyle :: FontStyle
}
deriving (Eq, Ord, Show)
instance Binary FontDescriptor where
put (FontDescriptor t s) = put (T.unpack t) >> put s
get = FontDescriptor <$> (T.pack <$> get) <*> get
newtype FontCache =
FontCache (M.Map FontDescriptor FilePath)
deriving Show
emptyFontCache :: FontCache
emptyFontCache = FontCache M.empty
signature :: B.ByteString
signature = "FontyFruity__FONTCACHE:0.5"
putFontCache :: FontCache -> Put
putFontCache (FontCache cache) = do
putByteString signature
putWord32be . fromIntegral $ M.size cache
mapM_ put $ M.toList cache
getFontCache :: Get FontCache
getFontCache = do
str <- getByteString $ B.length signature
when (str /= signature) $
fail "Invalid font cache"
count <- fromIntegral <$> getWord32be
FontCache . M.fromList <$> replicateM count get
instance Binary FontCache where
put = putFontCache
get = getFontCache
enumerateFonts :: FontCache -> [FontDescriptor]
enumerateFonts (FontCache fs) = M.keys fs
buildFontCache :: (FilePath -> IO (Maybe Font)) -> IO FontCache
buildFontCache loader = do
folders <- fontFolders
found <- build [("", v) | v <- folders]
return . FontCache
$ M.fromList [(d, path) | (Just d, path) <- found
, _descriptorFamilyName d /= ""]
where
descriptorOf Font { _fontHeader = Just hdr
, _fontNames = Just names} =
Just $ FontDescriptor (fontFamilyName names)
(_fHdrMacStyle hdr)
descriptorOf _ = Nothing
build [] = return []
build ((".", _):rest) = build rest
build (("..", _):rest) = build rest
build ((_, n):rest) = do
isDirectory <- doesDirectoryExist n
if isDirectory then do
sub <- getDirectoryContents n
(++) <$> build [(s, n </> s) | s <- sub]
<*> build rest
else do
isFile <- doesFileExist n
if isFile then do
f <- loader n
case f of
Nothing -> build rest
Just fo -> ((descriptorOf fo, n) :) <$> build rest
else build rest
findFont :: (FilePath -> IO (Maybe Font)) -> String -> FontStyle
-> IO (Maybe FilePath)
findFont loader fontName fontStyle = do
folders <- fontFolders
searchIn [("", v) | v <- folders]
where
fontNameText = T.pack fontName
isMatching n (Font { _fontHeader = Just hdr
, _fontNames = Just names})
| _fHdrMacStyle hdr == fontStyle &&
fontFamilyName names == fontNameText = Just n
isMatching _ _ = Nothing
searchIn [] = return Nothing
searchIn ((".", _):rest) = searchIn rest
searchIn (("..", _):rest) = searchIn rest
searchIn ((_, n):rest) = do
isDirectory <- doesDirectoryExist n
let findOrRest Nothing = searchIn rest
findOrRest l = return l
if isDirectory then do
sub <- getDirectoryContents n
subRez <- searchIn [(s, n </> s) | s <- sub]
findOrRest subRez
else do
font <- loader n
findOrRest $ font >>= isMatching n