{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
---------------------------------------------------------
-- |
-- Copyright   : (c) 2006-2016, alpheccar.org
-- License     : BSD-style
--
-- Maintainer  : misc@NOSPAMalpheccar.org
-- Stability   : experimental
-- Portability : portable
--
-- PDF Font
---------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
module Graphics.PDF.Fonts.StandardFont(
      IsFont
    , GlyphSize
    , FontName(..)
    , StdFont(..)
    , mkStdFont
    , embeddedFont
) where 

import Data.ByteString (ByteString)
import Data.FileEmbed (embedFile)
import Graphics.PDF.LowLevel.Types
import Graphics.PDF.Resources
import qualified Data.Map.Strict as M
import Graphics.PDF.Fonts.Font
import Graphics.PDF.Fonts.AFMParser(fontToStructure, parseAfm)
import Graphics.PDF.Fonts.Encoding
import Graphics.PDF.Fonts.FontTypes
import Text.Parsec.Error(ParseError)


data FontName = Helvetica 
              | Helvetica_Bold
              | Helvetica_Oblique
              | Helvetica_BoldOblique
              | Times_Roman 
              | Times_Bold
              | Times_Italic
              | Times_BoldItalic
              | Courier
              | Courier_Bold
              | Courier_Oblique
              | Courier_BoldOblique
              | Symbol
              | ZapfDingbats
              deriving(FontName -> FontName -> Bool
(FontName -> FontName -> Bool)
-> (FontName -> FontName -> Bool) -> Eq FontName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FontName -> FontName -> Bool
== :: FontName -> FontName -> Bool
$c/= :: FontName -> FontName -> Bool
/= :: FontName -> FontName -> Bool
Eq,Eq FontName
Eq FontName =>
(FontName -> FontName -> Ordering)
-> (FontName -> FontName -> Bool)
-> (FontName -> FontName -> Bool)
-> (FontName -> FontName -> Bool)
-> (FontName -> FontName -> Bool)
-> (FontName -> FontName -> FontName)
-> (FontName -> FontName -> FontName)
-> Ord FontName
FontName -> FontName -> Bool
FontName -> FontName -> Ordering
FontName -> FontName -> FontName
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 :: FontName -> FontName -> Ordering
compare :: FontName -> FontName -> Ordering
$c< :: FontName -> FontName -> Bool
< :: FontName -> FontName -> Bool
$c<= :: FontName -> FontName -> Bool
<= :: FontName -> FontName -> Bool
$c> :: FontName -> FontName -> Bool
> :: FontName -> FontName -> Bool
$c>= :: FontName -> FontName -> Bool
>= :: FontName -> FontName -> Bool
$cmax :: FontName -> FontName -> FontName
max :: FontName -> FontName -> FontName
$cmin :: FontName -> FontName -> FontName
min :: FontName -> FontName -> FontName
Ord,Int -> FontName
FontName -> Int
FontName -> [FontName]
FontName -> FontName
FontName -> FontName -> [FontName]
FontName -> FontName -> FontName -> [FontName]
(FontName -> FontName)
-> (FontName -> FontName)
-> (Int -> FontName)
-> (FontName -> Int)
-> (FontName -> [FontName])
-> (FontName -> FontName -> [FontName])
-> (FontName -> FontName -> [FontName])
-> (FontName -> FontName -> FontName -> [FontName])
-> Enum FontName
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: FontName -> FontName
succ :: FontName -> FontName
$cpred :: FontName -> FontName
pred :: FontName -> FontName
$ctoEnum :: Int -> FontName
toEnum :: Int -> FontName
$cfromEnum :: FontName -> Int
fromEnum :: FontName -> Int
$cenumFrom :: FontName -> [FontName]
enumFrom :: FontName -> [FontName]
$cenumFromThen :: FontName -> FontName -> [FontName]
enumFromThen :: FontName -> FontName -> [FontName]
$cenumFromTo :: FontName -> FontName -> [FontName]
enumFromTo :: FontName -> FontName -> [FontName]
$cenumFromThenTo :: FontName -> FontName -> FontName -> [FontName]
enumFromThenTo :: FontName -> FontName -> FontName -> [FontName]
Enum)


instance Show FontName where
    show :: FontName -> String
show FontName
Helvetica = String
"Helvetica"
    show FontName
Helvetica_Bold = String
"Helvetica-Bold"
    show FontName
Helvetica_Oblique = String
"Helvetica-Oblique"
    show FontName
Helvetica_BoldOblique = String
"Helvetica-BoldOblique"
    show FontName
Times_Roman = String
"Times-Roman"
    show FontName
Times_Bold = String
"Times-Bold"
    show FontName
Times_Italic = String
"Times-Italic"
    show FontName
Times_BoldItalic = String
"Times-BoldItalic"
    show FontName
Courier = String
"Courier"
    show FontName
Courier_Bold = String
"Courier-Bold"
    show FontName
Courier_Oblique = String
"Courier-Oblique"
    show FontName
Courier_BoldOblique = String
"Courier-BoldOblique"
    show FontName
Symbol = String
"Symbol"
    show FontName
ZapfDingbats = String
"ZapfDingbats"

embeddedFont :: FontName -> ByteString
embeddedFont :: FontName -> ByteString
embeddedFont FontName
Helvetica = $(embedFile "Core14_AFMs/Helvetica.afm")
embeddedFont FontName
Helvetica_Bold = $(embedFile "Core14_AFMs/Helvetica-Bold.afm")
embeddedFont FontName
Helvetica_Oblique = $(embedFile "Core14_AFMs/Helvetica-Oblique.afm")
embeddedFont FontName
Helvetica_BoldOblique = $(embedFile "Core14_AFMs/Helvetica-BoldOblique.afm")
embeddedFont FontName
Times_Roman = $(embedFile "Core14_AFMs/Times-Roman.afm")
embeddedFont FontName
Times_Bold = $(embedFile "Core14_AFMs/Times-Bold.afm")
embeddedFont FontName
Times_Italic = $(embedFile "Core14_AFMs/Times-Italic.afm")
embeddedFont FontName
Times_BoldItalic = $(embedFile "Core14_AFMs/Times-BoldItalic.afm")
embeddedFont FontName
Courier = $(embedFile "Core14_AFMs/Courier.afm")
embeddedFont FontName
Courier_Bold = $(embedFile "Core14_AFMs/Courier-Bold.afm")
embeddedFont FontName
Courier_Oblique = $(embedFile "Core14_AFMs/Courier-Oblique.afm")
embeddedFont FontName
Courier_BoldOblique = $(embedFile "Core14_AFMs/Courier-BoldOblique.afm")
embeddedFont FontName
Symbol = $(embedFile "Core14_AFMs/Symbol.afm")
embeddedFont FontName
ZapfDingbats = $(embedFile "Core14_AFMs/ZapfDingbats.afm")

data StdFont = StdFont FontStructure deriving Int -> StdFont -> ShowS
[StdFont] -> ShowS
StdFont -> String
(Int -> StdFont -> ShowS)
-> (StdFont -> String) -> ([StdFont] -> ShowS) -> Show StdFont
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StdFont -> ShowS
showsPrec :: Int -> StdFont -> ShowS
$cshow :: StdFont -> String
show :: StdFont -> String
$cshowList :: [StdFont] -> ShowS
showList :: [StdFont] -> ShowS
Show

instance PdfResourceObject StdFont where
   toRsrc :: StdFont -> AnyPdfObject
toRsrc (StdFont FontStructure
f) =  PDFDictionary -> AnyPdfObject
forall a. (PdfObject a, PdfLengthInfo a) => a -> AnyPdfObject
AnyPdfObject (PDFDictionary -> AnyPdfObject)
-> ([(PDFName, AnyPdfObject)] -> PDFDictionary)
-> [(PDFName, AnyPdfObject)]
-> AnyPdfObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(PDFName, AnyPdfObject)] -> PDFDictionary
dictFromList ([(PDFName, AnyPdfObject)] -> AnyPdfObject)
-> [(PDFName, AnyPdfObject)] -> AnyPdfObject
forall a b. (a -> b) -> a -> b
$
                           [String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"Type" (String -> PDFName
PDFName (String -> PDFName) -> String -> PDFName
forall a b. (a -> b) -> a -> b
$ String
"Font")
                           , String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"Subtype" (String -> PDFName
PDFName (String -> PDFName) -> String -> PDFName
forall a b. (a -> b) -> a -> b
$ String
"Type1")
                           , String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"BaseFont" (String -> PDFName
PDFName (String -> PDFName) -> String -> PDFName
forall a b. (a -> b) -> a -> b
$ FontStructure -> String
baseFont FontStructure
f)
                           ] [(PDFName, AnyPdfObject)]
-> [(PDFName, AnyPdfObject)] -> [(PDFName, AnyPdfObject)]
forall a. [a] -> [a] -> [a]
++ [(PDFName, AnyPdfObject)]
encoding'
          where encoding' :: [(PDFName, AnyPdfObject)]
encoding' | FontStructure -> String
baseFont FontStructure
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== FontName -> String
forall a. Show a => a -> String
show FontName
Symbol = [] 
                          | FontStructure -> String
baseFont FontStructure
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== FontName -> String
forall a. Show a => a -> String
show FontName
ZapfDingbats = []
                          | Bool
otherwise = [String -> PDFName -> (PDFName, AnyPdfObject)
forall a.
(PdfObject a, PdfLengthInfo a) =>
String -> a -> (PDFName, AnyPdfObject)
entry String
"Encoding" (String -> PDFName
PDFName (String -> PDFName) -> String -> PDFName
forall a b. (a -> b) -> a -> b
$ String
"MacRomanEncoding")]

instance IsFont StdFont where 
  getDescent :: StdFont -> Int -> PDFFloat
getDescent (StdFont FontStructure
fs) Int
s = Int -> GlyphSize -> PDFFloat
trueSize Int
s (GlyphSize -> PDFFloat) -> GlyphSize -> PDFFloat
forall a b. (a -> b) -> a -> b
$ FontStructure -> GlyphSize
descent FontStructure
fs 
  getHeight :: StdFont -> Int -> PDFFloat
getHeight (StdFont FontStructure
fs) Int
s = Int -> GlyphSize -> PDFFloat
trueSize Int
s (GlyphSize -> PDFFloat) -> GlyphSize -> PDFFloat
forall a b. (a -> b) -> a -> b
$ FontStructure -> GlyphSize
height FontStructure
fs 
  getKern :: StdFont -> Int -> GlyphCode -> GlyphCode -> PDFFloat
getKern (StdFont FontStructure
fs) Int
s GlyphCode
a GlyphCode
b = Int -> GlyphSize -> PDFFloat
trueSize Int
s (GlyphSize -> PDFFloat) -> GlyphSize -> PDFFloat
forall a b. (a -> b) -> a -> b
$ GlyphSize -> GlyphPair -> Map GlyphPair GlyphSize -> GlyphSize
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault GlyphSize
0 (GlyphCode -> GlyphCode -> GlyphPair
GlyphPair GlyphCode
a GlyphCode
b) (FontStructure -> Map GlyphPair GlyphSize
kernMetrics FontStructure
fs)
  glyphWidth :: StdFont -> Int -> GlyphCode -> PDFFloat
glyphWidth (StdFont FontStructure
fs) Int
s GlyphCode
a = Int -> GlyphSize -> PDFFloat
trueSize Int
s  (GlyphSize -> PDFFloat) -> GlyphSize -> PDFFloat
forall a b. (a -> b) -> a -> b
$ GlyphSize -> GlyphCode -> Map GlyphCode GlyphSize -> GlyphSize
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault GlyphSize
0 GlyphCode
a (FontStructure -> Map GlyphCode GlyphSize
widthData FontStructure
fs)
  charGlyph :: StdFont -> Char -> GlyphCode
charGlyph (StdFont FontStructure
fs) Char
c = GlyphCode -> Char -> Map Char GlyphCode -> GlyphCode
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault GlyphCode
0 Char
c (FontStructure -> Map Char GlyphCode
encoding FontStructure
fs)
  name :: StdFont -> String
name (StdFont FontStructure
fs) = FontStructure -> String
baseFont FontStructure
fs 
  hyphenGlyph :: StdFont -> Maybe GlyphCode
hyphenGlyph (StdFont FontStructure
fs) = FontStructure -> Maybe GlyphCode
hyphen FontStructure
fs 
  spaceGlyph :: StdFont -> GlyphCode
spaceGlyph (StdFont FontStructure
fs) = FontStructure -> GlyphCode
space FontStructure
fs

mkStdFont :: FontName -> IO (Either ParseError AnyFont)
mkStdFont :: FontName -> IO (Either ParseError AnyFont)
mkStdFont FontName
f = do
  Map String Char
theEncoding <- case FontName
f of  
                    FontName
ZapfDingbats -> Encodings -> IO (Map String Char)
getEncoding Encodings
ZapfDingbatsEncoding  
                    FontName
_ -> Encodings -> IO (Map String Char)
getEncoding Encodings
AdobeStandardEncoding
  Maybe (Map String GlyphCode)
theMacEncoding <- case FontName
f of 
                     FontName
ZapfDingbats -> Maybe (Map String GlyphCode) -> IO (Maybe (Map String GlyphCode))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Map String GlyphCode)
forall a. Maybe a
Nothing
                     FontName
Symbol -> Maybe (Map String GlyphCode) -> IO (Maybe (Map String GlyphCode))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Map String GlyphCode)
forall a. Maybe a
Nothing 
                     FontName
_ -> IO (Map String GlyphCode)
parseMacEncoding IO (Map String GlyphCode)
-> (Map String GlyphCode -> IO (Maybe (Map String GlyphCode)))
-> IO (Maybe (Map String GlyphCode))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Map String GlyphCode) -> IO (Maybe (Map String GlyphCode))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Map String GlyphCode) -> IO (Maybe (Map String GlyphCode)))
-> (Map String GlyphCode -> Maybe (Map String GlyphCode))
-> Map String GlyphCode
-> IO (Maybe (Map String GlyphCode))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String GlyphCode -> Maybe (Map String GlyphCode)
forall a. a -> Maybe a
Just
  Either ParseError AnyFont -> IO (Either ParseError AnyFont)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError AnyFont -> IO (Either ParseError AnyFont))
-> Either ParseError AnyFont -> IO (Either ParseError AnyFont)
forall a b. (a -> b) -> a -> b
$ case String -> ByteString -> Either ParseError AFMFont
parseAfm String
"<embedded>" (ByteString -> Either ParseError AFMFont)
-> ByteString -> Either ParseError AFMFont
forall a b. (a -> b) -> a -> b
$ FontName -> ByteString
embeddedFont FontName
f of 
    Left ParseError
pe -> ParseError -> Either ParseError AnyFont
forall a b. a -> Either a b
Left ParseError
pe 
    Right AFMFont
r -> AnyFont -> Either ParseError AnyFont
forall a b. b -> Either a b
Right (AnyFont -> Either ParseError AnyFont)
-> AnyFont -> Either ParseError AnyFont
forall a b. (a -> b) -> a -> b
$ let theFont :: FontStructure
theFont = AFMFont
-> Map String Char -> Maybe (Map String GlyphCode) -> FontStructure
fontToStructure AFMFont
r Map String Char
theEncoding Maybe (Map String GlyphCode)
theMacEncoding
                           f' :: FontStructure
f' = FontStructure
theFont { baseFont = show f }
                       in StdFont -> AnyFont
forall f. (IsFont f, PdfResourceObject f, Show f) => f -> AnyFont
AnyFont (StdFont -> AnyFont) -> StdFont -> AnyFont
forall a b. (a -> b) -> a -> b
$ FontStructure -> StdFont
StdFont FontStructure
f'