{-# 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
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Metric] -> ShowS
$cshowList :: [Metric] -> ShowS
show :: Metric -> [Char]
$cshow :: Metric -> [Char]
showsPrec :: Int -> Metric -> ShowS
$cshowsPrec :: Int -> Metric -> ShowS
Show)
                     
data EncodingScheme = AFMAdobeStandardEncoding 
                    | AFMFontSpecific
                    | AFMUnsupportedEncoding
                    deriving(EncodingScheme -> EncodingScheme -> Bool
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]
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [EncodingScheme] -> ShowS
$cshowList :: [EncodingScheme] -> ShowS
show :: EncodingScheme -> [Char]
$cshow :: EncodingScheme -> [Char]
showsPrec :: Int -> EncodingScheme -> ShowS
$cshowsPrec :: Int -> EncodingScheme -> ShowS
Show)

data KX = KX String String Int  
        deriving(KX -> KX -> Bool
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
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
Ord,Int -> KX -> ShowS
[KX] -> ShowS
KX -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [KX] -> ShowS
$cshowList :: [KX] -> ShowS
show :: KX -> [Char]
$cshow :: KX -> [Char]
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 -> [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
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AFMFont] -> ShowS
$cshowList :: [AFMFont] -> ShowS
show :: AFMFont -> [Char]
$cshow :: AFMFont -> [Char]
showsPrec :: Int -> AFMFont -> ShowS
$cshowsPrec :: Int -> 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 = 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 forall a. a -> [a] -> [a]
: [Char]
t


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

toEndOfLine :: AFMParser ()
toEndOfLine :: AFMParser ()
toEndOfLine = do [Char]
_ <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
noneOf [Char]
"\r\n")
                 AFMParser ()
line
                 forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 
getString :: AFMParser String
getString :: ParsecT [Char] AFMFont Identity [Char]
getString = do 
  [Char]
c <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"-+")
  AFMParser ()
line
  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  = forall a. Read a => [Char] -> a
read 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 <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
".-+")
                AFMParser ()
line
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Read a => [Char] -> a
read [Char]
c
              
getBool :: AFMParser Bool
getBool :: AFMParser Bool
getBool = forall a. Read a => [Char] -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
capitalize 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
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]
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CharacterSet] -> ShowS
$cshowList :: [CharacterSet] -> ShowS
show :: CharacterSet -> [Char]
$cshow :: CharacterSet -> [Char]
showsPrec :: Int -> CharacterSet -> ShowS
$cshowsPrec :: Int -> CharacterSet -> ShowS
Show)
    
data Weight = Medium
            | Bold
            | Roman
            deriving(Weight -> Weight -> Bool
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]
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Weight] -> ShowS
$cshowList :: [Weight] -> ShowS
show :: Weight -> [Char]
$cshow :: Weight -> [Char]
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 [[Char]]
array = 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 (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"-+0123456789")) (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (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
               forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Read a => [Char] -> a
read 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" -> forall (m :: * -> *) a. Monad m => a -> m a
return EncodingScheme
AFMAdobeStandardEncoding
    [Char]
"FontSpecific" -> forall (m :: * -> *) a. Monad m => a -> m a
return EncodingScheme
AFMFontSpecific 
    [Char]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return  EncodingScheme
AFMUnsupportedEncoding     
                                           
number :: AFMParser Int
number :: AFMParser Int
number  = do [Char]
c <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"-+0123456789")
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Read a => [Char] -> a
read [Char]
c
         
data Elem = C Int
          | WX Int
          | N String
          | B [Double]
          | L
          deriving(Elem -> Elem -> Bool
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]
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Elem] -> ShowS
$cshowList :: [Elem] -> ShowS
show :: Elem -> [Char]
$cshow :: Elem -> [Char]
showsPrec :: Int -> Elem -> ShowS
$cshowsPrec :: Int -> Elem -> ShowS
Show)    
               
metricElem :: AFMParser Elem
metricElem :: AFMParser Elem
metricElem  = do Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'C'
                 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
                 Int -> Elem
C forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AFMParser Int
number 
              forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
              do [Char]
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"WX"
                 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
                 Int -> Elem
WX forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AFMParser Int
number 
              forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> 
              do Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'N'
                 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
                 [Char]
c <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.')
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Elem
N [Char]
c
              forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
              do Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'B'
                 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
                 [[Char]]
c <- AFMParser [[Char]]
array
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Double] -> Elem
B forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Read a => [Char] -> a
read forall a b. (a -> b) -> a -> b
$ [[Char]]
c   
              forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> 
              do Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'L'
                 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
                 [Char]
_ <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter
                 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
                 [Char]
_ <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter
                 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 = 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 :: Int
charCode=Int
c}
     addElem  (WX Int
c) Metric
m = Metric
m {metricWidth :: Int
metricWidth=Int
c}
     addElem  (N [Char]
s) Metric
m = Metric
m {name :: [Char]
name=[Char]
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 <- 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 (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"; ")) 
       AFMParser ()
line 
       forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Elem] -> Metric
mkMetric forall a b. (a -> b) -> a -> b
$ [Elem]
l
       

       
kernPair :: AFMParser KX
kernPair :: AFMParser KX
kernPair = do [Char]
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"KPX"
              forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
              [Char]
namea <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum
              forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
              [Char]
nameb <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum
              forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
              [Char]
nb <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"-+0123456789")
              AFMParser ()
line
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Int -> KX
KX [Char]
namea [Char]
nameb (forall a. Read a => [Char] -> a
read [Char]
nb)
                       

              
keyword :: String -> AFMParser () -> AFMParser () 
keyword :: [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
s AFMParser ()
action = do 
  [Char]
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
s
  forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  AFMParser ()
action
  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]
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
s  
  AFMParser ()
toEndOfLine 
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

notHeader :: String -> AFMParser () 
notHeader :: [Char] -> AFMParser ()
notHeader [Char]
s = do 
  [Char]
r <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum
  if [Char]
s forall a. Eq a => a -> a -> Bool
== [Char]
r 
    then 
      forall s u (m :: * -> *) a. ParsecT s u m a
parserZero 
    else do 
      AFMParser ()
toEndOfLine

specific :: AFMParser () 
specific :: AFMParser ()
specific = forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"FontName" (ParsecT [Char] AFMFont Identity [Char]
getString forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
name' -> forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {type1BaseFont :: [Char]
type1BaseFont = [Char]
name'}) 
                  , forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"UnderlinePosition" (AFMParser Int
getInt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
name' -> forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {underlinePosition :: Int
underlinePosition = Int
name'}) 
                  , forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"UnderlineThickness" (AFMParser Int
getInt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
name' -> forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {underlineThickness :: Int
underlineThickness = Int
name'})
                  , forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"EncodingScheme" (AFMParser EncodingScheme
getEncoding forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \EncodingScheme
name' -> forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {encodingScheme :: EncodingScheme
encodingScheme = EncodingScheme
name'})
                  , forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"CapHeight" (AFMParser Int
getInt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
name' -> forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {afmCapHeight :: Int
afmCapHeight = Int
name'}) 
                  , forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"Ascender" (AFMParser Int
getInt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
name' -> forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {afmAscent :: Int
afmAscent = Int
name'})
                  , forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"Descender" (AFMParser Int
getInt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
name' -> forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {afmDescent :: Int
afmDescent = Int
name'}) 
                  , forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"ItalicAngle" (AFMParser Double
getFloat forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Double
name' -> forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {afmItalic :: Double
afmItalic = Double
name'}) 
                  , forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"IsFixedPitch" (AFMParser Bool
getBool forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
name' -> forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {afmFixedPitch :: Bool
afmFixedPitch = Bool
name'}) 
                  , forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ [Char] -> AFMParser () -> AFMParser ()
keyword [Char]
"FontBBox" (AFMParser [Double]
getArray forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Double]
name' -> forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState forall a b. (a -> b) -> a -> b
$ \AFMFont
afm' -> AFMFont
afm' {afmBBox :: [Double]
afmBBox = [Double]
name'}) 
                  , forall tok st a. GenParser tok st a -> GenParser tok st a
try 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 <- 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"
            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [KX]
k
            }

afm :: AFMParser AFMFont
afm :: AFMParser AFMFont
afm = 
  do  
    [Char] -> AFMParser ()
header [Char]
"StartFontMetrics"
    [()]
_ <- 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 <- 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 <- forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option forall a. Maybe a
Nothing AFMParser (Maybe [KX])
getKernData
    [Char]
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"EndFontMetrics"
    
    forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState 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' <- 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' forall a. Eq a => a -> a -> Bool
== Int
0 
    then
       if AFMFont -> Int
afmCapHeight AFMFont
afm' forall a. Eq a => a -> a -> Bool
/= Int
0 
          then
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AFMFont
afm' { afmAscent :: Int
afmAscent = AFMFont -> Int
afmCapHeight AFMFont
afm'
                            }
          else
              let h :: Int
h = forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
ymax forall a. Num a => a -> a -> a
- Double
ymin) in
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AFMFont
afm' { afmAscent :: Int
afmAscent = Int
h 
                            , afmDescent :: Int
afmDescent = Int
0 
                            }
    else
       forall (m :: * -> *) a. Monad m => a -> m a
return 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 = 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 :: Map GlyphCode GlyphSize
widthData = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (forall a b. (Integral a, Num b) => a -> b
fromIntegral GlyphCode
glyphCode) (forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 -> [Char]
name Metric
m) of 
      [Char]
"space" -> FontStructure
fs' {space :: GlyphCode
space = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Metric -> Int
charCode Metric
m}
      [Char]
"hyphen" -> FontStructure
fs' {hyphen :: Maybe GlyphCode
hyphen = forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Metric -> Int
charCode Metric
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 = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
sa Map [Char] GlyphCode
d 
      cbM :: Maybe GlyphCode
cbM = 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 :: Map GlyphPair GlyphSize
kernMetrics = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (GlyphCode -> GlyphCode -> GlyphPair
GlyphPair GlyphCode
ca GlyphCode
cb) (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   -- ^ 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' forall a. Num a => a -> a -> a
- AFMFont -> Int
afmDescent AFMFont
afm') 
      fs :: FontStructure
fs = FontStructure
emptyFontStructure { descent :: GlyphSize
descent = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ - (AFMFont -> Int
afmDescent AFMFont
afm')
                              , height :: GlyphSize
height = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
h 
                              , ascent :: GlyphSize
ascent = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 :: [Char]
baseFont = AFMFont -> [Char]
type1BaseFont AFMFont
afm'
                              }
      addName :: Metric -> Map [Char] a -> Map [Char] a
addName Metric
m Map [Char] a
d | Metric -> Int
charCode Metric
m forall a. Eq a => a -> a -> Bool
== -Int
1 = Map [Char] a
d
                  | Bool
otherwise = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Metric -> [Char]
name Metric
m) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Metric -> Int
charCode Metric
m) Map [Char] a
d 
      nameToGlyph :: Map [Char] GlyphCode
nameToGlyph = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}. Num a => Metric -> Map [Char] a -> Map [Char] a
addName forall k a. Map k a
M.empty (AFMFont -> [Metric]
metrics AFMFont
afm')) forall a. a -> a
id Maybe (Map [Char] GlyphCode)
maybeMapNameToGlyph
      fs1 :: FontStructure
fs1 = 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 = 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 -> 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}. ([Char], a) -> Map Char a -> Map Char a
addEncodingMapping forall k a. Map k a
M.empty (forall k a. Map k a -> [(k, a)]
M.toList Map [Char] 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 -> 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 = 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