From 82ecf51fea496726ab4643a88819ae3894d070a7 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Fri, 10 Nov 2023 11:57:08 +0100 Subject: [PATCH] Add the PDF generator snippets --- app/Main.hs | 14 +- fountainhead.cabal | 8 +- src/Graphics/Fountainhead/PDF.hs | 316 ++++++++++++++++++++++++++ src/Graphics/Fountainhead/Parser.hs | 4 + src/Graphics/Fountainhead/TrueType.hs | 4 + src/Graphics/Fountainhead/Type.hs | 4 + 6 files changed, 342 insertions(+), 8 deletions(-) create mode 100644 src/Graphics/Fountainhead/PDF.hs 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(..)