Add the PDF generator snippets

6 files changed, 342 insertions, 8 deletions

diff --git a/app/Main.hs b/app/Main.hs
index 24e7a32..cc2c11d 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -16,10 +16,11 @@ import Graphics.Fountainhead.Parser
     )
 import Graphics.Fountainhead.TrueType (FontDirectory(..), TableDirectory(..))
 import System.Environment (getArgs)
+import System.Exit (exitWith)
+import GHC.IO.Exception (ExitCode(..))
 
-fontMain :: IO ()
-fontMain = do
-    fontFile <- head <$> getArgs
+fontMain :: FilePath -> IO ()
+fontMain fontFile = do
     ttfContents <- ByteString.readFile fontFile
 
     let initialState = Megaparsec.State
@@ -43,4 +44,9 @@ fontMain = do
         Right x -> print x
 
 main :: IO ()
-main = fontMain
+main = do
+    programArguments <- getArgs
+    case programArguments of
+        [fontFile] -> fontMain fontFile
+        _ -> putStrLn "The program expects exactly one argument, the font file path."
+            >> exitWith (ExitFailure 2)
diff --git a/fountainhead.cabal b/fountainhead.cabal
index b8536f8..ce06a61 100644
--- a/fountainhead.cabal
+++ b/fountainhead.cabal
@@ -7,13 +7,11 @@ description: TrueType font parseer.
 bug-reports: https://git.caraus.tech/OSS/fountainhead/issues
 homepage: https://git.caraus.tech/OSS/fountainhead
 maintainer: belka@caraus.de
+author: Eugen Wissner
 
 license-files: LICENSE
 license: MPL-2.0
 
-author: Eugen Wissner
-maintainer: belka@caraus.de
-
 copyright: (c) 2023 Eugen Wissner
 category: Graphics
 
@@ -24,16 +22,18 @@ extra-source-files:
 library
   exposed-modules:
     Graphics.Fountainhead.Parser
+    Graphics.Fountainhead.PDF
     Graphics.Fountainhead.Type
     Graphics.Fountainhead.TrueType
   hs-source-dirs:
     src
   build-depends:
-    base ^>=4.16.3.0,
+    base >= 4.16 && < 5,
     bytestring ^>= 0.11.0,
     containers ^>= 0.6.5,
     megaparsec ^>= 9.3,
     time ^>= 1.12,
+    transformers ^>= 0.5,
     vector ^>= 0.13.0
 
 executable fountainhead
diff --git a/src/Graphics/Fountainhead/PDF.hs b/src/Graphics/Fountainhead/PDF.hs
new file mode 100644
index 0000000..1ed42fc
--- /dev/null
+++ b/src/Graphics/Fountainhead/PDF.hs
@@ -0,0 +1,316 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# LANGUAGE EmptyDataDecls #-}
+
+module Graphics.Fountainhead.PDF
+    ( Dictionary(..)
+    , E5
+    , Header(..)
+    , Link(..)
+    , Name(..)
+    , Object(..)
+    , Sink
+    , TextString(..)
+    , Trailer(..)
+    , Type(..)
+    , UncoatedString(..)
+    , XRefSection(..)
+    , XRefEntry(..)
+    , arrayType
+    , headerToPdf
+    , dictionaryToPdf
+    , dictionaryType
+    , linkToPdf
+    , linkType
+    , nameToPdf
+    , nameType
+    , nextName
+    , objectToPdf
+    , sinkWithLength
+    , stringType
+    , textStringToPdf
+    , textType
+    , trailerToPdf
+    , typeToPdf
+    , uncoatedStringToPdf
+    , xrefEntryToPdf
+    , xrefSectionToPdf
+    , writeObject
+    ) where
+
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Trans.State (StateT, get, gets, put)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Builder as ByteString.Builder
+import qualified Data.ByteString.Builder as ByteString (Builder)
+import qualified Data.ByteString.Lazy as ByteString.Lazy
+import Data.Char (ord)
+import Data.Fixed (Fixed(..), HasResolution(..), showFixed)
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+
+-- | The header in the first line of a PDF file contains a PDF version number
+-- consisting of a major and a minor version.
+data Header = Header Int Int
+    deriving (Eq, Show)
+
+-- | See t'Header'.
+headerToPdf :: Header -> ByteString.Builder
+headerToPdf (Header major minor)
+    = ByteString.Builder.string7 "%PDF-"
+    <> ByteString.Builder.intDec major
+    <> ByteString.Builder.char7 '.'
+    <> ByteString.Builder.intDec minor
+    <> ByteString.Builder.char7 '\n'
+
+-- | A name object is an atomic symbol uniquely defined by a sequence of
+-- characters.
+newtype Name = Name String
+    deriving (Eq, Show)
+
+-- | See t'Name'.
+nameToPdf :: Name -> ByteString.Builder
+nameToPdf (Name name) = ByteString.Builder.char7 '/'
+    <> ByteString.Builder.string7 name
+
+-- | A dictionary object is an associative table containing pairs of objects.
+newtype Dictionary = Dictionary (Vector (Name, Type))
+
+-- | See t'Dictionary'.
+dictionaryToPdf :: Dictionary -> IO ByteString.Builder
+dictionaryToPdf (Dictionary valuePairs) = do
+    pairs <- traverse pairToPdf valuePairs
+    pure
+        $ ByteString.Builder.string7 "<<"
+        <> unwordBuilder pairs
+        <> ByteString.Builder.string7 ">>"
+  where
+    pairToPdf (name, value) = do
+        value' <- typeToPdf value
+        pure $ nameToPdf name <> ByteString.Builder.char7 ' ' <> value'
+
+-- | Hexadecimal data.
+newtype UncoatedString = UncoatedString String
+    deriving (Eq, Show)
+
+-- | See t'UncoatedString'.
+uncoatedStringToPdf :: UncoatedString -> ByteString.Builder
+uncoatedStringToPdf (UncoatedString uncoatedString)
+    = ByteString.Builder.char7 '<'
+    <> ByteString.Builder.string8 uncoatedString
+    <> ByteString.Builder.char7 '>'
+
+-- | A sequence of literal characters.
+newtype TextString = TextString String
+    deriving (Eq, Show)
+
+-- | See t'TextString'.
+textStringToPdf :: TextString -> ByteString.Builder
+textStringToPdf (TextString textString)
+    = ByteString.Builder.char7 '('
+    <> ByteString.Builder.stringUtf8 textString 
+    <> ByteString.Builder.char7 ')'
+
+-- Resolution of 10^-5 = .001.
+data E5
+
+instance HasResolution E5
+  where
+    resolution _ = 100000
+
+-- | Reference to an inderect object, consisting of the object name and
+-- revision.
+data Link = Link Int Int
+    deriving (Eq, Show)
+
+-- | See t'Link'.
+linkToPdf :: Link -> ByteString.Builder
+linkToPdf (Link name revision)
+    = ByteString.Builder.intDec name
+    <> ByteString.Builder.char7 ' '
+    <> ByteString.Builder.intDec revision
+    <> ByteString.Builder.string8 " R"
+
+-- | Basic types of object.
+data Type
+    = DictionaryType Dictionary
+    | ArrayType (Vector Type)
+    | LinkType Link
+    | NameType Name
+    | IntegerType Int
+    | RealType (Fixed E5)
+    | StreamType Dictionary (IO ByteString)
+    | StringType UncoatedString
+    | TextType TextString
+    | NullType
+
+-- | See t'Type'.
+typeToPdf :: Type -> IO ByteString.Builder
+typeToPdf (DictionaryType dictionary) = dictionaryToPdf dictionary
+typeToPdf (ArrayType values) = do
+    converted <- traverse typeToPdf values
+    pure
+        $ ByteString.Builder.char7 '['
+        <> unwordBuilder converted
+        <> ByteString.Builder.char7 ']'
+typeToPdf (LinkType link) = pure $ linkToPdf link
+typeToPdf (NameType name) = pure $ nameToPdf name
+typeToPdf (IntegerType pdfInteger) = pure $ ByteString.Builder.intDec pdfInteger
+typeToPdf (StreamType dictionary producer) = do
+    streamContents <- producer
+    producedDictionary <- dictionaryToPdf dictionary
+    pure
+        $ producedDictionary
+        <> ByteString.Builder.string8 "\nstream\n"
+        <> ByteString.Builder.byteString streamContents
+        <> ByteString.Builder.string8 "\nendstream"
+typeToPdf (StringType string) = pure $ uncoatedStringToPdf string
+typeToPdf (TextType text) = pure $ textStringToPdf text
+typeToPdf (RealType realType) =
+    pure $ ByteString.Builder.string7 $ showFixed True realType
+typeToPdf NullType = pure $ ByteString.Builder.string7 "null"
+
+-- | Object number, generation number and object contents.
+data Object = Object Int Int Type
+
+-- | See t'Object'.
+objectToPdf :: Object -> IO ByteString.Builder
+objectToPdf (Object name revision type') = do
+    producedType <- typeToPdf type'
+    pure $ ByteString.Builder.intDec name
+        <> ByteString.Builder.char7 ' '
+        <> ByteString.Builder.intDec revision
+        <> ByteString.Builder.string7 " obj\n"
+        <> producedType
+        <> ByteString.Builder.string7 "\nendobj\n"
+
+-- | Shortcut to create a t'Dictionary' type.
+dictionaryType :: [(Name, Type)] -> Type
+dictionaryType = DictionaryType . Dictionary . Vector.fromList
+
+-- | Shortcut to create an t'Array' type.
+arrayType :: [Type] -> Type
+arrayType = ArrayType . Vector.fromList
+
+-- | Shortcut to create a t'Name' type.
+nameType :: String -> Type
+nameType = NameType . Name
+
+-- | Shortcut to create a t'UncoatedString' type.
+stringType :: String -> Type
+stringType = StringType . UncoatedString
+
+-- | Shortcut to create a t'TextString' type.
+textType :: String -> Type
+textType = TextType . TextString
+
+-- | Shortcut to create a t'Link' type.
+linkType :: Int -> Int -> Type
+linkType name revision = LinkType $ Link name revision
+
+-- | Byte offset of an object in the file, generation number and whether this is
+-- an in-use entry.
+data XRefEntry = XRefEntry Int Int Bool
+    deriving (Eq, Show)
+
+-- | See t'XRefEntry'.
+xrefEntryToPdf :: XRefEntry -> ByteString.Builder
+xrefEntryToPdf (XRefEntry offset generation True)
+    = pad 10 offset
+    <> ByteString.Builder.char7 ' '
+    <> pad 5 generation
+    <> ByteString.Builder.string7 " n"
+xrefEntryToPdf (XRefEntry offset generation False)
+    = pad 10 offset
+    <> ByteString.Builder.char7 ' '
+    <> pad 5 generation
+    <> ByteString.Builder.string7 " f"
+
+-- | Cross-reference table containing information about the indirect objects in
+-- the file.
+newtype XRefSection = XRefSection
+    { unXRefSection :: Vector XRefEntry
+    } deriving (Eq, Show)
+
+-- | See t'XRefSection'.
+xrefSectionToPdf :: XRefSection -> ByteString.Builder
+xrefSectionToPdf (XRefSection entries)
+    = ByteString.Builder.string7 "xref\n0 "
+    <> ByteString.Builder.intDec (length entries)
+    <> newline
+    <> Vector.foldMap (newline <>) (xrefEntryToPdf <$> entries)
+    <> newline
+
+instance Semigroup XRefSection
+  where
+    (XRefSection lhs) <> (XRefSection rhs) = XRefSection $ lhs <> rhs
+
+instance Monoid XRefSection
+  where
+    mempty = XRefSection mempty
+
+-- | A trailer giving the location of the cross-reference table and of certain
+-- special objects within the body of the file.
+data Trailer = Trailer Dictionary Int
+
+-- | See t'Trailer'.
+trailerToPdf :: Trailer -> IO ByteString.Builder
+trailerToPdf (Trailer dictionary startxref) = do
+    producedDictionary <- dictionaryToPdf dictionary
+    pure $ ByteString.Builder.string7 "trailer "
+        <> producedDictionary
+        <> ByteString.Builder.string7 "\nstartxref\n"
+        <> ByteString.Builder.intDec startxref
+        <> ByteString.Builder.string7 "\n%%EOF\n"
+
+pad :: Int -> Int -> ByteString.Builder
+pad length' number =
+    let asString = ByteString.Builder.intDec number
+        numberLength = builderLength asString
+        padding = ByteString.Builder.byteString
+            $ ByteString.replicate (length' - numberLength) zero
+     in padding <> asString
+  where
+    zero = fromIntegral $ ord '0'
+    builderLength = fromIntegral
+        . ByteString.Lazy.length
+        . ByteString.Builder.toLazyByteString
+
+unwordBuilder :: Vector ByteString.Builder -> ByteString.Builder
+unwordBuilder = Vector.foldMap (ByteString.Builder.char7 ' ' <>)
+
+newline :: ByteString.Builder
+newline = ByteString.Builder.char7 '\n'
+
+type Sink = ByteString.Lazy.ByteString -> IO ()
+
+-- | Creates a new object using the provided value, writes the object to the
+-- sink, and returns a reference to that object.
+--
+-- For example if the passed value is a dictionary, the created object could be
+-- @
+-- 2 0 obj <<…>> endobj
+-- @
+-- where "2 0" identifies the object. The name (2) is generated using the state,
+-- the revision is always 0.
+writeObject :: Sink -> Type -> StateT (Int, XRefSection) IO Link
+writeObject sink object = do
+    (previousLength, XRefSection refs) <- get
+    let objectName = length refs
+    objectContents <- liftIO $ objectToPdf $ Object objectName 0 object
+    writtenLength <- liftIO $ sinkWithLength sink objectContents
+    put (previousLength + writtenLength, XRefSection $ Vector.snoc refs (XRefEntry previousLength 0 True))
+    pure $ Link objectName 0
+
+-- | Gets the name of the object which will be generated next.
+nextName :: StateT (Int, XRefSection) IO Int
+nextName = gets (length . unXRefSection . snd)
+
+-- | Writes the data into the sink and returns the number of the written bytes.
+sinkWithLength :: Sink -> ByteString.Builder -> IO Int
+sinkWithLength sink data' =
+    let lazyData = ByteString.Builder.toLazyByteString data'
+     in sink lazyData >> pure (fromIntegral $ ByteString.Lazy.length lazyData)
diff --git a/src/Graphics/Fountainhead/Parser.hs b/src/Graphics/Fountainhead/Parser.hs
index bfa1596..6d2b900 100644
--- a/src/Graphics/Fountainhead/Parser.hs
+++ b/src/Graphics/Fountainhead/Parser.hs
@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE ExplicitForAll #-}
diff --git a/src/Graphics/Fountainhead/TrueType.hs b/src/Graphics/Fountainhead/TrueType.hs
index de51575..a461d52 100644
--- a/src/Graphics/Fountainhead/TrueType.hs
+++ b/src/Graphics/Fountainhead/TrueType.hs
@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 {-# LANGUAGE DuplicateRecordFields #-}
 
 -- | Types representing a TrueType font.
diff --git a/src/Graphics/Fountainhead/Type.hs b/src/Graphics/Fountainhead/Type.hs
index 3dc2a3f..2493157 100644
--- a/src/Graphics/Fountainhead/Type.hs
+++ b/src/Graphics/Fountainhead/Type.hs
@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 -- | Generic font types.
 module Graphics.Fountainhead.Type
     ( F2Dot14(..)