{-# 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(
      AFMFont(..)
    , EncodingScheme(..)
    , Metric(..)
    , KX(..)
    , parseAfm
    , fontToStructure
    ) where 

import Data.ByteString (ByteString)
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 -> [Char]
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
$c== :: Metric -> Metric -> Bool
== :: Metric -> Metric -> Bool
$c/= :: Metric -> Metric -> Bool
/= :: Metric -> Metric -> Bool
Eq,Int -> Metric -> ShowS
[Metric] -> ShowS
Metric -> [Char]
(Int -> Metric -> ShowS)
-> (Metric -> [Char]) -> ([Metric] -> ShowS) -> Show Metric
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Metric -> ShowS
showsPrec :: Int -> Metric -> ShowS
$cshow :: Metric -> [Char]
show :: Metric -> [Char]
$cshowList :: [Metric] -> ShowS
showList :: [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
$c== :: EncodingScheme -> EncodingScheme -> Bool
== :: EncodingScheme -> EncodingScheme -> Bool
$c/= :: EncodingScheme -> EncodingScheme -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS EncodingScheme
readsPrec :: Int -> ReadS EncodingScheme
$creadList :: ReadS [EncodingScheme]
readList :: ReadS [EncodingScheme]
$creadPrec :: ReadPrec EncodingScheme
readPrec :: ReadPrec EncodingScheme
$creadListPrec :: ReadPrec [EncodingScheme]
readListPrec :: ReadPrec [EncodingScheme]
Read,Int -> EncodingScheme -> ShowS
[EncodingScheme] -> ShowS
EncodingScheme -> [Char]
(Int -> EncodingScheme -> ShowS)
-> (EncodingScheme -> [Char])
-> ([EncodingScheme] -> ShowS)
-> Show EncodingScheme
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EncodingScheme -> ShowS
showsPrec :: Int -> EncodingScheme -> ShowS
$cshow :: EncodingScheme -> [Char]
show :: EncodingScheme -> [Char]
$cshowList :: [EncodingScheme] -> ShowS
showList :: [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
$c== :: KX -> KX -> Bool
== :: KX -> KX -> Bool
$c/= :: KX -> KX -> Bool
/= :: 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
$ccompare :: KX -> KX -> Ordering
compare :: KX -> KX -> Ordering
$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
>= :: KX -> KX -> Bool
$cmax :: KX -> KX -> KX
max :: KX -> KX -> KX
$cmin :: KX -> KX -> KX
min :: KX -> KX -> KX
Ord,Int -> KX -> ShowS
[KX] -> ShowS
KX -> [Char]
(Int -> KX -> ShowS)
-> (KX -> [Char]) -> ([KX] -> ShowS) -> Show KX
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KX -> ShowS
showsPrec :: Int -> KX -> ShowS
$cshow :: KX -> [Char]
show :: KX -> [Char]
$cshowList :: [KX] -> ShowS
showList :: [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 -> [Char]
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
$c== :: AFMFont -> AFMFont -> Bool
== :: AFMFont -> AFMFont -> Bool
$c/= :: AFMFont -> AFMFont -> Bool
/= :: AFMFont -> AFMFont -> Bool
Eq,Int -> AFMFont -> ShowS
[AFMFont] -> ShowS
AFMFont -> [Char]
(Int -> AFMFont -> ShowS)
-> (AFMFont -> [Char]) -> ([AFMFont] -> ShowS) -> Show AFMFont
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AFMFont -> ShowS
showsPrec :: Int -> AFMFont -> ShowS
$cshow :: AFMFont -> [Char]
show :: AFMFont -> [Char]
$cshowList :: [AFMFont] -> ShowS
showList :: [AFMFont] -> ShowS
Show)


type AFMParser = GenParser Char AFMFont

emptyAFM :: AFMFont
emptyAFM :: AFMFont
emptyAFM = 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 :: [Char]
type1BaseFont = [Char]
""
                   , 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:[Char]
t) = Char -> Char
toUpper Char
h Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
t


line :: AFMParser ()
line :: AFMParser ()
line = do [Char]
_ <- [Char] -> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\r\n" ParsecT [Char] AFMFont Identity [Char]
-> ParsecT [Char] AFMFont Identity [Char]
-> ParsecT [Char] 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 [Char] AFMFont Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\n"
          () -> AFMParser ()
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

toEndOfLine :: AFMParser ()
toEndOfLine :: AFMParser ()
toEndOfLine = do [Char]
_ <- ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ([Char] -> ParsecT [Char] AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
noneOf [Char]
"\r\n")
                 AFMParser ()
line
                 () -> AFMParser ()
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 
getString :: AFMParser String
getString :: ParsecT [Char] AFMFont Identity [Char]
getString = do 
  [Char]
c <- ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Char] AFMFont Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] 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 [Char] AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"-+")
  AFMParser ()
line
  [Char] -> ParsecT [Char] AFMFont Identity [Char]
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
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  = [Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int)
-> ParsecT [Char] AFMFont Identity [Char] -> AFMParser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Char] AFMFont Identity [Char]
getString
              
getFloat :: AFMParser Double
getFloat :: AFMParser Double
getFloat = do 
                [Char]
c <- ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Char] AFMFont Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] 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 [Char] AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
".-+")
                AFMParser ()
line
                Double -> AFMParser Double
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> AFMParser Double) -> Double -> AFMParser Double
forall a b. (a -> b) -> a -> b
$ [Char] -> Double
forall a. Read a => [Char] -> a
read [Char]
c
              
getBool :: AFMParser Bool
getBool :: AFMParser Bool
getBool = [Char] -> Bool
forall a. Read a => [Char] -> a
read ([Char] -> Bool) -> ShowS -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
capitalize ([Char] -> Bool)
-> ParsecT [Char] AFMFont Identity [Char] -> AFMParser Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Char] AFMFont Identity [Char]
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
$c== :: CharacterSet -> CharacterSet -> Bool
== :: CharacterSet -> CharacterSet -> Bool
$c/= :: CharacterSet -> CharacterSet -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS CharacterSet
readsPrec :: Int -> ReadS CharacterSet
$creadList :: ReadS [CharacterSet]
readList :: ReadS [CharacterSet]
$creadPrec :: ReadPrec CharacterSet
readPrec :: ReadPrec CharacterSet
$creadListPrec :: ReadPrec [CharacterSet]
readListPrec :: ReadPrec [CharacterSet]
Read,Int -> CharacterSet -> ShowS
[CharacterSet] -> ShowS
CharacterSet -> [Char]
(Int -> CharacterSet -> ShowS)
-> (CharacterSet -> [Char])
-> ([CharacterSet] -> ShowS)
-> Show CharacterSet
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CharacterSet -> ShowS
showsPrec :: Int -> CharacterSet -> ShowS
$cshow :: CharacterSet -> [Char]
show :: CharacterSet -> [Char]
$cshowList :: [CharacterSet] -> ShowS
showList :: [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
$c== :: Weight -> Weight -> Bool
== :: Weight -> Weight -> Bool
$c/= :: Weight -> Weight -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS Weight
readsPrec :: Int -> ReadS Weight
$creadList :: ReadS [Weight]
readList :: ReadS [Weight]
$creadPrec :: ReadPrec Weight
readPrec :: ReadPrec Weight
$creadListPrec :: ReadPrec [Weight]
readListPrec :: ReadPrec [Weight]
Read,Int -> Weight -> ShowS
[Weight] -> ShowS
Weight -> [Char]
(Int -> Weight -> ShowS)
-> (Weight -> [Char]) -> ([Weight] -> ShowS) -> Show Weight
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Weight -> ShowS
showsPrec :: Int -> Weight -> ShowS
$cshow :: Weight -> [Char]
show :: Weight -> [Char]
$cshowList :: [Weight] -> ShowS
showList :: [Weight] -> ShowS
Show)
               
-- getCharacterSet :: AFMParser CharacterSet
-- getCharacterSet = read <$> getString
                       
-- getWeigth :: AFMParser Weight
-- getWeigth = read <$> getString

array :: AFMParser [String]  
array :: AFMParser [[Char]]
array = ParsecT [Char] AFMFont Identity [Char]
-> ParsecT [Char] AFMFont Identity [Char] -> AFMParser [[Char]]
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 [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ([Char] -> ParsecT [Char] AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"-+0123456789")) (ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ([Char] -> ParsecT [Char] AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
" "))
                 
getArray :: AFMParser [Double]
getArray :: AFMParser [Double]
getArray  = do [[Char]]
c <- AFMParser [[Char]]
array
               AFMParser ()
line
               [Double] -> AFMParser [Double]
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Double] -> AFMParser [Double])
-> ([[Char]] -> [Double]) -> [[Char]] -> AFMParser [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Double) -> [[Char]] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Double
forall a. Read a => [Char] -> a
read ([[Char]] -> AFMParser [Double]) -> [[Char]] -> AFMParser [Double]
forall a b. (a -> b) -> a -> b
$ [[Char]]
c
                 

           
getEncoding :: AFMParser EncodingScheme
getEncoding :: AFMParser EncodingScheme
getEncoding = do 
  [Char]
c <- ParsecT [Char] AFMFont Identity [Char]
getString
  case [Char]
c of 
    [Char]
"AdobeStandardEncoding" -> EncodingScheme -> AFMParser EncodingScheme
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return EncodingScheme
AFMAdobeStandardEncoding
    [Char]
"FontSpecific" -> EncodingScheme -> AFMParser EncodingScheme
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return EncodingScheme
AFMFontSpecific 
    [Char]
_ -> EncodingScheme -> AFMParser EncodingScheme
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return  EncodingScheme
AFMUnsupportedEncoding     
                                           
number :: AFMParser Int
number :: AFMParser Int
number  = do [Char]
c <- ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ([Char] -> ParsecT [Char] AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"-+0123456789")
             Int -> AFMParser Int
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> AFMParser Int) -> Int -> AFMParser Int
forall a b. (a -> b) -> a -> b
$ [Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
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
$c== :: Elem -> Elem -> Bool
== :: Elem -> Elem -> Bool
$c/= :: Elem -> Elem -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS Elem
readsPrec :: Int -> ReadS Elem
$creadList :: ReadS [Elem]
readList :: ReadS [Elem]
$creadPrec :: ReadPrec Elem
readPrec :: ReadPrec Elem
$creadListPrec :: ReadPrec [Elem]
readListPrec :: ReadPrec [Elem]
Read,Int -> Elem -> ShowS
[Elem] -> ShowS
Elem -> [Char]
(Int -> Elem -> ShowS)
-> (Elem -> [Char]) -> ([Elem] -> ShowS) -> Show Elem
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Elem -> ShowS
showsPrec :: Int -> Elem -> ShowS
$cshow :: Elem -> [Char]
show :: Elem -> [Char]
$cshowList :: [Elem] -> ShowS
showList :: [Elem] -> ShowS
Show)    
               
metricElem :: AFMParser Elem
metricElem :: AFMParser Elem
metricElem  = do Char
_ <- Char -> ParsecT [Char] 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 [Char]
_ <- [Char] -> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"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 [Char] 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
                 [Char]
c <- ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Char] AFMFont Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] 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 [Char] AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.')
                 Elem -> AFMParser Elem
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Elem -> AFMParser Elem) -> Elem -> AFMParser Elem
forall a b. (a -> b) -> a -> b
$ [Char] -> Elem
N [Char]
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 [Char] 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
                 [[Char]]
c <- AFMParser [[Char]]
array
                 Elem -> AFMParser Elem
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Elem -> AFMParser Elem)
-> ([[Char]] -> Elem) -> [[Char]] -> AFMParser Elem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Double] -> Elem
B ([Double] -> Elem) -> ([[Char]] -> [Double]) -> [[Char]] -> Elem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Double) -> [[Char]] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Double
forall a. Read a => [Char] -> a
read ([[Char]] -> AFMParser Elem) -> [[Char]] -> AFMParser Elem
forall a b. (a -> b) -> a -> b
$ [[Char]]
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 [Char] 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
                 [Char]
_ <- ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT [Char] 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
                 [Char]
_ <- ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT [Char] AFMFont Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter
                 Elem -> AFMParser Elem
forall a. a -> ParsecT [Char] AFMFont Identity a
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 a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Elem -> Metric -> Metric
addElem (Int -> Int -> [Char] -> [Double] -> Metric
Metric (-Int
1) Int
0 [Char]
"" [])  
 where
     addElem :: Elem -> Metric -> Metric
addElem  (C Int
c) Metric
m = Metric
m {charCode=c}
     addElem  (WX Int
c) Metric
m = Metric
m {metricWidth=c}
     addElem  (N [Char]
s) Metric
m = Metric
m {name=s}
     addElem  (B [Double]
l) Metric
m = Metric
m {bounds=l}
     addElem  Elem
_ Metric
m = Metric
m         
                          
charMetric :: AFMParser Metric
charMetric :: AFMParser Metric
charMetric = do
       [Elem]
l <- AFMParser Elem
-> ParsecT [Char] AFMFont Identity [Char]
-> ParsecT [Char] 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 [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ([Char] -> ParsecT [Char] AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"; ")) 
       AFMParser ()
line 
       Metric -> AFMParser Metric
forall a. a -> ParsecT [Char] AFMFont Identity a
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 [Char]
_ <- [Char] -> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"KPX"
              AFMParser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
              [Char]
namea <- ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT [Char] 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
              [Char]
nameb <- ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT [Char] 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
              [Char]
nb <- ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ([Char] -> ParsecT [Char] AFMFont Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"-+0123456789")
              AFMParser ()
line
              KX -> AFMParser KX
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (KX -> AFMParser KX) -> KX -> AFMParser KX
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Int -> KX
KX [Char]
namea [Char]
nameb ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
nb)
                       

              
keyword :: String -> AFMParser () -> AFMParser () 
keyword :: [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
s AFMParser ()
action = do 
  [Char]
_ <- [Char] -> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
s
  AFMParser ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  AFMParser ()
action
  () -> AFMParser ()
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

header :: String -> AFMParser () 
header :: [Char] -> AFMParser ()
header [Char]
s = do 
  [Char]
_ <- [Char] -> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
s  
  AFMParser ()
toEndOfLine 
  () -> AFMParser ()
forall a. a -> ParsecT [Char] AFMFont Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

notHeader :: String -> AFMParser () 
notHeader :: [Char] -> AFMParser ()
notHeader [Char]
s = do 
  [Char]
r <- ParsecT [Char] AFMFont Identity Char
-> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT [Char] AFMFont Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum
  if [Char]
s [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
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
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"FontName" (ParsecT [Char] AFMFont Identity [Char]
getString ParsecT [Char] AFMFont Identity [Char]
-> ([Char] -> AFMParser ()) -> AFMParser ()
forall a b.
ParsecT [Char] AFMFont Identity a
-> (a -> ParsecT [Char] AFMFont Identity b)
-> ParsecT [Char] AFMFont Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
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 = 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
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"UnderlinePosition" (AFMParser Int
getInt AFMParser Int -> (Int -> AFMParser ()) -> AFMParser ()
forall a b.
ParsecT [Char] AFMFont Identity a
-> (a -> ParsecT [Char] AFMFont Identity b)
-> ParsecT [Char] AFMFont Identity b
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 = 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
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"UnderlineThickness" (AFMParser Int
getInt AFMParser Int -> (Int -> AFMParser ()) -> AFMParser ()
forall a b.
ParsecT [Char] AFMFont Identity a
-> (a -> ParsecT [Char] AFMFont Identity b)
-> ParsecT [Char] AFMFont Identity b
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 = 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
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"EncodingScheme" (AFMParser EncodingScheme
getEncoding AFMParser EncodingScheme
-> (EncodingScheme -> AFMParser ()) -> AFMParser ()
forall a b.
ParsecT [Char] AFMFont Identity a
-> (a -> ParsecT [Char] AFMFont Identity b)
-> ParsecT [Char] AFMFont Identity b
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 = 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
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"CapHeight" (AFMParser Int
getInt AFMParser Int -> (Int -> AFMParser ()) -> AFMParser ()
forall a b.
ParsecT [Char] AFMFont Identity a
-> (a -> ParsecT [Char] AFMFont Identity b)
-> ParsecT [Char] AFMFont Identity b
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 = 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
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"Ascender" (AFMParser Int
getInt AFMParser Int -> (Int -> AFMParser ()) -> AFMParser ()
forall a b.
ParsecT [Char] AFMFont Identity a
-> (a -> ParsecT [Char] AFMFont Identity b)
-> ParsecT [Char] AFMFont Identity b
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 = 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
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"Descender" (AFMParser Int
getInt AFMParser Int -> (Int -> AFMParser ()) -> AFMParser ()
forall a b.
ParsecT [Char] AFMFont Identity a
-> (a -> ParsecT [Char] AFMFont Identity b)
-> ParsecT [Char] AFMFont Identity b
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 = 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
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"ItalicAngle" (AFMParser Double
getFloat AFMParser Double -> (Double -> AFMParser ()) -> AFMParser ()
forall a b.
ParsecT [Char] AFMFont Identity a
-> (a -> ParsecT [Char] AFMFont Identity b)
-> ParsecT [Char] AFMFont Identity b
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 = 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
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"IsFixedPitch" (AFMParser Bool
getBool AFMParser Bool -> (Bool -> AFMParser ()) -> AFMParser ()
forall a b.
ParsecT [Char] AFMFont Identity a
-> (a -> ParsecT [Char] AFMFont Identity b)
-> ParsecT [Char] AFMFont Identity b
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 = 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
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"FontBBox" (AFMParser [Double]
getArray AFMParser [Double] -> ([Double] -> AFMParser ()) -> AFMParser ()
forall a b.
ParsecT [Char] AFMFont Identity a
-> (a -> ParsecT [Char] AFMFont Identity b)
-> ParsecT [Char] AFMFont Identity b
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 = 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
$ [Char] -> AFMParser ()
notHeader [Char]
"StartCharMetrics"
                  ]

getKernData :: AFMParser (Maybe [KX])
getKernData :: AFMParser (Maybe [KX])
getKernData = do 
            { [Char] -> AFMParser ()
header [Char]
"StartKernData"
            ; [Char] -> AFMParser ()
header [Char]
"StartKernPairs" 
            ; [KX]
k <- AFMParser KX -> ParsecT [Char] 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
            ; [Char] -> AFMParser ()
header [Char]
"EndKernPairs"
            ; [Char] -> AFMParser ()
header [Char]
"EndKernData"
            ; Maybe [KX] -> AFMParser (Maybe [KX])
forall a. a -> ParsecT [Char] AFMFont Identity a
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  
    [Char] -> AFMParser ()
header [Char]
"StartFontMetrics"
    [()]
_ <- AFMParser () -> ParsecT [Char] 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 
    [Char] -> AFMParser ()
header [Char]
"StartCharMetrics"
    [Metric]
charMetrics <- AFMParser Metric -> ParsecT [Char] 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
    [Char] -> AFMParser ()
header [Char]
"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
    [Char]
_ <- [Char] -> ParsecT [Char] AFMFont Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"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 = charMetrics 
                                , kernData = 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 a. a -> ParsecT [Char] AFMFont Identity a
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 = afmCapHeight afm'
                            }
          else
              let h :: Int
h = Double -> Int
forall b. Integral b => Double -> b
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 a. a -> ParsecT [Char] AFMFont Identity a
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 = h 
                            , afmDescent = 0 
                            }
    else
       AFMFont -> AFMParser AFMFont
forall a. a -> ParsecT [Char] AFMFont Identity a
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 [Char] GlyphCode -> Metric -> FontStructure -> FontStructure
addMetric Map [Char] GlyphCode
nameToGlyph Metric
m FontStructure
fs = 
    let c :: Maybe GlyphCode
c = [Char] -> Map [Char] GlyphCode -> Maybe GlyphCode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Metric -> [Char]
name Metric
m) Map [Char] GlyphCode
nameToGlyph
        fs' :: FontStructure
fs' = case Maybe GlyphCode
c of 
                Just GlyphCode
glyphCode -> 
                  FontStructure
fs { widthData = M.insert (fromIntegral glyphCode) (fromIntegral $ metricWidth m) (widthData fs)}
                Maybe GlyphCode
Nothing -> FontStructure
fs
    in 
    case (Metric -> [Char]
name Metric
m) of 
      [Char]
"space" -> FontStructure
fs' {space = fromIntegral $ charCode m}
      [Char]
"hyphen" -> FontStructure
fs' {hyphen = Just (fromIntegral $ charCode m)}
      [Char]
_ -> FontStructure
fs'

addKern :: M.Map String GlyphCode -> KX -> FontStructure -> FontStructure 
addKern :: Map [Char] GlyphCode -> KX -> FontStructure -> FontStructure
addKern Map [Char] GlyphCode
d (KX [Char]
sa [Char]
sb Int
c) FontStructure
fs = 
  let caM :: Maybe GlyphCode
caM = [Char] -> Map [Char] GlyphCode -> Maybe GlyphCode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
sa Map [Char] GlyphCode
d 
      cbM :: Maybe GlyphCode
cbM = [Char] -> Map [Char] GlyphCode -> Maybe GlyphCode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
sb Map [Char] GlyphCode
d
  in 
  case (Maybe GlyphCode
caM,Maybe GlyphCode
cbM) of
    (Just GlyphCode
ca, Just GlyphCode
cb) -> FontStructure
fs {kernMetrics = M.insert (GlyphPair ca cb) (fromIntegral c) (kernMetrics 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   -- ^ Glyph name to unicode
                -> Maybe (M.Map PostscriptName GlyphCode)  -- ^ Glyph name to glyph code if not standard coding
                -> FontStructure 
fontToStructure :: AFMFont
-> Map [Char] Char -> Maybe (Map [Char] GlyphCode) -> FontStructure
fontToStructure AFMFont
afm' Map [Char] Char
encoding' Maybe (Map [Char] 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 = fromIntegral $ - (afmDescent afm')
                              , height = fromIntegral $ h 
                              , ascent = fromIntegral $ afmAscent afm'
                              , fontBBox = afmBBox afm'
                              , italicAngle = afmItalic afm'
                              , capHeight = fromIntegral $ afmCapHeight afm'
                              , fixedPitch = afmFixedPitch afm'
                              , serif = False
                              , symbolic = afmSymbolic afm'
                              , script = False
                              , nonSymbolic = not (afmSymbolic afm')
                              , italic = False
                              , allCap = False
                              , smallCap = False
                              , forceBold = False
                              , baseFont = type1BaseFont afm'
                              }
      addName :: Metric -> Map [Char] a -> Map [Char] a
addName Metric
m Map [Char] a
d | Metric -> Int
charCode Metric
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 = Map [Char] a
d
                  | Bool
otherwise = [Char] -> a -> Map [Char] a -> Map [Char] a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Metric -> [Char]
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 [Char] a
d 
      nameToGlyph :: Map [Char] GlyphCode
nameToGlyph = Map [Char] GlyphCode
-> (Map [Char] GlyphCode -> Map [Char] GlyphCode)
-> Maybe (Map [Char] GlyphCode)
-> Map [Char] GlyphCode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Metric -> Map [Char] GlyphCode -> Map [Char] GlyphCode)
-> Map [Char] GlyphCode -> [Metric] -> Map [Char] GlyphCode
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Metric -> Map [Char] GlyphCode -> Map [Char] GlyphCode
forall {a}. Num a => Metric -> Map [Char] a -> Map [Char] a
addName Map [Char] GlyphCode
forall k a. Map k a
M.empty (AFMFont -> [Metric]
metrics AFMFont
afm')) Map [Char] GlyphCode -> Map [Char] GlyphCode
forall a. a -> a
id Maybe (Map [Char] GlyphCode)
maybeMapNameToGlyph
      fs1 :: FontStructure
fs1 = (Metric -> FontStructure -> FontStructure)
-> FontStructure -> [Metric] -> FontStructure
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Map [Char] GlyphCode -> Metric -> FontStructure -> FontStructure
addMetric Map [Char] GlyphCode
nameToGlyph) FontStructure
fs (AFMFont -> [Metric]
metrics AFMFont
afm')
      addEncodingMapping :: ([Char], a) -> Map Char a -> Map Char a
addEncodingMapping ([Char]
pname,a
glyphcode) Map Char a
d = 
         let unicodeM :: Maybe Char
unicodeM = [Char] -> Map [Char] Char -> Maybe Char
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
pname Map [Char] 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 = (([Char], GlyphCode) -> Map Char GlyphCode -> Map Char GlyphCode)
-> Map Char GlyphCode
-> [([Char], GlyphCode)]
-> Map Char GlyphCode
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Char], GlyphCode) -> Map Char GlyphCode -> Map Char GlyphCode
forall {a}. ([Char], a) -> Map Char a -> Map Char a
addEncodingMapping Map Char GlyphCode
forall k a. Map k a
M.empty (Map [Char] GlyphCode -> [([Char], GlyphCode)]
forall k a. Map k a -> [(k, a)]
M.toList Map [Char] GlyphCode
nameToGlyph)
      fs2 :: FontStructure
fs2 = FontStructure
fs1 { encoding = 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 a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Map [Char] GlyphCode -> KX -> FontStructure -> FontStructure
addKern Map [Char] GlyphCode
nameToGlyph) FontStructure
fs2 [KX]
k

afmParseFromFile :: AFMParser AFMFont -> FilePath -> ByteString -> Either ParseError AFMFont
afmParseFromFile :: AFMParser AFMFont
-> [Char] -> ByteString -> Either ParseError AFMFont
afmParseFromFile AFMParser AFMFont
p [Char]
path ByteString
bs = AFMParser AFMFont
-> AFMFont -> [Char] -> [Char] -> Either ParseError AFMFont
forall tok st a.
GenParser tok st a -> st -> [Char] -> [tok] -> Either ParseError a
runParser AFMParser AFMFont
p AFMFont
emptyAFM [Char]
path (ByteString -> [Char]
unpack ByteString
bs)

parseAfm :: FilePath -> ByteString -> Either ParseError AFMFont
parseAfm :: [Char] -> ByteString -> Either ParseError AFMFont
parseAfm = AFMParser AFMFont
-> [Char] -> ByteString -> Either ParseError AFMFont
afmParseFromFile AFMParser AFMFont
afm