module Wumpus.Basic.System.FontLoader.AfmTopLevel
(
loadAfmFontMetrics
, loadAfmFont1
) where
import Wumpus.Basic.Kernel
import Wumpus.Basic.System.FontLoader.AfmV4Dot1Parser
import Wumpus.Basic.System.FontLoader.Datatypes
import Wumpus.Basic.System.FontLoader.FontLoadMonad
import Wumpus.Core
import Control.Monad
import Data.Monoid
loadAfmFontMetrics :: FilePath -> [FontDef] -> IO FontLoadResult
loadAfmFontMetrics font_dir_path ds =
liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ds
where
mkFun = afmLoadFontMetrics font_dir_path
post (Left err,msgs) = let errs = fontLoadMsg err `mappend` msgs
in FontLoadResult mempty errs
post (Right xs,msgs) = let body = foldr fn mempty xs
in FontLoadResult body msgs
fn (name,metrics) table = insertFont name metrics table
loadAfmFont1 :: FilePath -> FontDef -> IO FontLoadResult
loadAfmFont1 font_dir_path font_def =
liftM post $ runFontLoadIO $ afmLoadFontMetrics font_dir_path font_def
where
post (Left err,msgs) = let errs = fontLoadMsg err `mappend` msgs
in FontLoadResult mempty errs
post (Right (a,b),msgs) = let body = insertFont a b mempty
in FontLoadResult body msgs
afmLoadFontMetrics :: FilePath -> FontDef -> FontLoadIO (FontName,FontMetrics)
afmLoadFontMetrics font_dir_path font_def = do
tellLoadMsg $ "Loading " ++ afm_file
path <- checkFontPath font_dir_path afm_file
ans <- runParserFLIO path afmV4Dot1Parser
props <- buildAfmFontProps afm_mono_defaults_4_1 ans
return (name, buildMetricsOps afmValue props)
where
afm_file = afm_file_name font_def
name = ps_font_name $ font_def_face font_def
afm_mono_defaults_4_1 :: MonospaceDefaults AfmUnit
afm_mono_defaults_4_1 =
MonospaceDefaults { default_letter_bbox = bbox
, default_cap_height = 562
, default_descender = (157)
, default_underline_position = (100)
, default_underline_thickness = 50
, default_char_width = V2 600 0
}
where
bbox = BBox (P2 (23) (250)) (P2 715 805)