{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TemplateHaskell #-}
module Graphics.PDF.Fonts.AFMParser(
getFont
, AFMFont(..)
, EncodingScheme(..)
, Metric(..)
, KX(..)
, parseFont
) where
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Char8 (unpack)
import Text.ParserCombinators.Parsec hiding(space)
import Text.Parsec(modifyState)
import Text.Parsec.Prim(parserZero)
import Data.Char(toUpper)
import qualified Data.Map.Strict as M
import Graphics.PDF.Fonts.Font(emptyFontStructure)
import Graphics.PDF.LowLevel.Types
import Graphics.PDF.Fonts.Encoding(PostscriptName)
import Graphics.PDF.Fonts.FontTypes
data Metric = Metric { Metric -> Int
charCode :: Int
, Metric -> Int
metricWidth :: Int
, Metric -> String
name :: String
, Metric -> [Double]
bounds :: [Double]
}
deriving(Metric -> Metric -> Bool
(Metric -> Metric -> Bool)
-> (Metric -> Metric -> Bool) -> Eq Metric
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Metric -> Metric -> Bool
$c/= :: Metric -> Metric -> Bool
== :: Metric -> Metric -> Bool
$c== :: Metric -> Metric -> Bool
Eq,Int -> Metric -> ShowS
[Metric] -> ShowS
Metric -> String
(Int -> Metric -> ShowS)
-> (Metric -> String) -> ([Metric] -> ShowS) -> Show Metric
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Metric] -> ShowS
$cshowList :: [Metric] -> ShowS
show :: Metric -> String
$cshow :: Metric -> String
showsPrec :: Int -> Metric -> ShowS
$cshowsPrec :: Int -> Metric -> ShowS
Show)
data EncodingScheme = AFMAdobeStandardEncoding
| AFMFontSpecific
| AFMUnsupportedEncoding
deriving(EncodingScheme -> EncodingScheme -> Bool
(EncodingScheme -> EncodingScheme -> Bool)
-> (EncodingScheme -> EncodingScheme -> Bool) -> Eq EncodingScheme
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EncodingScheme -> EncodingScheme -> Bool
$c/= :: EncodingScheme -> EncodingScheme -> Bool
== :: EncodingScheme -> EncodingScheme -> Bool
$c== :: EncodingScheme -> EncodingScheme -> Bool
Eq,ReadPrec [EncodingScheme]
ReadPrec EncodingScheme
Int -> ReadS EncodingScheme
ReadS [EncodingScheme]
(Int -> ReadS EncodingScheme)
-> ReadS [EncodingScheme]
-> ReadPrec EncodingScheme
-> ReadPrec [EncodingScheme]
-> Read EncodingScheme
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [EncodingScheme]
$creadListPrec :: ReadPrec [EncodingScheme]
readPrec :: ReadPrec EncodingScheme
$creadPrec :: ReadPrec EncodingScheme
readList :: ReadS [EncodingScheme]
$creadList :: ReadS [EncodingScheme]
readsPrec :: Int -> ReadS EncodingScheme
$creadsPrec :: Int -> ReadS EncodingScheme
Read,Int -> EncodingScheme -> ShowS
[EncodingScheme] -> ShowS
EncodingScheme -> String
(Int -> EncodingScheme -> ShowS)
-> (EncodingScheme -> String)
-> ([EncodingScheme] -> ShowS)
-> Show EncodingScheme
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EncodingScheme] -> ShowS
$cshowList :: [EncodingScheme] -> ShowS
show :: EncodingScheme -> String
$cshow :: EncodingScheme -> String
showsPrec :: Int -> EncodingScheme -> ShowS
$cshowsPrec :: Int -> EncodingScheme -> ShowS
Show)
data KX = KX String String Int
deriving(KX -> KX -> Bool
(KX -> KX -> Bool) -> (KX -> KX -> Bool) -> Eq KX
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KX -> KX -> Bool
$c/= :: KX -> KX -> Bool
== :: KX -> KX -> Bool
$c== :: KX -> KX -> Bool
Eq,Eq KX
Eq KX
-> (KX -> KX -> Ordering)
-> (KX -> KX -> Bool)
-> (KX -> KX -> Bool)
-> (KX -> KX -> Bool)
-> (KX -> KX -> Bool)
-> (KX -> KX -> KX)
-> (KX -> KX -> KX)
-> Ord KX
KX -> KX -> Bool
KX -> KX -> Ordering
KX -> KX -> KX
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: KX -> KX -> KX
$cmin :: KX -> KX -> KX
max :: KX -> KX -> KX
$cmax :: KX -> KX -> KX
>= :: KX -> KX -> Bool
$c>= :: KX -> KX -> Bool
> :: KX -> KX -> Bool
$c> :: KX -> KX -> Bool
<= :: KX -> KX -> Bool
$c<= :: KX -> KX -> Bool
< :: KX -> KX -> Bool
$c< :: KX -> KX -> Bool
compare :: KX -> KX -> Ordering
$ccompare :: KX -> KX -> Ordering
$cp1Ord :: Eq KX
Ord,Int -> KX -> ShowS
[KX] -> ShowS
KX -> String
(Int -> KX -> ShowS)
-> (KX -> String) -> ([KX] -> ShowS) -> Show KX
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KX] -> ShowS
$cshowList :: [KX] -> ShowS
show :: KX -> String
$cshow :: KX -> String
showsPrec :: Int -> KX -> ShowS
$cshowsPrec :: Int -> KX -> ShowS
Show)
data AFMFont = AFMFont { AFMFont -> [Metric]
metrics :: [Metric]
, AFMFont -> Int
underlinePosition :: Int
, AFMFont -> Int
underlineThickness :: Int
, AFMFont -> Int
afmAscent :: Int
, AFMFont -> Int
afmDescent :: Int
, AFMFont -> Maybe [KX]
kernData :: Maybe [KX]
, AFMFont -> String
type1BaseFont :: String
, AFMFont -> EncodingScheme
encodingScheme :: EncodingScheme
, AFMFont -> Double
afmItalic :: Double
, AFMFont -> Int
afmCapHeight :: Int
, AFMFont -> [Double]
afmBBox :: [Double]
, AFMFont -> Bool
afmFixedPitch :: Bool
, AFMFont -> Bool
afmSymbolic :: Bool
}
deriving(AFMFont -> AFMFont -> Bool
(AFMFont -> AFMFont -> Bool)
-> (AFMFont -> AFMFont -> Bool) -> Eq AFMFont
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AFMFont -> AFMFont -> Bool
$c/= :: AFMFont -> AFMFont -> Bool
== :: AFMFont -> AFMFont -> Bool
$c== :: AFMFont -> AFMFont -> Bool
Eq,Int -> AFMFont -> ShowS
[AFMFont] -> ShowS
AFMFont -> String
(Int -> AFMFont -> ShowS)
-> (AFMFont -> String) -> ([AFMFont] -> ShowS) -> Show AFMFont
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AFMFont] -> ShowS
$cshowList :: [AFMFont] -> ShowS
show :: AFMFont -> String
$cshow :: AFMFont -> String
showsPrec :: Int -> AFMFont -> ShowS
$cshowsPrec :: Int -> AFMFont -> ShowS
Show)
type AFMParser = GenParser Char AFMFont
emptyAFM :: AFMFont
emptyAFM :: AFMFont
emptyAFM = AFMFont :: [Metric]
-> Int
-> Int
-> Int
-> Int
-> Maybe [KX]
-> String
-> EncodingScheme
-> Double
-> Int
-> [Double]
-> Bool
-> Bool
-> AFMFont
AFMFont { metrics :: [Metric]
metrics = []
, underlinePosition :: Int
underlinePosition = Int
0
, underlineThickness :: Int
underlineThickness = Int
0
, afmAscent :: Int
afmAscent = Int
0
, afmDescent :: Int
afmDescent = Int
0
, kernData :: Maybe [KX]
kernData = Maybe [KX]
forall a. Maybe a
Nothing
, type1BaseFont :: String
type1BaseFont = String
""
, encodingScheme :: EncodingScheme
encodingScheme = EncodingScheme
AFMAdobeStandardEncoding
, afmItalic :: Double
afmItalic = Double
0.0
, afmCapHeight :: Int
afmCapHeight = Int
0
, afmBBox :: [Double]
afmBBox = []
, afmFixedPitch :: Bool
afmFixedPitch = Bool
False
, afmSymbolic :: Bool
afmSymbolic = Bool
False
}
capitalize :: String -> String
capitalize :: ShowS
capitalize [] = []
capitalize (Char
h:String
t) = Char -> Char
toUpper Char
h Char -> ShowS
forall a. a -> [a] -> [a]
: String
t
line :: AFMParser ()
line :: AFMParser ()
line = do String
_ <- String -> ParsecT String AFMFont Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\r\n" ParsecT String AFMFont Identity String
-> ParsecT String AFMFont Identity String
-> ParsecT String AFMFont Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String AFMFont Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\n"
() -> AFMParser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
toEndOfLine :: AFMParser ()
toEndOfLine :: AFMParser ()
toEndOfLine = do String
_ <- ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\r\n")
AFMParser ()
line
() -> AFMParser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
getString :: AFMParser String
getString :: ParsecT String AFMFont Identity String
getString = do
String
c <- ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-+")
AFMParser ()
line
String -> ParsecT String AFMFont Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return String
c
getInt :: AFMParser Int
getInt :: AFMParser Int
getInt = String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT String AFMFont Identity String -> AFMParser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String AFMFont Identity String
getString
getFloat :: AFMParser Double
getFloat :: AFMParser Double
getFloat = do
String
c <- ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
".-+")
AFMParser ()
line
Double -> AFMParser Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> AFMParser Double) -> Double -> AFMParser Double
forall a b. (a -> b) -> a -> b
$ String -> Double
forall a. Read a => String -> a
read String
c
getBool :: AFMParser Bool
getBool :: AFMParser Bool
getBool = String -> Bool
forall a. Read a => String -> a
read (String -> Bool) -> ShowS -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
capitalize (String -> Bool)
-> ParsecT String AFMFont Identity String -> AFMParser Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String AFMFont Identity String
getString
data CharacterSet = ExtendedRoman
| Special
deriving(CharacterSet -> CharacterSet -> Bool
(CharacterSet -> CharacterSet -> Bool)
-> (CharacterSet -> CharacterSet -> Bool) -> Eq CharacterSet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CharacterSet -> CharacterSet -> Bool
$c/= :: CharacterSet -> CharacterSet -> Bool
== :: CharacterSet -> CharacterSet -> Bool
$c== :: CharacterSet -> CharacterSet -> Bool
Eq,ReadPrec [CharacterSet]
ReadPrec CharacterSet
Int -> ReadS CharacterSet
ReadS [CharacterSet]
(Int -> ReadS CharacterSet)
-> ReadS [CharacterSet]
-> ReadPrec CharacterSet
-> ReadPrec [CharacterSet]
-> Read CharacterSet
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CharacterSet]
$creadListPrec :: ReadPrec [CharacterSet]
readPrec :: ReadPrec CharacterSet
$creadPrec :: ReadPrec CharacterSet
readList :: ReadS [CharacterSet]
$creadList :: ReadS [CharacterSet]
readsPrec :: Int -> ReadS CharacterSet
$creadsPrec :: Int -> ReadS CharacterSet
Read,Int -> CharacterSet -> ShowS
[CharacterSet] -> ShowS
CharacterSet -> String
(Int -> CharacterSet -> ShowS)
-> (CharacterSet -> String)
-> ([CharacterSet] -> ShowS)
-> Show CharacterSet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CharacterSet] -> ShowS
$cshowList :: [CharacterSet] -> ShowS
show :: CharacterSet -> String
$cshow :: CharacterSet -> String
showsPrec :: Int -> CharacterSet -> ShowS
$cshowsPrec :: Int -> CharacterSet -> ShowS
Show)
data Weight = Medium
| Bold
| Roman
deriving(Weight -> Weight -> Bool
(Weight -> Weight -> Bool)
-> (Weight -> Weight -> Bool) -> Eq Weight
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Weight -> Weight -> Bool
$c/= :: Weight -> Weight -> Bool
== :: Weight -> Weight -> Bool
$c== :: Weight -> Weight -> Bool
Eq,ReadPrec [Weight]
ReadPrec Weight
Int -> ReadS Weight
ReadS [Weight]
(Int -> ReadS Weight)
-> ReadS [Weight]
-> ReadPrec Weight
-> ReadPrec [Weight]
-> Read Weight
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Weight]
$creadListPrec :: ReadPrec [Weight]
readPrec :: ReadPrec Weight
$creadPrec :: ReadPrec Weight
readList :: ReadS [Weight]
$creadList :: ReadS [Weight]
readsPrec :: Int -> ReadS Weight
$creadsPrec :: Int -> ReadS Weight
Read,Int -> Weight -> ShowS
[Weight] -> ShowS
Weight -> String
(Int -> Weight -> ShowS)
-> (Weight -> String) -> ([Weight] -> ShowS) -> Show Weight
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Weight] -> ShowS
$cshowList :: [Weight] -> ShowS
show :: Weight -> String
$cshow :: Weight -> String
showsPrec :: Int -> Weight -> ShowS
$cshowsPrec :: Int -> Weight -> ShowS
Show)
array :: AFMParser [String]
array :: AFMParser [String]
array = ParsecT String AFMFont Identity String
-> ParsecT String AFMFont Identity String -> AFMParser [String]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepEndBy (ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-+0123456789")) (ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
" "))
getArray :: AFMParser [Double]
getArray :: AFMParser [Double]
getArray = do [String]
c <- AFMParser [String]
array
AFMParser ()
line
[Double] -> AFMParser [Double]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Double] -> AFMParser [Double])
-> ([String] -> [Double]) -> [String] -> AFMParser [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Double) -> [String] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map String -> Double
forall a. Read a => String -> a
read ([String] -> AFMParser [Double]) -> [String] -> AFMParser [Double]
forall a b. (a -> b) -> a -> b
$ [String]
c
getEncoding :: AFMParser EncodingScheme
getEncoding :: AFMParser EncodingScheme
getEncoding = do
String
c <- ParsecT String AFMFont Identity String
getString
case String
c of
String
"AdobeStandardEncoding" -> EncodingScheme -> AFMParser EncodingScheme
forall (m :: * -> *) a. Monad m => a -> m a
return EncodingScheme
AFMAdobeStandardEncoding
String
"FontSpecific" -> EncodingScheme -> AFMParser EncodingScheme
forall (m :: * -> *) a. Monad m => a -> m a
return EncodingScheme
AFMFontSpecific
String
_ -> EncodingScheme -> AFMParser EncodingScheme
forall (m :: * -> *) a. Monad m => a -> m a
return EncodingScheme
AFMUnsupportedEncoding
number :: AFMParser Int
number :: AFMParser Int
number = do String
c <- ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-+0123456789")
Int -> AFMParser Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> AFMParser Int) -> Int -> AFMParser Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read String
c
data Elem = C Int
| WX Int
| N String
| B [Double]
| L
deriving(Elem -> Elem -> Bool
(Elem -> Elem -> Bool) -> (Elem -> Elem -> Bool) -> Eq Elem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Elem -> Elem -> Bool
$c/= :: Elem -> Elem -> Bool
== :: Elem -> Elem -> Bool
$c== :: Elem -> Elem -> Bool
Eq,ReadPrec [Elem]
ReadPrec Elem
Int -> ReadS Elem
ReadS [Elem]
(Int -> ReadS Elem)
-> ReadS [Elem] -> ReadPrec Elem -> ReadPrec [Elem] -> Read Elem
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Elem]
$creadListPrec :: ReadPrec [Elem]
readPrec :: ReadPrec Elem
$creadPrec :: ReadPrec Elem
readList :: ReadS [Elem]
$creadList :: ReadS [Elem]
readsPrec :: Int -> ReadS Elem
$creadsPrec :: Int -> ReadS Elem
Read,Int -> Elem -> ShowS
[Elem] -> ShowS
Elem -> String
(Int -> Elem -> ShowS)
-> (Elem -> String) -> ([Elem] -> ShowS) -> Show Elem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Elem] -> ShowS
$cshowList :: [Elem] -> ShowS
show :: Elem -> String
$cshow :: Elem -> String
showsPrec :: Int -> Elem -> ShowS
$cshowsPrec :: Int -> Elem -> ShowS
Show)
metricElem :: AFMParser Elem
metricElem :: AFMParser Elem
metricElem = do Char
_ <- Char -> ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'C'
AFMParser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
Int -> Elem
C (Int -> Elem) -> AFMParser Int -> AFMParser Elem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AFMParser Int
number
AFMParser Elem -> AFMParser Elem -> AFMParser Elem
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
do String
_ <- String -> ParsecT String AFMFont Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"WX"
AFMParser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
Int -> Elem
WX (Int -> Elem) -> AFMParser Int -> AFMParser Elem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AFMParser Int
number
AFMParser Elem -> AFMParser Elem -> AFMParser Elem
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
do Char
_ <- Char -> ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'N'
AFMParser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
String
c <- ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.')
Elem -> AFMParser Elem
forall (m :: * -> *) a. Monad m => a -> m a
return (Elem -> AFMParser Elem) -> Elem -> AFMParser Elem
forall a b. (a -> b) -> a -> b
$ String -> Elem
N String
c
AFMParser Elem -> AFMParser Elem -> AFMParser Elem
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
do Char
_ <- Char -> ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'B'
AFMParser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
[String]
c <- AFMParser [String]
array
Elem -> AFMParser Elem
forall (m :: * -> *) a. Monad m => a -> m a
return (Elem -> AFMParser Elem)
-> ([String] -> Elem) -> [String] -> AFMParser Elem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Double] -> Elem
B ([Double] -> Elem) -> ([String] -> [Double]) -> [String] -> Elem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Double) -> [String] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map String -> Double
forall a. Read a => String -> a
read ([String] -> AFMParser Elem) -> [String] -> AFMParser Elem
forall a b. (a -> b) -> a -> b
$ [String]
c
AFMParser Elem -> AFMParser Elem -> AFMParser Elem
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
do Char
_ <- Char -> ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'L'
AFMParser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
String
_ <- ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter
AFMParser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
String
_ <- ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter
Elem -> AFMParser Elem
forall (m :: * -> *) a. Monad m => a -> m a
return Elem
L
mkMetric :: [Elem] -> Metric
mkMetric :: [Elem] -> Metric
mkMetric = (Elem -> Metric -> Metric) -> Metric -> [Elem] -> Metric
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Elem -> Metric -> Metric
addElem (Int -> Int -> String -> [Double] -> Metric
Metric (-Int
1) Int
0 String
"" [])
where
addElem :: Elem -> Metric -> Metric
addElem (C Int
c) Metric
m = Metric
m {charCode :: Int
charCode=Int
c}
addElem (WX Int
c) Metric
m = Metric
m {metricWidth :: Int
metricWidth=Int
c}
addElem (N String
s) Metric
m = Metric
m {name :: String
name=String
s}
addElem (B [Double]
l) Metric
m = Metric
m {bounds :: [Double]
bounds=[Double]
l}
addElem Elem
_ Metric
m = Metric
m
charMetric :: AFMParser Metric
charMetric :: AFMParser Metric
charMetric = do
[Elem]
l <- AFMParser Elem
-> ParsecT String AFMFont Identity String
-> ParsecT String AFMFont Identity [Elem]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepEndBy AFMParser Elem
metricElem (ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"; "))
AFMParser ()
line
Metric -> AFMParser Metric
forall (m :: * -> *) a. Monad m => a -> m a
return (Metric -> AFMParser Metric)
-> ([Elem] -> Metric) -> [Elem] -> AFMParser Metric
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Elem] -> Metric
mkMetric ([Elem] -> AFMParser Metric) -> [Elem] -> AFMParser Metric
forall a b. (a -> b) -> a -> b
$ [Elem]
l
kernPair :: AFMParser KX
kernPair :: AFMParser KX
kernPair = do String
_ <- String -> ParsecT String AFMFont Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"KPX"
AFMParser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
String
namea <- ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum
AFMParser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
String
nameb <- ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum
AFMParser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
String
nb <- ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-+0123456789")
AFMParser ()
line
KX -> AFMParser KX
forall (m :: * -> *) a. Monad m => a -> m a
return (KX -> AFMParser KX) -> KX -> AFMParser KX
forall a b. (a -> b) -> a -> b
$ String -> String -> Int -> KX
KX String
namea String
nameb (String -> Int
forall a. Read a => String -> a
read String
nb)
keyword :: String -> AFMParser () -> AFMParser ()
keyword :: String -> AFMParser () -> AFMParser ()
keyword String
s AFMParser ()
action = do
String
_ <- String -> ParsecT String AFMFont Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
s
AFMParser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
AFMParser ()
action
() -> AFMParser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
header :: String -> AFMParser ()
String
s = do
String
_ <- String -> ParsecT String AFMFont Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
s
AFMParser ()
toEndOfLine
() -> AFMParser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
notHeader :: String -> AFMParser ()
String
s = do
String
r <- ParsecT String AFMFont Identity Char
-> ParsecT String AFMFont Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String AFMFont Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum
if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
r
then
AFMParser ()
forall s u (m :: * -> *) a. ParsecT s u m a
parserZero
else do
AFMParser ()
toEndOfLine
specific :: AFMParser ()
specific :: AFMParser ()
specific = [AFMParser ()] -> AFMParser ()
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ AFMParser () -> AFMParser ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (AFMParser () -> AFMParser ()) -> AFMParser () -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ String -> AFMParser () -> AFMParser ()
keyword String
"FontName" (ParsecT String AFMFont Identity String
getString ParsecT String AFMFont Identity String
-> (String -> AFMParser ()) -> AFMParser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
name' -> (AFMFont -> AFMFont) -> AFMParser ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((AFMFont -> AFMFont) -> AFMParser ())
-> (AFMFont -> AFMFont) -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {type1BaseFont :: String
type1BaseFont = String
name'})
, AFMParser () -> AFMParser ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (AFMParser () -> AFMParser ()) -> AFMParser () -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ String -> AFMParser () -> AFMParser ()
keyword String
"UnderlinePosition" (AFMParser Int
getInt AFMParser Int -> (Int -> AFMParser ()) -> AFMParser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
name' -> (AFMFont -> AFMFont) -> AFMParser ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((AFMFont -> AFMFont) -> AFMParser ())
-> (AFMFont -> AFMFont) -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {underlinePosition :: Int
underlinePosition = Int
name'})
, AFMParser () -> AFMParser ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (AFMParser () -> AFMParser ()) -> AFMParser () -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ String -> AFMParser () -> AFMParser ()
keyword String
"UnderlineThickness" (AFMParser Int
getInt AFMParser Int -> (Int -> AFMParser ()) -> AFMParser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
name' -> (AFMFont -> AFMFont) -> AFMParser ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((AFMFont -> AFMFont) -> AFMParser ())
-> (AFMFont -> AFMFont) -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {underlineThickness :: Int
underlineThickness = Int
name'})
, AFMParser () -> AFMParser ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (AFMParser () -> AFMParser ()) -> AFMParser () -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ String -> AFMParser () -> AFMParser ()
keyword String
"EncodingScheme" (AFMParser EncodingScheme
getEncoding AFMParser EncodingScheme
-> (EncodingScheme -> AFMParser ()) -> AFMParser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \EncodingScheme
name' -> (AFMFont -> AFMFont) -> AFMParser ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((AFMFont -> AFMFont) -> AFMParser ())
-> (AFMFont -> AFMFont) -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {encodingScheme :: EncodingScheme
encodingScheme = EncodingScheme
name'})
, AFMParser () -> AFMParser ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (AFMParser () -> AFMParser ()) -> AFMParser () -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ String -> AFMParser () -> AFMParser ()
keyword String
"CapHeight" (AFMParser Int
getInt AFMParser Int -> (Int -> AFMParser ()) -> AFMParser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
name' -> (AFMFont -> AFMFont) -> AFMParser ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((AFMFont -> AFMFont) -> AFMParser ())
-> (AFMFont -> AFMFont) -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {afmCapHeight :: Int
afmCapHeight = Int
name'})
, AFMParser () -> AFMParser ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (AFMParser () -> AFMParser ()) -> AFMParser () -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ String -> AFMParser () -> AFMParser ()
keyword String
"Ascender" (AFMParser Int
getInt AFMParser Int -> (Int -> AFMParser ()) -> AFMParser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
name' -> (AFMFont -> AFMFont) -> AFMParser ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((AFMFont -> AFMFont) -> AFMParser ())
-> (AFMFont -> AFMFont) -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {afmAscent :: Int
afmAscent = Int
name'})
, AFMParser () -> AFMParser ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (AFMParser () -> AFMParser ()) -> AFMParser () -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ String -> AFMParser () -> AFMParser ()
keyword String
"Descender" (AFMParser Int
getInt AFMParser Int -> (Int -> AFMParser ()) -> AFMParser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
name' -> (AFMFont -> AFMFont) -> AFMParser ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((AFMFont -> AFMFont) -> AFMParser ())
-> (AFMFont -> AFMFont) -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {afmDescent :: Int
afmDescent = Int
name'})
, AFMParser () -> AFMParser ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (AFMParser () -> AFMParser ()) -> AFMParser () -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ String -> AFMParser () -> AFMParser ()
keyword String
"ItalicAngle" (AFMParser Double
getFloat AFMParser Double -> (Double -> AFMParser ()) -> AFMParser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Double
name' -> (AFMFont -> AFMFont) -> AFMParser ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((AFMFont -> AFMFont) -> AFMParser ())
-> (AFMFont -> AFMFont) -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {afmItalic :: Double
afmItalic = Double
name'})
, AFMParser () -> AFMParser ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (AFMParser () -> AFMParser ()) -> AFMParser () -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ String -> AFMParser () -> AFMParser ()
keyword String
"IsFixedPitch" (AFMParser Bool
getBool AFMParser Bool -> (Bool -> AFMParser ()) -> AFMParser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
name' -> (AFMFont -> AFMFont) -> AFMParser ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((AFMFont -> AFMFont) -> AFMParser ())
-> (AFMFont -> AFMFont) -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {afmFixedPitch :: Bool
afmFixedPitch = Bool
name'})
, AFMParser () -> AFMParser ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (AFMParser () -> AFMParser ()) -> AFMParser () -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ String -> AFMParser () -> AFMParser ()
keyword String
"FontBBox" (AFMParser [Double]
getArray AFMParser [Double] -> ([Double] -> AFMParser ()) -> AFMParser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Double]
name' -> (AFMFont -> AFMFont) -> AFMParser ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((AFMFont -> AFMFont) -> AFMParser ())
-> (AFMFont -> AFMFont) -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {afmBBox :: [Double]
afmBBox = [Double]
name'})
, AFMParser () -> AFMParser ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (AFMParser () -> AFMParser ()) -> AFMParser () -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ String -> AFMParser ()
notHeader String
"StartCharMetrics"
]
getKernData :: AFMParser (Maybe [KX])
getKernData :: AFMParser (Maybe [KX])
getKernData = do
{ String -> AFMParser ()
header String
"StartKernData"
; String -> AFMParser ()
header String
"StartKernPairs"
; [KX]
k <- AFMParser KX -> ParsecT String AFMFont Identity [KX]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 AFMParser KX
kernPair
; String -> AFMParser ()
header String
"EndKernPairs"
; String -> AFMParser ()
header String
"EndKernData"
; Maybe [KX] -> AFMParser (Maybe [KX])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [KX] -> AFMParser (Maybe [KX]))
-> Maybe [KX] -> AFMParser (Maybe [KX])
forall a b. (a -> b) -> a -> b
$ [KX] -> Maybe [KX]
forall a. a -> Maybe a
Just [KX]
k
}
afm :: AFMParser AFMFont
afm :: AFMParser AFMFont
afm =
do
String -> AFMParser ()
header String
"StartFontMetrics"
[()]
_ <- AFMParser () -> ParsecT String AFMFont Identity [()]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 AFMParser ()
specific
String -> AFMParser ()
header String
"StartCharMetrics"
[Metric]
charMetrics <- AFMParser Metric -> ParsecT String AFMFont Identity [Metric]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 AFMParser Metric
charMetric
String -> AFMParser ()
header String
"EndCharMetrics"
Maybe [KX]
kerns <- Maybe [KX] -> AFMParser (Maybe [KX]) -> AFMParser (Maybe [KX])
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Maybe [KX]
forall a. Maybe a
Nothing AFMParser (Maybe [KX])
getKernData
String
_ <- String -> ParsecT String AFMFont Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"EndFontMetrics"
(AFMFont -> AFMFont) -> AFMParser ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((AFMFont -> AFMFont) -> AFMParser ())
-> (AFMFont -> AFMFont) -> AFMParser ()
forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' { metrics :: [Metric]
metrics = [Metric]
charMetrics
, kernData :: Maybe [KX]
kernData = Maybe [KX]
kerns
}
AFMFont
afm' <- AFMParser AFMFont
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
let [Double
_,Double
ymin,Double
_,Double
ymax] = AFMFont -> [Double]
afmBBox AFMFont
afm'
if AFMFont -> Int
afmAscent AFMFont
afm' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then
if AFMFont -> Int
afmCapHeight AFMFont
afm' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
then
AFMFont -> AFMParser AFMFont
forall (m :: * -> *) a. Monad m => a -> m a
return (AFMFont -> AFMParser AFMFont) -> AFMFont -> AFMParser AFMFont
forall a b. (a -> b) -> a -> b
$ AFMFont
afm' { afmAscent :: Int
afmAscent = AFMFont -> Int
afmCapHeight AFMFont
afm'
}
else
let h :: Int
h = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
ymax Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
ymin) in
AFMFont -> AFMParser AFMFont
forall (m :: * -> *) a. Monad m => a -> m a
return (AFMFont -> AFMParser AFMFont) -> AFMFont -> AFMParser AFMFont
forall a b. (a -> b) -> a -> b
$ AFMFont
afm' { afmAscent :: Int
afmAscent = Int
h
, afmDescent :: Int
afmDescent = Int
0
}
else
AFMFont -> AFMParser AFMFont
forall (m :: * -> *) a. Monad m => a -> m a
return (AFMFont -> AFMParser AFMFont) -> AFMFont -> AFMParser AFMFont
forall a b. (a -> b) -> a -> b
$ AFMFont
afm'
addMetric :: M.Map PostscriptName GlyphCode -> Metric -> FontStructure -> FontStructure
addMetric :: Map String GlyphCode -> Metric -> FontStructure -> FontStructure
addMetric Map String GlyphCode
nameToGlyph Metric
m FontStructure
fs =
let c :: Maybe GlyphCode
c = String -> Map String GlyphCode -> Maybe GlyphCode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Metric -> String
name Metric
m) Map String GlyphCode
nameToGlyph
fs' :: FontStructure
fs' = case Maybe GlyphCode
c of
Just GlyphCode
glyphCode ->
FontStructure
fs { widthData :: Map GlyphCode GlyphSize
widthData = GlyphCode
-> GlyphSize -> Map GlyphCode GlyphSize -> Map GlyphCode GlyphSize
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (GlyphCode -> GlyphCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral GlyphCode
glyphCode) (Int -> GlyphSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GlyphSize) -> Int -> GlyphSize
forall a b. (a -> b) -> a -> b
$ Metric -> Int
metricWidth Metric
m) (FontStructure -> Map GlyphCode GlyphSize
widthData FontStructure
fs)}
Maybe GlyphCode
Nothing -> FontStructure
fs
in
case (Metric -> String
name Metric
m) of
String
"space" -> FontStructure
fs' {space :: GlyphCode
space = Int -> GlyphCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GlyphCode) -> Int -> GlyphCode
forall a b. (a -> b) -> a -> b
$ Metric -> Int
charCode Metric
m}
String
"hyphen" -> FontStructure
fs' {hyphen :: Maybe GlyphCode
hyphen = GlyphCode -> Maybe GlyphCode
forall a. a -> Maybe a
Just (Int -> GlyphCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GlyphCode) -> Int -> GlyphCode
forall a b. (a -> b) -> a -> b
$ Metric -> Int
charCode Metric
m)}
String
_ -> FontStructure
fs'
addKern :: M.Map String GlyphCode -> KX -> FontStructure -> FontStructure
addKern :: Map String GlyphCode -> KX -> FontStructure -> FontStructure
addKern Map String GlyphCode
d (KX String
sa String
sb Int
c) FontStructure
fs =
let caM :: Maybe GlyphCode
caM = String -> Map String GlyphCode -> Maybe GlyphCode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
sa Map String GlyphCode
d
cbM :: Maybe GlyphCode
cbM = String -> Map String GlyphCode -> Maybe GlyphCode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
sb Map String GlyphCode
d
in
case (Maybe GlyphCode
caM,Maybe GlyphCode
cbM) of
(Just GlyphCode
ca, Just GlyphCode
cb) -> FontStructure
fs {kernMetrics :: Map GlyphPair GlyphSize
kernMetrics = GlyphPair
-> GlyphSize -> Map GlyphPair GlyphSize -> Map GlyphPair GlyphSize
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (GlyphCode -> GlyphCode -> GlyphPair
GlyphPair GlyphCode
ca GlyphCode
cb) (Int -> GlyphSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c) (FontStructure -> Map GlyphPair GlyphSize
kernMetrics FontStructure
fs)}
(Maybe GlyphCode, Maybe GlyphCode)
_ -> FontStructure
fs
fontToStructure :: AFMFont
-> M.Map PostscriptName Char
-> Maybe (M.Map PostscriptName GlyphCode)
-> FontStructure
fontToStructure :: AFMFont
-> Map String Char -> Maybe (Map String GlyphCode) -> FontStructure
fontToStructure AFMFont
afm' Map String Char
encoding' Maybe (Map String GlyphCode)
maybeMapNameToGlyph =
let h :: Int
h = (AFMFont -> Int
afmAscent AFMFont
afm' Int -> Int -> Int
forall a. Num a => a -> a -> a
- AFMFont -> Int
afmDescent AFMFont
afm')
fs :: FontStructure
fs = FontStructure
emptyFontStructure { descent :: GlyphSize
descent = Int -> GlyphSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GlyphSize) -> Int -> GlyphSize
forall a b. (a -> b) -> a -> b
$ - (AFMFont -> Int
afmDescent AFMFont
afm')
, height :: GlyphSize
height = Int -> GlyphSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GlyphSize) -> Int -> GlyphSize
forall a b. (a -> b) -> a -> b
$ Int
h
, ascent :: GlyphSize
ascent = Int -> GlyphSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GlyphSize) -> Int -> GlyphSize
forall a b. (a -> b) -> a -> b
$ AFMFont -> Int
afmAscent AFMFont
afm'
, fontBBox :: [Double]
fontBBox = AFMFont -> [Double]
afmBBox AFMFont
afm'
, italicAngle :: Double
italicAngle = AFMFont -> Double
afmItalic AFMFont
afm'
, capHeight :: GlyphSize
capHeight = Int -> GlyphSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GlyphSize) -> Int -> GlyphSize
forall a b. (a -> b) -> a -> b
$ AFMFont -> Int
afmCapHeight AFMFont
afm'
, fixedPitch :: Bool
fixedPitch = AFMFont -> Bool
afmFixedPitch AFMFont
afm'
, serif :: Bool
serif = Bool
False
, symbolic :: Bool
symbolic = AFMFont -> Bool
afmSymbolic AFMFont
afm'
, script :: Bool
script = Bool
False
, nonSymbolic :: Bool
nonSymbolic = Bool -> Bool
not (AFMFont -> Bool
afmSymbolic AFMFont
afm')
, italic :: Bool
italic = Bool
False
, allCap :: Bool
allCap = Bool
False
, smallCap :: Bool
smallCap = Bool
False
, forceBold :: Bool
forceBold = Bool
False
, baseFont :: String
baseFont = AFMFont -> String
type1BaseFont AFMFont
afm'
}
addName :: Metric -> Map String a -> Map String a
addName Metric
m Map String a
d | Metric -> Int
charCode Metric
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 = Map String a
d
| Bool
otherwise = String -> a -> Map String a -> Map String a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Metric -> String
name Metric
m) (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ Metric -> Int
charCode Metric
m) Map String a
d
nameToGlyph :: Map String GlyphCode
nameToGlyph = Map String GlyphCode
-> (Map String GlyphCode -> Map String GlyphCode)
-> Maybe (Map String GlyphCode)
-> Map String GlyphCode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Metric -> Map String GlyphCode -> Map String GlyphCode)
-> Map String GlyphCode -> [Metric] -> Map String GlyphCode
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Metric -> Map String GlyphCode -> Map String GlyphCode
forall a. Num a => Metric -> Map String a -> Map String a
addName Map String GlyphCode
forall k a. Map k a
M.empty (AFMFont -> [Metric]
metrics AFMFont
afm')) Map String GlyphCode -> Map String GlyphCode
forall a. a -> a
id Maybe (Map String GlyphCode)
maybeMapNameToGlyph
fs1 :: FontStructure
fs1 = (Metric -> FontStructure -> FontStructure)
-> FontStructure -> [Metric] -> FontStructure
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Map String GlyphCode -> Metric -> FontStructure -> FontStructure
addMetric Map String GlyphCode
nameToGlyph) FontStructure
fs (AFMFont -> [Metric]
metrics AFMFont
afm')
addEncodingMapping :: (String, a) -> Map Char a -> Map Char a
addEncodingMapping (String
pname,a
glyphcode) Map Char a
d =
let unicodeM :: Maybe Char
unicodeM = String -> Map String Char -> Maybe Char
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
pname Map String Char
encoding'
in
case Maybe Char
unicodeM of
Maybe Char
Nothing -> Map Char a
d
Just Char
code -> Char -> a -> Map Char a -> Map Char a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Char
code a
glyphcode Map Char a
d
mapping :: Map Char GlyphCode
mapping = ((String, GlyphCode) -> Map Char GlyphCode -> Map Char GlyphCode)
-> Map Char GlyphCode
-> [(String, GlyphCode)]
-> Map Char GlyphCode
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, GlyphCode) -> Map Char GlyphCode -> Map Char GlyphCode
forall a. (String, a) -> Map Char a -> Map Char a
addEncodingMapping Map Char GlyphCode
forall k a. Map k a
M.empty (Map String GlyphCode -> [(String, GlyphCode)]
forall k a. Map k a -> [(k, a)]
M.toList Map String GlyphCode
nameToGlyph)
fs2 :: FontStructure
fs2 = FontStructure
fs1 { encoding :: Map Char GlyphCode
encoding = Map Char GlyphCode
mapping}
in
case AFMFont -> Maybe [KX]
kernData AFMFont
afm' of
Maybe [KX]
Nothing -> FontStructure
fs2
Just [KX]
k -> (KX -> FontStructure -> FontStructure)
-> FontStructure -> [KX] -> FontStructure
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Map String GlyphCode -> KX -> FontStructure -> FontStructure
addKern Map String GlyphCode
nameToGlyph) FontStructure
fs2 [KX]
k
afmParseFromFile :: AFMParser AFMFont -> FilePath -> ByteString -> IO (Either ParseError AFMFont)
afmParseFromFile :: AFMParser AFMFont
-> String -> ByteString -> IO (Either ParseError AFMFont)
afmParseFromFile AFMParser AFMFont
p String
path ByteString
bs = do
Either ParseError AFMFont -> IO (Either ParseError AFMFont)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError AFMFont -> IO (Either ParseError AFMFont))
-> Either ParseError AFMFont -> IO (Either ParseError AFMFont)
forall a b. (a -> b) -> a -> b
$ AFMParser AFMFont
-> AFMFont -> String -> String -> Either ParseError AFMFont
forall tok st a.
GenParser tok st a -> st -> String -> [tok] -> Either ParseError a
runParser AFMParser AFMFont
p AFMFont
emptyAFM String
path (ByteString -> String
unpack ByteString
bs)
parseFont :: Either ByteString String -> IO (Maybe AFMFont)
parseFont :: Either ByteString String -> IO (Maybe AFMFont)
parseFont (Left ByteString
bs) = do
Either ParseError AFMFont
r <- AFMParser AFMFont
-> String -> ByteString -> IO (Either ParseError AFMFont)
afmParseFromFile AFMParser AFMFont
afm String
"<embedded>" ByteString
bs
case Either ParseError AFMFont
r of
Left ParseError
e -> String -> IO (Maybe AFMFont)
forall a. HasCallStack => String -> a
error (ParseError -> String
forall a. Show a => a -> String
show ParseError
e)
Right AFMFont
r' -> Maybe AFMFont -> IO (Maybe AFMFont)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AFMFont -> IO (Maybe AFMFont))
-> Maybe AFMFont -> IO (Maybe AFMFont)
forall a b. (a -> b) -> a -> b
$ AFMFont -> Maybe AFMFont
forall a. a -> Maybe a
Just AFMFont
r'
parseFont (Right String
path) = do
ByteString
bs <- String -> IO ByteString
B.readFile String
path
Either ParseError AFMFont
r <- AFMParser AFMFont
-> String -> ByteString -> IO (Either ParseError AFMFont)
afmParseFromFile AFMParser AFMFont
afm String
path ByteString
bs
case Either ParseError AFMFont
r of
Left ParseError
e -> String -> IO (Maybe AFMFont)
forall a. HasCallStack => String -> a
error (ParseError -> String
forall a. Show a => a -> String
show ParseError
e)
Right AFMFont
r' -> Maybe AFMFont -> IO (Maybe AFMFont)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AFMFont -> IO (Maybe AFMFont))
-> Maybe AFMFont -> IO (Maybe AFMFont)
forall a b. (a -> b) -> a -> b
$ AFMFont -> Maybe AFMFont
forall a. a -> Maybe a
Just AFMFont
r'
getFont :: Either ByteString AFMFont
-> M.Map PostscriptName Char
-> Maybe (M.Map PostscriptName GlyphCode)
-> IO (Maybe FontStructure)
getFont :: Either ByteString AFMFont
-> Map String Char
-> Maybe (Map String GlyphCode)
-> IO (Maybe FontStructure)
getFont (Left ByteString
s) Map String Char
encoding' Maybe (Map String GlyphCode)
nameToGlyph = do
Maybe AFMFont
result <- Either ByteString String -> IO (Maybe AFMFont)
parseFont (ByteString -> Either ByteString String
forall a b. a -> Either a b
Left ByteString
s)
case Maybe AFMFont
result of
Maybe AFMFont
Nothing -> Maybe FontStructure -> IO (Maybe FontStructure)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FontStructure
forall a. Maybe a
Nothing
Just AFMFont
r -> Maybe FontStructure -> IO (Maybe FontStructure)
forall (m :: * -> *) a. Monad m => a -> m a
return (FontStructure -> Maybe FontStructure
forall a. a -> Maybe a
Just (FontStructure -> Maybe FontStructure)
-> FontStructure -> Maybe FontStructure
forall a b. (a -> b) -> a -> b
$ AFMFont
-> Map String Char -> Maybe (Map String GlyphCode) -> FontStructure
fontToStructure AFMFont
r Map String Char
encoding' Maybe (Map String GlyphCode)
nameToGlyph)
getFont (Right AFMFont
result) Map String Char
encoding' Maybe (Map String GlyphCode)
nameToGlyph = Maybe FontStructure -> IO (Maybe FontStructure)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FontStructure -> IO (Maybe FontStructure))
-> (FontStructure -> Maybe FontStructure)
-> FontStructure
-> IO (Maybe FontStructure)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontStructure -> Maybe FontStructure
forall a. a -> Maybe a
Just (FontStructure -> IO (Maybe FontStructure))
-> FontStructure -> IO (Maybe FontStructure)
forall a b. (a -> b) -> a -> b
$ AFMFont
-> Map String Char -> Maybe (Map String GlyphCode) -> FontStructure
fontToStructure AFMFont
result Map String Char
encoding' Maybe (Map String GlyphCode)
nameToGlyph