module Graphics.Text.TrueType.FontFolders
( loadUnixFontFolderList
, loadWindowsFontFolderList
, fontFolders
, findFont
, FontCache( .. )
, FontDescriptor( .. )
, buildFontCache
) where
import Control.Applicative( (<$>), (<*>) )
import System.Directory( getDirectoryContents
, doesDirectoryExist
)
import qualified Data.Map 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 = return
["~/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)
newtype FontCache =
FontCache (M.Map FontDescriptor FilePath)
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]
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
f <- loader n
case f of
Nothing -> build rest
Just fo -> ((descriptorOf fo, n) :) <$> 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