{-# 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 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 Paths_HPDF
import Graphics.PDF.LowLevel.Types
import Graphics.PDF.Fonts.Encoding(PostscriptName)
import Graphics.PDF.Fonts.FontTypes

data Metric = Metric { charCode :: Int
                     , metricWidth :: Int
                     , name :: String
                     , bounds :: [Double]
                     }
                     deriving(Eq,Show)

data EncodingScheme = AFMAdobeStandardEncoding
                    | AFMFontSpecific
                    | AFMUnsupportedEncoding
                    deriving(Eq,Read,Show)

data KX = KX String String Int
        deriving(Eq,Ord,Show)

data AFMFont = AFMFont { metrics :: [Metric]
                       , underlinePosition :: Int
                       , underlineThickness :: Int
                       , afmAscent :: Int
                       , afmDescent :: Int
                       , kernData :: Maybe [KX]
                       , type1BaseFont :: String
                       , encodingScheme :: EncodingScheme
                       , afmItalic :: Double
                       , afmCapHeight :: Int
                       , afmBBox :: [Double]
                       , afmFixedPitch :: Bool
                       , afmSymbolic :: Bool
                       }
                       deriving(Eq,Show)


type AFMParser = GenParser Char AFMFont

emptyAFM :: AFMFont
emptyAFM = AFMFont { metrics = []
                   , underlinePosition = 0
                   , underlineThickness = 0
                   , afmAscent = 0
                   , afmDescent = 0
                   , kernData = Nothing
                   , type1BaseFont = ""
                   , encodingScheme = AFMAdobeStandardEncoding
                   , afmItalic = 0.0
                   , afmCapHeight = 0
                   , afmBBox = []
                   , afmFixedPitch = False
                   , afmSymbolic = False
                   }

capitalize :: String -> String
capitalize [] = []
capitalize (h:t) = toUpper h : t


line :: AFMParser ()
line = do _ <- string "\r\n" <|> string "\n"
          return ()

toEndOfLine :: AFMParser ()
toEndOfLine = do _ <- many (noneOf "\r\n")
                 line
                 return ()

getString :: AFMParser String
getString = do
  c <- many1 (alphaNum <|> oneOf "-+")
  line
  return 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  = read <$> getString

getFloat :: AFMParser Double
getFloat = do
                c <- many1 (alphaNum <|> oneOf ".-+")
                line
                return $ read c

getBool :: AFMParser Bool
getBool = read . capitalize <$> getString

data CharacterSet = ExtendedRoman
                  | Special
                  deriving(Eq,Read,Show)

data Weight = Medium
            | Bold
            | Roman
            deriving(Eq,Read,Show)

-- getCharacterSet :: AFMParser CharacterSet
-- getCharacterSet = read <$> getString

-- getWeigth :: AFMParser Weight
-- getWeigth = read <$> getString

array :: AFMParser [String]
array = sepEndBy (many1 (oneOf "-+0123456789")) (many1 (oneOf " "))

getArray :: AFMParser [Double]
getArray  = do c <- array
               line
               return . map read $ c



getEncoding :: AFMParser EncodingScheme
getEncoding = do
  c <- getString
  case c of
    "AdobeStandardEncoding" -> return AFMAdobeStandardEncoding
    "FontSpecific" -> return AFMFontSpecific
    _ -> return  AFMUnsupportedEncoding

number :: AFMParser Int
number  = do c <- many1 (oneOf "-+0123456789")
             return $ read c

data Elem = C Int
          | WX Int
          | N String
          | B [Double]
          | L
          deriving(Eq,Read,Show)

metricElem :: AFMParser Elem
metricElem  = do _ <- char 'C'
                 spaces
                 C <$> number
              <|>
              do _ <- string "WX"
                 spaces
                 WX <$> number
              <|>
              do _ <- char 'N'
                 spaces
                 c <- many1 (alphaNum <|> char '.')
                 return $ N c
              <|>
              do _ <- char 'B'
                 spaces
                 c <- array
                 return . B . map read $ c
              <|>
              do _ <- char 'L'
                 spaces
                 _ <- many1 letter
                 spaces
                 _ <- many1 letter
                 return L

-- isEncoded :: Metric -> Bool
-- isEncoded (Metric c _ _ _) = c /= (-1)                  

mkMetric :: [Elem] -> Metric
mkMetric = foldr addElem (Metric (-1) 0 "" [])
 where
     addElem  (C c) m = m {charCode=c}
     addElem  (WX c) m = m {metricWidth=c}
     addElem  (N s) m = m {name=s}
     addElem  (B l) m = m {bounds=l}
     addElem  _ m = m

charMetric :: AFMParser Metric
charMetric = do
       l <- sepEndBy metricElem (many1 (oneOf "; "))
       line
       return . mkMetric $ l



kernPair :: AFMParser KX
kernPair = do _ <- string "KPX"
              spaces
              namea <- many1 alphaNum
              spaces
              nameb <- many1 alphaNum
              spaces
              nb <- many1 (oneOf "-+0123456789")
              line
              return $ KX namea nameb (read nb)



keyword :: String -> AFMParser () -> AFMParser ()
keyword s action = do
  _ <- string s
  spaces
  action
  return ()

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

header :: String -> AFMParser ()
header s = do
  _ <- string s
  toEndOfLine
  return ()

notHeader :: String -> AFMParser ()
notHeader s = do
  r <- many1 alphaNum
  if s == r
    then
      parserZero
    else do
      toEndOfLine

specific :: AFMParser ()
specific = choice [ try $ keyword "FontName" (getString >>= \name' -> modifyState $ \afm' -> afm' {type1BaseFont = name'})
                  , try $ keyword "UnderlinePosition" (getInt >>= \name' -> modifyState $ \afm' -> afm' {underlinePosition = name'})
                  , try $ keyword "UnderlineThickness" (getInt >>= \name' -> modifyState $ \afm' -> afm' {underlineThickness = name'})
                  , try $ keyword "EncodingScheme" (getEncoding >>= \name' -> modifyState $ \afm' -> afm' {encodingScheme = name'})
                  , try $ keyword "CapHeight" (getInt >>= \name' -> modifyState $ \afm' -> afm' {afmCapHeight = name'})
                  , try $ keyword "Ascender" (getInt >>= \name' -> modifyState $ \afm' -> afm' {afmAscent = name'})
                  , try $ keyword "Descender" (getInt >>= \name' -> modifyState $ \afm' -> afm' {afmDescent = name'})
                  , try $ keyword "ItalicAngle" (getFloat >>= \name' -> modifyState $ \afm' -> afm' {afmItalic = name'})
                  , try $ keyword "IsFixedPitch" (getBool >>= \name' -> modifyState $ \afm' -> afm' {afmFixedPitch = name'})
                  , try $ keyword "FontBBox" (getArray >>= \name' -> modifyState $ \afm' -> afm' {afmBBox = name'})
                  , try $ notHeader "StartCharMetrics"
                  ]

getKernData :: AFMParser (Maybe [KX])
getKernData = do
            { header "StartKernData"
            ; header "StartKernPairs"
            ; k <- many1 kernPair
            ; header "EndKernPairs"
            ; header "EndKernData"
            ; return $ Just k
            }

afm :: AFMParser AFMFont
afm =
  do
    header "StartFontMetrics"
    _ <- many1 specific
    header "StartCharMetrics"
    charMetrics <- many1 charMetric
    header "EndCharMetrics"
    kerns <- option Nothing getKernData
    _ <- string "EndFontMetrics"

    modifyState $ \afm' -> afm' { metrics = charMetrics
                                , kernData = kerns
                                }

    afm' <- getState
    let [_,ymin,_,ymax] = afmBBox afm'
    if afmAscent afm' == 0
    then
       if afmCapHeight afm' /= 0
          then
              return $ afm' { afmAscent = afmCapHeight afm'
                            }
          else
              let h = floor (ymax - ymin) in
              return $ afm' { afmAscent = h
                            , afmDescent = 0
                            }
    else
       return $ afm'

addMetric :: M.Map PostscriptName GlyphCode -> Metric -> FontStructure -> FontStructure
addMetric nameToGlyph m fs =
    let c = M.lookup (name m) nameToGlyph
        fs' = case c of
                Just glyphCode ->
                  fs { widthData = M.insert (fromIntegral glyphCode) (fromIntegral $ metricWidth m) (widthData fs)}
                Nothing -> fs
    in
    case (name m) of
      "space" -> fs' {space = fromIntegral $ charCode m}
      "hyphen" -> fs' {hyphen = Just (fromIntegral $ charCode m)}
      _ -> fs'

addKern :: M.Map String GlyphCode -> KX -> FontStructure -> FontStructure
addKern d (KX sa sb c) fs =
  let caM = M.lookup sa d
      cbM = M.lookup sb d
  in
  case (caM,cbM) of
    (Just ca, Just cb) -> fs {kernMetrics = M.insert (GlyphPair ca cb) (fromIntegral c) (kernMetrics fs)}
    _ -> 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 afm' encoding' maybeMapNameToGlyph =
  let h = (afmAscent afm' - afmDescent afm')
      fs = 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 m d | charCode m == -1 = d
                  | otherwise = M.insert (name m) (fromIntegral $ charCode m) d
      nameToGlyph = maybe (foldr addName M.empty (metrics afm')) id maybeMapNameToGlyph
      fs1 = foldr (addMetric nameToGlyph) fs (metrics afm')
      addEncodingMapping (pname,glyphcode) d =
         let unicodeM = M.lookup pname encoding'
         in
         case unicodeM of
          Nothing -> d
          Just code -> M.insert code glyphcode d
      mapping = foldr addEncodingMapping M.empty (M.toList nameToGlyph)
      fs2 = fs1 { encoding = mapping}
  in
  case kernData afm' of
    Nothing -> fs2
    Just k -> foldr (addKern nameToGlyph) fs2 k

afmParseFromFile :: AFMParser AFMFont -> FilePath -> IO (Either ParseError AFMFont)
afmParseFromFile p path = do
  l <- readFile path
  return $ runParser p emptyAFM path l

parseFont :: Either String String -> IO (Maybe AFMFont)
parseFont (Left s) = do
    path <- getDataFileName s
    r <- afmParseFromFile afm path
    case r of
      Left e -> error (show e)
      Right r' -> return $ Just r'
parseFont (Right path) = do
    r <- afmParseFromFile afm path
    case r of
      Left e -> error (show e)
      Right r' -> return $ Just r'

getFont :: Either String 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 (Left s) encoding' nameToGlyph = do
  result <- parseFont (Left s)
  case result of
    Nothing -> return Nothing
    Just r -> return (Just $ fontToStructure r encoding' nameToGlyph)
getFont (Right result) encoding' nameToGlyph = return . Just $ fontToStructure result encoding' nameToGlyph