{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TemplateHaskell #-}
---------------------------------------------------------
-- |
-- Copyright   : (c) 2006-2016, alpheccar.org
-- License     : BSD-style
--
-- Maintainer  : misc@NOSPAMalpheccar.org
-- Stability   : experimental
-- Portability : portable
--
-- AFM AFMParser
---------------------------------------------------------
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

-- getSentence :: AFMParser String
-- getSentence = do 
--                c <- many1 (alphaNum <|> oneOf " -+")
--                line
--                return c

            
-- getName :: AFMParser String
-- getName = do 
--               c <- alphaNum >> many (alphaNum <|> oneOf " -+")
--               line
--               return 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)
               
-- getCharacterSet :: AFMParser CharacterSet
-- getCharacterSet = read <$> getString
                       
-- getWeigth :: AFMParser Weight
-- getWeigth = read <$> getString

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
                                
-- isEncoded :: Metric -> Bool
-- isEncoded (Metric c _ _ _) = c /= (-1)                  
                        
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 ()

-- anyKeyWord :: AFMParser () 
-- anyKeyWord = do 
--   _ <- many1 alphaNum
--   spaces 
--   toEndOfLine

header :: String -> AFMParser () 
header :: String -> AFMParser ()
header 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 () 
notHeader :: String -> AFMParser ()
notHeader 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

-- If the maybe argument is not nothing, we use the specific encoding for
-- the postscript names.
-- Otherwise we use the encoding we found in the afm file.
-- It is used to force MacRomanEncoding on not symbolic default fonts.
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  -- ^ Glyph name to unicode
        -> Maybe (M.Map PostscriptName GlyphCode)  -- ^ Glyph name to glyph code if not standard coding
        -> 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