{-# 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