wumpus-basic-0.16.0: src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Basic.System.FontLoader.Base.FontLoadMonad
-- Copyright : (c) Stephen Tetley 2010
-- License : BSD3
--
-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>
-- Stability : highly unstable
-- Portability : GHC
--
-- Font load monad handling IO (file system access), failure and
-- logging.
--
--------------------------------------------------------------------------------
module Wumpus.Basic.System.FontLoader.Base.FontLoadMonad
(
FontLoadErr
, FontLoadIO
, runFontLoadIO
, evalFontLoadIO
, loadError
, logLoadMsg
, promoteIO
, promoteEither
, runParserFLIO
, sequenceAll
-- * Font loading
, buildAfmFontProps
, checkFontPath
) where
import Wumpus.Basic.System.FontLoader.Base.Datatypes
import Wumpus.Basic.Utils.HList
import Wumpus.Basic.Utils.ParserCombinators
import Wumpus.Core -- package: wumpus-core
import Wumpus.Core.Text.GlyphIndices
import Control.Monad
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import Data.Monoid
import System.Directory
import System.FilePath
--------------------------------------------------------------------------------
-- FontLoadIO monad - IO plus Error
type FontLoadErr = String
newtype FontLoadLog = FontLoadLog { getFontLoadLog :: H String }
instance Monoid FontLoadLog where
mempty = FontLoadLog $ emptyH
a `mappend` b = FontLoadLog $ getFontLoadLog a `appendH` getFontLoadLog b
newtype FontLoadIO a = FontLoadIO {
getFontLoadIO :: IO (Either FontLoadErr a, FontLoadLog ) }
instance Functor FontLoadIO where
fmap f ma = FontLoadIO $ getFontLoadIO ma >>= \(a,w) -> return (fmap f a, w)
instance Monad FontLoadIO where
return a = FontLoadIO $ return (Right a, mempty)
m >>= k = FontLoadIO $ getFontLoadIO m >>= fn
where
fn (Left err, w) = return (Left err, w)
fn (Right a, w1) = getFontLoadIO (k a) >>= \(b,w2) ->
return (b, w1 `mappend` w2)
runFontLoadIO :: FontLoadIO a -> IO (Either FontLoadErr a,[String])
runFontLoadIO ma = liftM post $ getFontLoadIO ma
where
post (ans,w) = (ans, toListH $ getFontLoadLog w)
evalFontLoadIO :: FontLoadIO a -> IO (Either FontLoadErr a)
evalFontLoadIO ma = liftM post $ getFontLoadIO ma
where
post (ans,_) = ans
loadError :: FontLoadErr -> FontLoadIO a
loadError msg = FontLoadIO $ return (Left msg, mempty)
logLoadMsg :: String -> FontLoadIO ()
logLoadMsg msg = FontLoadIO $ return (Right (), message1 msg )
message1 :: String -> FontLoadLog
message1 = FontLoadLog . wrapH
-- | aka liftIO
promoteIO :: IO a -> FontLoadIO a
promoteIO ma = FontLoadIO $ ma >>= \a -> return (Right a, mempty)
promoteEither :: Either FontLoadErr a -> FontLoadIO a
promoteEither = either loadError return
runParserFLIO :: FilePath -> Parser Char a -> FontLoadIO a
runParserFLIO filepath p =
promoteIO (readFile filepath) >>= promoteEither . runParserEither p
-- | The standard monadic @sequence@ would finish on first fail
-- for the FontLoadIO monad. As we want to be able to sequence
-- the loading of a list of fonts, this is not really the
-- behaviour we want for Wumpus. Instead we prefer to use fallback
-- metrics and produce an inaccurate drawing on a font load error
-- rather than fail and produce no drawing.
--
sequenceAll :: [FontLoadIO a] -> FontLoadIO [a]
sequenceAll = FontLoadIO . step
where
step [] = return (Right [], mempty)
step (m:ms) = liftM2 cons (getFontLoadIO m) (step ms)
cons :: (Either FontLoadErr a, FontLoadLog)
-> (Either FontLoadErr [a], FontLoadLog)
-> (Either FontLoadErr [a], FontLoadLog)
cons (Right a, w1) (Right as, w2) =
(Right $ a:as, w1 `mappend` w2)
cons (Right a, w1) (Left e2, w2) =
(Right [a], w1 `mappend` w2 `mappend` message1 e2)
cons (Left e1, w1) (Right as, w2) =
(Right as, w1 `mappend` message1 e1 `mappend` w2)
cons (Left e1, w1) (Left e2, w2) =
(Right [], w1 `mappend` message1 e1 `mappend` w2 `mappend` message1 e2)
--------------------------------------------------------------------------------
-- | Afm files do not have a default advance vec so use the
-- monospace default.
--
-- Afm files hopefully have @CapHeight@ and @FontBBox@ properties
-- in the header. Use the monospace default only if they are
-- missing.
--
buildAfmFontProps :: MonospaceDefaults AfmUnit
-> AfmFile
-> FontLoadIO (FontProps AfmUnit)
buildAfmFontProps defaults afm = do
cap_height <- extractCapHeight defaults afm
desc_depth <- extractDescender defaults afm
bbox <- extractFontBBox defaults afm
return $ FontProps
{ fp_bounding_box = bbox
, fp_default_adv_vec = default_char_width defaults
, fp_adv_vecs = char_widths
, fp_cap_height = cap_height
, fp_descender = desc_depth
}
where
char_widths = foldr fn IntMap.empty $ afm_glyph_metrics afm
fn (AfmGlyphMetrics _ v ss) table = case Map.lookup ss ps_glyph_indices of
Nothing -> table
Just i -> IntMap.insert i v table
extractCapHeight :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit
extractCapHeight defaults afm = maybe errk return $ afm_cap_height afm
where
errk = logLoadMsg "WARNING - Could not extract CapHeight" >>
return (default_cap_height defaults)
extractDescender :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit
extractDescender defaults afm = maybe errk return $ afm_descender afm
where
errk = logLoadMsg "WARNING - Could not extract Descender" >>
return (default_descender defaults)
extractFontBBox :: MonospaceDefaults AfmUnit -> AfmFile
-> FontLoadIO (BoundingBox AfmUnit)
extractFontBBox defaults afm = maybe errk return $ afm_letter_bbox afm
where
errk = logLoadMsg "WARNING - Could not extract CapHeight" >>
return (default_letter_bbox defaults)
checkFontPath :: FilePath -> FilePath -> FontLoadIO FilePath
checkFontPath path_root font_file_name =
let full_path = normalise (path_root </> font_file_name)
in do { check <- promoteIO (doesFileExist full_path)
; if check then return full_path
else loadError $ "Could not resolve path: " ++ full_path
}