diff --git a/line2pdf.cabal b/line2pdf.cabal --- a/line2pdf.cabal +++ b/line2pdf.cabal @@ -1,5 +1,5 @@ name: line2pdf -version: 0.0.6 +version: 0.0.7 copyright: 2008 Audrey Tang license: BSD3 license-file: LICENSE @@ -17,7 +17,7 @@ description: Choose the new smaller, split-up base package. library - exposed-modules: Text.LineToPDF + exposed-modules: Text.LineToPDF Text.LineToPDF.Internals extensions: ImplicitParams, ExistentialQuantification if flag(small_base) build-depends: base >= 3, containers, bytestring diff --git a/src/Text/LineToPDF.hs b/src/Text/LineToPDF.hs --- a/src/Text/LineToPDF.hs +++ b/src/Text/LineToPDF.hs @@ -1,485 +1,4 @@ -{-# LANGUAGE ImplicitParams, ExistentialQuantification #-} - -module Text.LineToPDF (lineToPDF, defaultConfig, AppConfig(..), Encoding(..)) where -import Data.IORef -import System.IO -import System.IO.Unsafe -import Control.Applicative -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.IntMap as IM - -{-# NOINLINE __POS__ #-} -__POS__ :: IORef Int -__POS__ = unsafePerformIO (newRef 0) - -{-# NOINLINE __OBJ__ #-} -__OBJ__ :: IORef Int -__OBJ__ = unsafePerformIO (newRef 0) - -{-# NOINLINE __LOC__ #-} -__LOC__ :: IORef (IM.IntMap String) -__LOC__ = unsafePerformIO (newRef IM.empty) - -{-# NOINLINE __PAGE__ #-} -__PAGE__ :: IORef [Obj] -__PAGE__ = unsafePerformIO (newRef []) - -data Encoding - = Latin - | Big5 - | GBK - | EUC_JP - | EUC_KR - | ShiftJIS - -data AppConfig = forall a. MkAppConfig - { pageWidth :: Int - , pageHeight :: Int - , ptSize :: Float - , encodings :: [Encoding] - , srcLines :: [a] - , srcPut :: a -> IO () - , srcEscape :: Char -> a -> a - , srcLength :: a -> Int - , srcHead :: a -> Char - } - -defaultConfig :: Encoding -> L.ByteString -> AppConfig -defaultConfig enc txt = MkAppConfig - { pageWidth = 842 - , pageHeight = 595 - , ptSize = 12 - , encodings = [enc] - , srcLines = L.lines txt - , srcPut = L.putStr - , srcEscape = \ch -> L.intercalate (L.pack ['\\', ch]) . L.split ch - , srcLength = fromEnum . L.length - , srcHead = L.head - } - -type M = IO -type Obj = Int - -lineToPDF :: AppConfig -> IO () -lineToPDF appConfig = do - hSetBinaryMode stdout True - - pr$ "%PDF-1.2\n" ++ "%\xE2\xE3\xCF\xD3\n" - - (info, root, tPages, resources) <- writeHeader $ encodings appConfig - - pageObjs <- let ?tPages = tPages - ?resources = resources in writePages appConfig - - markLocation root - writeObj root $ do - pr$ "/Type/Catalog" ++ "/Pages " - pr$ show tPages ++ " 0 R" - - markLocation tPages - writeObj tPages $ do - pr$ "/Type/Pages" ++ "/Count " - pr$ show (length pageObjs) - ++ "/MediaBox[0 0 " - ++ show (pageWidth appConfig) ++ " " ++ show (pageHeight appConfig) - pr$ "]" ++ "/Kids[" - pr$ concatMap ((++ " 0 R ") . show) pageObjs - pr$ "]" - - xfer <- currentLocation - - objCount <- incrObj - pr$ "xref\n" ++ "0 " ++ show objCount ++ "\n" - ++ "0000000000 65535 f \r" - - writeLocations - - pr$ "trailer\n" ++ "<<" ++ "/Size " - pr$ show objCount - - pr$ "/Root " ++ show root ++ " 0 R" - pr$ "/Info " ++ show info ++ " 0 R" - pr$ ">>\n" ++ "startxref\n" - pr$ show xfer ++ "\n" ++ "%%EOF\n" - -writeObj :: Obj -> M a -> M a -writeObj obj f = do - pr$ show obj ++ " 0 obj" ++ "<<" - rv <- f - pr$ ">>" ++ "endobj\n" - return rv - -writeLocations :: M () -writeLocations = do - locs <- IM.elems <$> readRef __LOC__ - pr$ concatMap fmt locs - where - fmt x = pad ++ x ++ " 00000 n \r" - where - pad = replicate (10-l) '0' - l = length x - -printObj :: String -> M Obj -printObj str = markObj $ (pr str >>) . return - -writeHeader :: [Encoding] -> M (Obj, Obj, Obj, Obj) -writeHeader encs = do - info <- printObj $ "/CreationDate(D:20080707163949+08'00')" - ++ "/Producer(line2pdf.hs)" - ++ "/Title(Untitled)" - encoding <- printObj strDefaultEncoding - latinFonts <- (`mapM` ([1..] `zip` baseFonts)) $ \(n, font) -> do - markObj $ \obj -> do - pr$ "/Type/Font" ++ "/Subtype/Type1" ++ "/Name/F" - pr$ show (n :: Int) - pr$ "/Encoding " ++ show encoding ++ " 0 R" - pr$ font - return $ "/F" ++ show n ++ " " ++ show obj ++ " 0 R" - cjkFonts <- (`mapM` encs) $ \enc -> case enc of - Latin -> return [] - Big5 -> writeFontsBig5 - GBK -> writeFontsGBK - EUC_JP -> writeFontsEUC_JP - EUC_KR -> writeFontsEUC_KR - ShiftJIS -> writeFontsShiftJIS - root <- incrObj - tPages <- incrObj - markObj $ \resources -> do - pr$ "/Font<<" ++ concat latinFonts ++ concat (concat cjkFonts) ++ ">>" - ++ "/ProcSet[/PDF/Text]" ++ "/XObject<<>>" - return (info, root, tPages, resources) - -baseFonts :: [String] -baseFonts = - [ "/BaseFont/Courier" - , "/BaseFont/Courier-Oblique" - , "/BaseFont/Courier-Bold" - , "/BaseFont/Courier-BoldOblique" - , "/BaseFont/Helvetica" - , "/BaseFont/Helvetica-Oblique" - , "/BaseFont/Helvetica-Bold" - , "/BaseFont/Helvetica-BoldOblique" - , "/BaseFont/Times-Roman" - , "/BaseFont/Times-Italic" - , "/BaseFont/Times-Bold" - , "/BaseFont/Times-BoldItalic" - , "/BaseFont/Symbol" - , "/BaseFont/ZapfDingbats" - ] - -pr :: String -> M () -pr str = do - putStr str - modifyRef __POS__ (+ (length str)) - -currentLocation :: IO Int -currentLocation = readRef __POS__ - -newRef :: a -> M (IORef a) -newRef = newIORef - -readRef :: IORef a -> M a -readRef = readIORef - -writeRef :: IORef a -> a -> M () -writeRef = writeIORef - -modifyRef :: IORef a -> (a -> a) -> M () -modifyRef = modifyIORef - -incrObj :: M Obj -incrObj = do - obj <- succ <$> readRef __OBJ__ - writeRef __OBJ__ obj - return obj - -markObj :: (Obj -> M a) -> M a -markObj f = do - obj <- incrObj - markLocation obj - writeObj obj (f obj) - -markLocation :: Obj -> M () -markLocation obj = do - loc <- currentLocation - modifyRef __LOC__ $ IM.insert obj (show loc) - -fontOf :: Encoding -> String -fontOf Latin = "1" -fontOf EUC_JP = "20" -fontOf ShiftJIS = "25" -fontOf Big5 = "30" -fontOf GBK = "35" -fontOf EUC_KR = "40" - -startPage :: (?tPages :: Obj, ?resources :: Obj) => AppConfig -> M Int -startPage MkAppConfig{ pageHeight = height, ptSize = pt, encodings = encs } = do - markObj $ \obj -> do - modifyRef __PAGE__ (obj:) - pr$ "/Type/Page" - pr$ "/Parent " ++ show ?tPages ++ " 0 R" - pr$ "/Resources " ++ show ?resources ++ " 0 R" - pr$ "/Contents " ++ show (succ obj) ++ " 0 R" - pr$ "/Rotate 0" - - obj <- incrObj - markLocation obj - pr$ show obj ++ " 0 obj" ++ "<<" - pr$ "/Length " ++ show (succ obj) ++ " 0 R" - pr$ ">>" ++ "stream\n" - - streamPos <- currentLocation - pr$ "BT\n"; - let font = fontOf $ case encs of - (l:_) -> l - _ -> Latin - pr$ "/F" ++ font ++ " " ++ show pt ++ " Tf\n" - pr$ "1 0 0 1 50 " ++ show (height - 40) ++ " Tm\n" - pr$ show pt ++ " TL\n" - - return streamPos - -endPage :: Int -> M () -endPage streamStart = do - pr$ "ET\n" - streamEnd <- currentLocation - pr$ "endstream\n" - ++ "endobj\n" - - obj <- incrObj - markLocation obj - - pr$ show obj ++ " 0 obj\n" - ++ show (streamEnd - streamStart) ++ "\n" - ++ "endobj\n" - -writePages :: (?tPages :: Obj, ?resources :: Obj) => AppConfig -> M [Obj] -writePages appConfig@MkAppConfig - { srcLength = len - , srcPut = put - , srcHead = hd - , srcLines = lns - , srcEscape = esc - , pageHeight = height - } = do - pos <- newRef =<< startPage appConfig - - (`mapM_` lns) $ \ln -> do - case len ln of - 1 | hd ln == '\f' -> do - endPage =<< readRef pos - writeRef pos =<< startPage appConfig - _ -> do - pr$ "T*(" - let ln' = (esc '(' . esc ')' . esc '\\') ln - put ln' - modifyRef __POS__ (+ len ln') - pr$ ")Tj\n" - - endPage =<< readRef pos - reverse <$> readRef __PAGE__ - -strDefaultEncoding :: String -strDefaultEncoding = "/Type/Encoding" - ++ "/Differences[0 /.notdef/.notdef/.notdef/.notdef" - ++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef" - ++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef" - ++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef" - ++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef" - ++ "/.notdef/.notdef/.notdef/.notdef/space/exclam" - ++ "/quotedbl/numbersign/dollar/percent/ampersand" - ++ "/quoteright/parenleft/parenright/asterisk/plus/comma" - ++ "/hyphen/period/slash/zero/one/two/three/four/five" - ++ "/six/seven/eight/nine/colon/semicolon/less/equal" - ++ "/greater/question/at/A/B/C/D/E/F/G/H/I/J/K/L" - ++ "/M/N/O/P/Q/R/S/T/U/V/W/X/Y/Z/bracketleft" - ++ "/backslash/bracketright/asciicircum/underscore" - ++ "/quoteleft/a/b/c/d/e/f/g/h/i/j/k/l/m/n/o/p" - ++ "/q/r/s/t/u/v/w/x/y/z/braceleft/bar/braceright" - ++ "/asciitilde/.notdef/.notdef/.notdef/.notdef/.notdef" - ++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef" - ++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef" - ++ "/dotlessi/grave/acute/circumflex/tilde/macron/breve" - ++ "/dotaccent/dieresis/.notdef/ring/cedilla/.notdef" - ++ "/hungarumlaut/ogonek/caron/space/exclamdown/cent" - ++ "/sterling/currency/yen/brokenbar/section/dieresis" - ++ "/copyright/ordfeminine/guillemotleft/logicalnot/hyphen" - ++ "/registered/macron/degree/plusminus/twosuperior" - ++ "/threesuperior/acute/mu/paragraph/periodcentered" - ++ "/cedilla/onesuperior/ordmasculine/guillemotright" - ++ "/onequarter/onehalf/threequarters/questiondown/Agrave" - ++ "/Aacute/Acircumflex/Atilde/Adieresis/Aring/AE" - ++ "/Ccedilla/Egrave/Eacute/Ecircumflex/Edieresis/Igrave" - ++ "/Iacute/Icircumflex/Idieresis/Eth/Ntilde/Ograve" - ++ "/Oacute/Ocircumflex/Otilde/Odieresis/multiply/Oslash" - ++ "/Ugrave/Uacute/Ucircumflex/Udieresis/Yacute/Thorn" - ++ "/germandbls/agrave/aacute/acircumflex/atilde/adieresis" - ++ "/aring/ae/ccedilla/egrave/eacute/ecircumflex" - ++ "/edieresis/igrave/iacute/icircumflex/idieresis/eth" - ++ "/ntilde/ograve/oacute/ocircumflex/otilde/odieresis" - ++ "/divide/oslash/ugrave/uacute/ucircumflex/udieresis" - ++ "/yacute/thorn/ydieresis]" - -data FontConfig = MkFontConfig - { encoding :: String - , cidFontType :: String - , ordering :: String - , supplement :: String - , wBox :: String - , descriptor :: String - } - -writeFontsShiftJIS :: M [String] -writeFontsShiftJIS = writeFonts fontsShiftJIS $ MkFontConfig - { encoding = "90ms-RKSJ-H" - , cidFontType = "0" - , ordering = "Japan1" - , supplement = "2" - , wBox = "50 500 500" - , descriptor = "/Ascent 723" - ++ "/CapHeight 709" - ++ "/Descent -241" - ++ "/Flags 6" - ++ "/FontBBox[-123 -257 1001 910]" - ++ "/ItalicAngle 0" - ++ "/StemV 69" - ++ "/XHeight 450" - ++ "/Style<>>>>" - } - -writeFontsEUC_JP :: M [String] -writeFontsEUC_JP = writeFonts fontsEUC_JP $ MkFontConfig - { encoding = "EUC-H" - , cidFontType = "0" - , ordering = "Japan1" - , supplement = "2" - , wBox = "50 500 500" - , descriptor = "/Ascent 723" - ++ "/CapHeight 709" - ++ "/Descent -241" - ++ "/Flags 6" - ++ "/FontBBox[-123 -257 1001 910]" - ++ "/ItalicAngle 0" - ++ "/StemV 69" - ++ "/XHeight 450" - ++ "/Style<>>>>" - } - -writeFontsEUC_KR :: M [String] -writeFontsEUC_KR = writeFonts fontsEUC_KR $ MkFontConfig - { encoding = "KSCms-UHC-H/WinCharSet 129" - , cidFontType = "2" - , ordering = "Korea1" - , supplement = "0" - , wBox = "0 1000 500" - , descriptor = "/Flags 7" - ++ "/FontBBox[-100 -142 102 1000]" - ++ "/MissingWidth 500" - ++ "/StemV 91" - ++ "/StemH 91" - ++ "/ItalicAngle 0" - ++ "/CapHeight 858" - ++ "/XHeight 429" - ++ "/Ascent 858" - ++ "/Descent -142" - ++ "/Leading 148" - ++ "/MaxWidth 2" - ++ "/AvgWidth 500" - ++ "/Style<>>" - } - -writeFontsGBK :: M [String] -writeFontsGBK = writeFonts fontsGBK $ MkFontConfig - { encoding = "GB-EUC-H" - , cidFontType = "2" - , ordering = "GB1" - , supplement = "0" - , wBox = "500 1000 500 7716 [500]" - , descriptor = "/FontBBox[0 -199 1000 801]" - ++ "/Flags 6" - ++ "/CapHeight 658" - ++ "/Ascent 801" - ++ "/Descent -199" - ++ "/StemV 56" - ++ "/XHeight 429" - ++ "/ItalicAngle 0" - } - -writeFontsBig5 :: M [String] -writeFontsBig5 = writeFonts fontsBig5 $ MkFontConfig - { encoding = "ETen-B5-H" - , cidFontType = "2" - , ordering = "CNS1" - , supplement = "0" - , wBox = "13500 14000 500" - , descriptor = "/FontBBox[0 -199 1000 801]" - ++ "/Flags 7" - ++ "/CapHeight 0" - ++ "/Ascent 800" - ++ "/Descent -199" - ++ "/StemV 0" - ++ "/ItalicAngle 0" - } - -writeFonts fonts cfg = do - ref <- newRef [] - let addFont o fn = modifyRef ref - (("/F" ++ show fn ++ " " ++ show o ++ " 0 R"):) - markFont fn name = do - markObj $ \obj -> do - addFont obj fn - pr$ "/Type/Font" - ++ "/Subtype/Type0" - ++ "/Name/F" - pr$ show fn ++ "/BaseFont/" - pr$ name ++ "/Encoding/" ++ encoding cfg - pr$ "/DescendantFonts[" ++ show (succ obj) ++ " 0 R]" - markObj $ \obj -> do - pr$ "/Type/Font" - ++ "/Subtype/CIDFontType" - pr$ cidFontType cfg - ++ "/BaseFont/" - pr$ name ++ "/FontDescriptor " ++ show (succ obj) ++ " 0 R" - ++ "/CIDSystemInfo<<" - ++ "/Registry(Adobe)" - ++ "/Ordering(" - pr$ ordering cfg - ++ ")" - ++ "/Supplement " - pr$ supplement cfg - ++ ">>" - ++ "/DW 1000" - ++ "/W[" - pr$ wBox cfg - ++ "]" - printObj $ "/Type/FontDescriptor" - ++ "/FontName/" - ++ takeWhile (/= ',') name - ++ descriptor cfg - mapM_ (uncurry markFont) fonts - readRef ref - -fontFamily :: Int -> String -> [(Int, String)] -fontFamily n f = - [ (n, f) - , (n+1, f ++ ",Italic") - , (n+2, f ++ ",Bold") - , (n+3, f ++ ",BoldItalic") - ] - -fontsEUC_JP :: [(Int, String)] -fontsEUC_JP = fontFamily 20 "HeiseiMin-W3-EUC-H" - -fontsShiftJIS :: [(Int, String)] -fontsShiftJIS = fontFamily 25 "HeiseiMin-W3-90ms-RKSJ-H" - -fontsBig5 :: [(Int, String)] -fontsBig5 = fontFamily 30 "MingLiU" - -fontsGBK :: [(Int, String)] -fontsGBK = fontFamily 35 "STSong" - -fontsEUC_KR :: [(Int, String)] -fontsEUC_KR = fontFamily 40 "#B5#B8#BF#F2#C3#BC" - --- Target size = AFP size / 3 +module Text.LineToPDF ( + module Text.LineToPDF.Internals +) where +import Text.LineToPDF.Internals ( lineToPDF, defaultConfig, AppConfig(..), Encoding(..) ) diff --git a/src/Text/LineToPDF/Internals.hs b/src/Text/LineToPDF/Internals.hs new file mode 100644 --- /dev/null +++ b/src/Text/LineToPDF/Internals.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE ImplicitParams, ExistentialQuantification #-} + +module Text.LineToPDF.Internals where +import Data.IORef +import System.IO +import System.IO.Unsafe +import Control.Applicative +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.IntMap as IM + +{-# NOINLINE __POS__ #-} +__POS__ :: IORef Int +__POS__ = unsafePerformIO (newRef 0) + +{-# NOINLINE __OBJ__ #-} +__OBJ__ :: IORef Int +__OBJ__ = unsafePerformIO (newRef 0) + +{-# NOINLINE __LOC__ #-} +__LOC__ :: IORef (IM.IntMap String) +__LOC__ = unsafePerformIO (newRef IM.empty) + +{-# NOINLINE __PAGE__ #-} +__PAGE__ :: IORef [Obj] +__PAGE__ = unsafePerformIO (newRef []) + +data Encoding + = Latin + | Big5 + | GBK + | EUC_JP + | EUC_KR + | ShiftJIS + +data AppConfig = forall a. MkAppConfig + { pageWidth :: Int + , pageHeight :: Int + , ptSize :: Float + , encodings :: [Encoding] + , srcLines :: [a] + , srcPut :: a -> IO () + , srcEscape :: Char -> a -> a + , srcLength :: a -> Int + , srcHead :: a -> Char + } + +defaultConfig :: Encoding -> L.ByteString -> AppConfig +defaultConfig enc txt = MkAppConfig + { pageWidth = 842 + , pageHeight = 595 + , ptSize = 12 + , encodings = [enc] + , srcLines = L.lines txt + , srcPut = L.putStr + , srcEscape = \ch -> L.intercalate (L.pack ['\\', ch]) . L.split ch + , srcLength = fromEnum . L.length + , srcHead = L.head + } + +type M = IO +type Obj = Int + +lineToPDF :: AppConfig -> IO () +lineToPDF appConfig = do + hSetBinaryMode stdout True + + pr$ "%PDF-1.2\n" ++ "%\xE2\xE3\xCF\xD3\n" + + (info, root, tPages, resources) <- writeHeader $ encodings appConfig + + pageObjs <- let ?tPages = tPages + ?resources = resources in writePages appConfig + + markLocation root + writeObj root $ do + pr$ "/Type/Catalog" ++ "/Pages " + pr$ show tPages ++ " 0 R" + + markLocation tPages + writeObj tPages $ do + pr$ "/Type/Pages" ++ "/Count " + pr$ show (length pageObjs) + ++ "/MediaBox[0 0 " + ++ show (pageWidth appConfig) ++ " " ++ show (pageHeight appConfig) + pr$ "]" ++ "/Kids[" + pr$ concatMap ((++ " 0 R ") . show) pageObjs + pr$ "]" + + xfer <- currentLocation + + objCount <- incrObj + pr$ "xref\n" ++ "0 " ++ show objCount ++ "\n" + ++ "0000000000 65535 f \r" + + writeLocations + + pr$ "trailer\n" ++ "<<" ++ "/Size " + pr$ show objCount + + pr$ "/Root " ++ show root ++ " 0 R" + pr$ "/Info " ++ show info ++ " 0 R" + pr$ ">>\n" ++ "startxref\n" + pr$ show xfer ++ "\n" ++ "%%EOF\n" + +writeObj :: Obj -> M a -> M a +writeObj obj f = do + pr$ show obj ++ " 0 obj" ++ "<<" + rv <- f + pr$ ">>" ++ "endobj\n" + return rv + +writeLocations :: M () +writeLocations = do + locs <- IM.elems <$> readRef __LOC__ + pr$ concatMap fmt locs + where + fmt x = pad ++ x ++ " 00000 n \r" + where + pad = replicate (10-l) '0' + l = length x + +printObj :: String -> M Obj +printObj str = markObj $ (pr str >>) . return + +writeHeader :: [Encoding] -> M (Obj, Obj, Obj, Obj) +writeHeader encs = do + info <- printObj $ "/CreationDate(D:20080707163949+08'00')" + ++ "/Producer(line2pdf.hs)" + ++ "/Title(Untitled)" + encoding <- printObj strDefaultEncoding + latinFonts <- (`mapM` ([1..] `zip` baseFonts)) $ \(n, font) -> do + markObj $ \obj -> do + pr$ "/Type/Font" ++ "/Subtype/Type1" ++ "/Name/F" + pr$ show (n :: Int) + pr$ "/Encoding " ++ show encoding ++ " 0 R" + pr$ font + return $ "/F" ++ show n ++ " " ++ show obj ++ " 0 R" + cjkFonts <- (`mapM` encs) $ \enc -> case enc of + Latin -> return [] + Big5 -> writeFontsBig5 + GBK -> writeFontsGBK + EUC_JP -> writeFontsEUC_JP + EUC_KR -> writeFontsEUC_KR + ShiftJIS -> writeFontsShiftJIS + root <- incrObj + tPages <- incrObj + markObj $ \resources -> do + pr$ "/Font<<" ++ concat latinFonts ++ concat (concat cjkFonts) ++ ">>" + ++ "/ProcSet[/PDF/Text]" ++ "/XObject<<>>" + return (info, root, tPages, resources) + +baseFonts :: [String] +baseFonts = + [ "/BaseFont/Courier" + , "/BaseFont/Courier-Oblique" + , "/BaseFont/Courier-Bold" + , "/BaseFont/Courier-BoldOblique" + , "/BaseFont/Helvetica" + , "/BaseFont/Helvetica-Oblique" + , "/BaseFont/Helvetica-Bold" + , "/BaseFont/Helvetica-BoldOblique" + , "/BaseFont/Times-Roman" + , "/BaseFont/Times-Italic" + , "/BaseFont/Times-Bold" + , "/BaseFont/Times-BoldItalic" + , "/BaseFont/Symbol" + , "/BaseFont/ZapfDingbats" + ] + +pr :: String -> M () +pr str = do + putStr str + modifyRef __POS__ (+ (length str)) + +currentLocation :: IO Int +currentLocation = readRef __POS__ + +newRef :: a -> M (IORef a) +newRef = newIORef + +readRef :: IORef a -> M a +readRef = readIORef + +writeRef :: IORef a -> a -> M () +writeRef = writeIORef + +modifyRef :: IORef a -> (a -> a) -> M () +modifyRef = modifyIORef + +incrObj :: M Obj +incrObj = do + obj <- succ <$> readRef __OBJ__ + writeRef __OBJ__ obj + return obj + +markObj :: (Obj -> M a) -> M a +markObj f = do + obj <- incrObj + markLocation obj + writeObj obj (f obj) + +markLocation :: Obj -> M () +markLocation obj = do + loc <- currentLocation + modifyRef __LOC__ $ IM.insert obj (show loc) + +fontOf :: Encoding -> String +fontOf Latin = "1" +fontOf EUC_JP = "20" +fontOf ShiftJIS = "25" +fontOf Big5 = "30" +fontOf GBK = "35" +fontOf EUC_KR = "40" + +startPage :: (?tPages :: Obj, ?resources :: Obj) => AppConfig -> M Int +startPage MkAppConfig{ pageHeight = height, ptSize = pt, encodings = encs } = do + markObj $ \obj -> do + modifyRef __PAGE__ (obj:) + pr$ "/Type/Page" + pr$ "/Parent " ++ show ?tPages ++ " 0 R" + pr$ "/Resources " ++ show ?resources ++ " 0 R" + pr$ "/Contents " ++ show (succ obj) ++ " 0 R" + pr$ "/Rotate 0" + + obj <- incrObj + markLocation obj + pr$ show obj ++ " 0 obj" ++ "<<" + pr$ "/Length " ++ show (succ obj) ++ " 0 R" + pr$ ">>" ++ "stream\n" + + streamPos <- currentLocation + pr$ "BT\n"; + let font = fontOf $ case encs of + (l:_) -> l + _ -> Latin + pr$ "/F" ++ font ++ " " ++ show pt ++ " Tf\n" + pr$ "1 0 0 1 50 " ++ show (height - 40) ++ " Tm\n" + pr$ show pt ++ " TL\n" + + return streamPos + +endPage :: Int -> M () +endPage streamStart = do + pr$ "ET\n" + streamEnd <- currentLocation + pr$ "endstream\n" + ++ "endobj\n" + + obj <- incrObj + markLocation obj + + pr$ show obj ++ " 0 obj\n" + ++ show (streamEnd - streamStart) ++ "\n" + ++ "endobj\n" + +writePages :: (?tPages :: Obj, ?resources :: Obj) => AppConfig -> M [Obj] +writePages appConfig@MkAppConfig + { srcLength = len + , srcPut = put + , srcHead = hd + , srcLines = lns + , srcEscape = esc + , pageHeight = height + } = do + pos <- newRef =<< startPage appConfig + + (`mapM_` lns) $ \ln -> do + case len ln of + 1 | hd ln == '\f' -> do + endPage =<< readRef pos + writeRef pos =<< startPage appConfig + _ -> do + pr$ "T*(" + let ln' = (esc '(' . esc ')' . esc '\\') ln + put ln' + modifyRef __POS__ (+ len ln') + pr$ ")Tj\n" + + endPage =<< readRef pos + reverse <$> readRef __PAGE__ + +strDefaultEncoding :: String +strDefaultEncoding = "/Type/Encoding" + ++ "/Differences[0 /.notdef/.notdef/.notdef/.notdef" + ++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef" + ++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef" + ++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef" + ++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef" + ++ "/.notdef/.notdef/.notdef/.notdef/space/exclam" + ++ "/quotedbl/numbersign/dollar/percent/ampersand" + ++ "/quoteright/parenleft/parenright/asterisk/plus/comma" + ++ "/hyphen/period/slash/zero/one/two/three/four/five" + ++ "/six/seven/eight/nine/colon/semicolon/less/equal" + ++ "/greater/question/at/A/B/C/D/E/F/G/H/I/J/K/L" + ++ "/M/N/O/P/Q/R/S/T/U/V/W/X/Y/Z/bracketleft" + ++ "/backslash/bracketright/asciicircum/underscore" + ++ "/quoteleft/a/b/c/d/e/f/g/h/i/j/k/l/m/n/o/p" + ++ "/q/r/s/t/u/v/w/x/y/z/braceleft/bar/braceright" + ++ "/asciitilde/.notdef/.notdef/.notdef/.notdef/.notdef" + ++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef" + ++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef" + ++ "/dotlessi/grave/acute/circumflex/tilde/macron/breve" + ++ "/dotaccent/dieresis/.notdef/ring/cedilla/.notdef" + ++ "/hungarumlaut/ogonek/caron/space/exclamdown/cent" + ++ "/sterling/currency/yen/brokenbar/section/dieresis" + ++ "/copyright/ordfeminine/guillemotleft/logicalnot/hyphen" + ++ "/registered/macron/degree/plusminus/twosuperior" + ++ "/threesuperior/acute/mu/paragraph/periodcentered" + ++ "/cedilla/onesuperior/ordmasculine/guillemotright" + ++ "/onequarter/onehalf/threequarters/questiondown/Agrave" + ++ "/Aacute/Acircumflex/Atilde/Adieresis/Aring/AE" + ++ "/Ccedilla/Egrave/Eacute/Ecircumflex/Edieresis/Igrave" + ++ "/Iacute/Icircumflex/Idieresis/Eth/Ntilde/Ograve" + ++ "/Oacute/Ocircumflex/Otilde/Odieresis/multiply/Oslash" + ++ "/Ugrave/Uacute/Ucircumflex/Udieresis/Yacute/Thorn" + ++ "/germandbls/agrave/aacute/acircumflex/atilde/adieresis" + ++ "/aring/ae/ccedilla/egrave/eacute/ecircumflex" + ++ "/edieresis/igrave/iacute/icircumflex/idieresis/eth" + ++ "/ntilde/ograve/oacute/ocircumflex/otilde/odieresis" + ++ "/divide/oslash/ugrave/uacute/ucircumflex/udieresis" + ++ "/yacute/thorn/ydieresis]" + +data FontConfig = MkFontConfig + { encoding :: String + , cidFontType :: String + , ordering :: String + , supplement :: String + , wBox :: String + , descriptor :: String + } + +writeFontsShiftJIS :: M [String] +writeFontsShiftJIS = writeFonts fontsShiftJIS $ MkFontConfig + { encoding = "90ms-RKSJ-H" + , cidFontType = "0" + , ordering = "Japan1" + , supplement = "2" + , wBox = "50 500 500" + , descriptor = "/Ascent 723" + ++ "/CapHeight 709" + ++ "/Descent -241" + ++ "/Flags 6" + ++ "/FontBBox[-123 -257 1001 910]" + ++ "/ItalicAngle 0" + ++ "/StemV 69" + ++ "/XHeight 450" + ++ "/Style<>>>>" + } + +writeFontsEUC_JP :: M [String] +writeFontsEUC_JP = writeFonts fontsEUC_JP $ MkFontConfig + { encoding = "EUC-H" + , cidFontType = "0" + , ordering = "Japan1" + , supplement = "2" + , wBox = "50 500 500" + , descriptor = "/Ascent 723" + ++ "/CapHeight 709" + ++ "/Descent -241" + ++ "/Flags 6" + ++ "/FontBBox[-123 -257 1001 910]" + ++ "/ItalicAngle 0" + ++ "/StemV 69" + ++ "/XHeight 450" + ++ "/Style<>>>>" + } + +writeFontsEUC_KR :: M [String] +writeFontsEUC_KR = writeFonts fontsEUC_KR $ MkFontConfig + { encoding = "KSCms-UHC-H/WinCharSet 129" + , cidFontType = "2" + , ordering = "Korea1" + , supplement = "0" + , wBox = "0 1000 500" + , descriptor = "/Flags 7" + ++ "/FontBBox[-100 -142 102 1000]" + ++ "/MissingWidth 500" + ++ "/StemV 91" + ++ "/StemH 91" + ++ "/ItalicAngle 0" + ++ "/CapHeight 858" + ++ "/XHeight 429" + ++ "/Ascent 858" + ++ "/Descent -142" + ++ "/Leading 148" + ++ "/MaxWidth 2" + ++ "/AvgWidth 500" + ++ "/Style<>>" + } + +writeFontsGBK :: M [String] +writeFontsGBK = writeFonts fontsGBK $ MkFontConfig + { encoding = "GB-EUC-H" + , cidFontType = "2" + , ordering = "GB1" + , supplement = "0" + , wBox = "500 1000 500 7716 [500]" + , descriptor = "/FontBBox[0 -199 1000 801]" + ++ "/Flags 6" + ++ "/CapHeight 658" + ++ "/Ascent 801" + ++ "/Descent -199" + ++ "/StemV 56" + ++ "/XHeight 429" + ++ "/ItalicAngle 0" + } + +writeFontsBig5 :: M [String] +writeFontsBig5 = writeFonts fontsBig5 $ MkFontConfig + { encoding = "ETen-B5-H" + , cidFontType = "2" + , ordering = "CNS1" + , supplement = "0" + , wBox = "13500 14000 500" + , descriptor = "/FontBBox[0 -199 1000 801]" + ++ "/Flags 7" + ++ "/CapHeight 0" + ++ "/Ascent 800" + ++ "/Descent -199" + ++ "/StemV 0" + ++ "/ItalicAngle 0" + } + +writeFonts fonts cfg = do + ref <- newRef [] + let addFont o fn = modifyRef ref + (("/F" ++ show fn ++ " " ++ show o ++ " 0 R"):) + markFont fn name = do + markObj $ \obj -> do + addFont obj fn + pr$ "/Type/Font" + ++ "/Subtype/Type0" + ++ "/Name/F" + pr$ show fn ++ "/BaseFont/" + pr$ name ++ "/Encoding/" ++ encoding cfg + pr$ "/DescendantFonts[" ++ show (succ obj) ++ " 0 R]" + markObj $ \obj -> do + pr$ "/Type/Font" + ++ "/Subtype/CIDFontType" + pr$ cidFontType cfg + ++ "/BaseFont/" + pr$ name ++ "/FontDescriptor " ++ show (succ obj) ++ " 0 R" + ++ "/CIDSystemInfo<<" + ++ "/Registry(Adobe)" + ++ "/Ordering(" + pr$ ordering cfg + ++ ")" + ++ "/Supplement " + pr$ supplement cfg + ++ ">>" + ++ "/DW 1000" + ++ "/W[" + pr$ wBox cfg + ++ "]" + printObj $ "/Type/FontDescriptor" + ++ "/FontName/" + ++ takeWhile (/= ',') name + ++ descriptor cfg + mapM_ (uncurry markFont) fonts + readRef ref + +fontFamily :: Int -> String -> [(Int, String)] +fontFamily n f = + [ (n, f) + , (n+1, f ++ ",Italic") + , (n+2, f ++ ",Bold") + , (n+3, f ++ ",BoldItalic") + ] + +fontsEUC_JP :: [(Int, String)] +fontsEUC_JP = fontFamily 20 "HeiseiMin-W3-EUC-H" + +fontsShiftJIS :: [(Int, String)] +fontsShiftJIS = fontFamily 25 "HeiseiMin-W3-90ms-RKSJ-H" + +fontsBig5 :: [(Int, String)] +fontsBig5 = fontFamily 30 "MingLiU" + +fontsGBK :: [(Int, String)] +fontsGBK = fontFamily 35 "STSong" + +fontsEUC_KR :: [(Int, String)] +fontsEUC_KR = fontFamily 40 "#B5#B8#BF#F2#C3#BC" + +-- Target size = AFP size / 3