diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2004-2008 by Audrey Tang +The "MIT" License Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/OpenAFP-Utils.cabal b/OpenAFP-Utils.cabal --- a/OpenAFP-Utils.cabal +++ b/OpenAFP-Utils.cabal @@ -1,5 +1,5 @@ Name: OpenAFP-Utils -Version: 1.2 +Version: 1.2.1 License: BSD3 License-file: LICENSE Author: Audrey Tang @@ -8,64 +8,58 @@ Description: Assorted utilities to work with AFP data streams Category: Data Build-type: Simple -Cabal-Version : >= 1.2 -Executable afp2line2pdf - Main-is: afp2line2pdf.hs - Build-depends: OpenAFP, haskell98, base - Extensions: StandaloneDeriving, GeneralizedNewtypeDeriving, ImplicitParams, - ExistentialQuantification, PatternGuards +Executable: afp-dump +Main-is: afp-dump.hs +Build-depends: OpenAFP, haskell98, base, bytestring, containers, uconv, xhtml +Extensions: DeriveDataTypeable, PatternGuards -Executable afp-olndump - Main-is: afp-olndump.hs - Build-depends: OpenAFP, haskell98, base, bytestring, containers, binary +Executable: afp-page +Main-is: afp-page.hs +Build-depends: OpenAFP, haskell98, base -Executable afp-dump - Main-is: afp-dump.hs - Build-depends: OpenAFP, haskell98, base, bytestring, containers, uconv, xhtml - Extensions: DeriveDataTypeable, PatternGuards +Executable: afp-replace +Main-is: afp-replace.hs +Build-depends: OpenAFP, haskell98, base +Extensions: DeriveDataTypeable, FlexibleContexts, PatternGuards -Executable afp-page - Main-is: afp-page.hs - Build-depends: OpenAFP, haskell98, base +Executable: afp-scanudc +Main-is: afp-scanudc.hs +Build-depends: OpenAFP, haskell98, base, directory +Extensions: BangPatterns -Executable afp-replace - Main-is: afp-replace.hs - Build-depends: OpenAFP, haskell98, base - Extensions: DeriveDataTypeable, FlexibleContexts, PatternGuards +Executable: afp-split +Main-is: afp-split.hs +Build-depends: OpenAFP, haskell98, base -Executable afp-scanudc - Main-is: afp-scanudc.hs - Build-depends: OpenAFP, haskell98, base, directory - Extensions: BangPatterns, PatternGuards +Executable: afp-split-scb +Main-is: afp-split-scb.hs +Build-depends: OpenAFP, haskell98, base -Executable afp-split - Main-is: afp-split.hs - Build-depends: OpenAFP, haskell98, base +Executable: afp-split-tcb +Main-is: afp-split-tcb.hs +Build-depends: OpenAFP, haskell98, base, filepath +Extensions: ImplicitParams -Executable afp-split-scb - Main-is: afp-split-scb.hs - Build-depends: OpenAFP, haskell98, base +Executable: afp-type +Main-is: afp-type.hs +Build-depends: OpenAFP, haskell98, base -Executable afp-split-tcb - Main-is: afp-split-tcb.hs - Build-depends: OpenAFP, haskell98, base, filepath - Extensions: ImplicitParams +Executable: afp-udcfix +Main-is: afp-udcfix.hs +Build-depends: OpenAFP, haskell98, base, regex-base, regex-posix +Extensions: DeriveDataTypeable, MultiParamTypeClasses, FlexibleContexts -Executable afp-type - Main-is: afp-type.hs - Build-depends: OpenAFP, haskell98, base +Executable: afp-validate +Main-is: afp-validate.hs +Build-depends: OpenAFP, haskell98, base -Executable afp-udcfix - Main-is: afp-udcfix.hs - Build-depends: OpenAFP, haskell98, base, regex-base, regex-posix - Extensions: DeriveDataTypeable, MultiParamTypeClasses, FlexibleContexts, PatternGuards +Executable: afp2line +Main-is: afp2line.hs +Build-depends: OpenAFP, haskell98, base +Extensions: GeneralizedNewtypeDeriving -Executable afp-validate - Main-is: afp-validate.hs - Build-depends: OpenAFP, haskell98, base +Executable: afp-olndump +Main-is: afp-olndump.hs +Build-depends: OpenAFP, haskell98, base, bytestring, containers, binary -Executable afp2line - Main-is: afp2line.hs - Build-depends: OpenAFP, haskell98, base - Extensions: GeneralizedNewtypeDeriving diff --git a/afp-dump.hs b/afp-dump.hs --- a/afp-dump.hs +++ b/afp-dump.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -O -fglasgow-exts -funbox-strict-fields -fimplicit-params #-} + module Main where import Text.XHtml import Codec.Text.UConv diff --git a/afp-page.hs b/afp-page.hs --- a/afp-page.hs +++ b/afp-page.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -O -fglasgow-exts #-} + module Main where import OpenAFP import System.Exit diff --git a/afp-replace.hs b/afp-replace.hs --- a/afp-replace.hs +++ b/afp-replace.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, PatternGuards #-} module Main where import OpenAFP import qualified Data.ByteString.Lazy as L diff --git a/afp-scanudc.hs b/afp-scanudc.hs --- a/afp-scanudc.hs +++ b/afp-scanudc.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -O -fglasgow-exts -funbox-strict-fields -fbang-patterns #-} + module Main where import OpenAFP import System.Mem diff --git a/afp-split-scb.hs b/afp-split-scb.hs --- a/afp-split-scb.hs +++ b/afp-split-scb.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -O -fglasgow-exts #-} + module Main where import OpenAFP import System.Exit diff --git a/afp-split-tcb.hs b/afp-split-tcb.hs --- a/afp-split-tcb.hs +++ b/afp-split-tcb.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -O -fglasgow-exts #-} + module Main where import OpenAFP import System.Exit diff --git a/afp-split.hs b/afp-split.hs --- a/afp-split.hs +++ b/afp-split.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -O -fglasgow-exts #-} + module Main where import OpenAFP import System.Exit diff --git a/afp-type.hs b/afp-type.hs --- a/afp-type.hs +++ b/afp-type.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -O -fglasgow-exts #-} + module Main where import OpenAFP diff --git a/afp-udcfix.hs b/afp-udcfix.hs --- a/afp-udcfix.hs +++ b/afp-udcfix.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -O -fglasgow-exts -funbox-strict-fields #-} + module Main where import OpenAFP import qualified Data.Map as Map diff --git a/afp-validate.hs b/afp-validate.hs --- a/afp-validate.hs +++ b/afp-validate.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -O -fglasgow-exts #-} + module Main where import OpenAFP import System.Exit diff --git a/afp2line.hs b/afp2line.hs --- a/afp2line.hs +++ b/afp2line.hs @@ -1,24 +1,25 @@ +{-# OPTIONS_GHC -O2 -fglasgow-exts #-} + module Main where import OpenAFP import Data.Monoid +import System.Posix.Resource import qualified Data.IntMap as IM import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as S import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Char8 as C --- --- import System.Posix.Resource --- --- __1GB__ :: Integer --- __1GB__ = 1024 * 1024 * 1024 --- --- mkLimit :: Integer -> ResourceLimits --- mkLimit x = ResourceLimits (ResourceLimit x) (ResourceLimit x) --- + +__1GB__ :: Integer +__1GB__ = 1024 * 1024 * 1024 + +mkLimit :: Integer -> ResourceLimits +mkLimit x = ResourceLimits (ResourceLimit x) (ResourceLimit x) + main :: IO () main = do - -- setResourceLimit ResourceTotalMemory (mkLimit __1GB__) - -- setResourceLimit ResourceCoreFileSize (mkLimit 0) + setResourceLimit ResourceTotalMemory (mkLimit __1GB__) + setResourceLimit ResourceCoreFileSize (mkLimit 0) hSetBinaryMode stdout True args <- getArgs @@ -154,27 +155,22 @@ ptxGroupDump :: [PTX_] -> IO () ptxGroupDump (scfl:cs) = do let scflId = ptx_scfl (decodeChunk scfl) - curEncoding <- lookupFontEncoding scflId cs ..> - [ _PTX_TRN ... \trn -> do - when (ptx_scfl (decodeChunk scfl) == 2) $ do - hPrint stderr (ptx_trn trn) - case curEncoding of - Just CP37 -> let bstr = packAStr' (ptx_trn trn) in do - insertText bstr - modifyIORef _CurrentColumn (+ S.length bstr) - Just CP835 -> pack835 (ptx_trn trn) >>= \bstr -> do - insertText bstr - modifyIORef _CurrentColumn (+ S.length bstr) - Just CP939 -> pack939 (ptx_trn trn) >>= \bstr -> do - C.hPut stderr bstr - insertText bstr - modifyIORef _CurrentColumn (+ S.length bstr) - Just CP950 -> let bstr = packBuf (ptx_trn trn) in do - insertText bstr - modifyIORef _CurrentColumn (+ S.length bstr) - _ -> fail "TRN without SCFL?" + [ _PTX_TRN ... \trn -> case curEncoding of + Just CP37 -> let bstr = packAStr' (ptx_trn trn) in do + insertText bstr + modifyIORef _CurrentColumn (+ S.length bstr) + Just CP835 -> pack835 (ptx_trn trn) >>= \bstr -> do + insertText bstr + modifyIORef _CurrentColumn (+ S.length bstr) + Just CP939 -> pack939 (ptx_trn trn) >>= \bstr -> do + insertText bstr + modifyIORef _CurrentColumn (+ S.length bstr) + Just CP950 -> let bstr = packBuf (ptx_trn trn) in do + insertText bstr + modifyIORef _CurrentColumn (+ S.length bstr) + _ -> fail "TRN without SCFL?" , _PTX_BLN ... \_ -> do writeIORef _CurrentColumn 0 modifyIORef _CurrentLine (+1) diff --git a/afp2line2pdf.hs b/afp2line2pdf.hs deleted file mode 100644 --- a/afp2line2pdf.hs +++ /dev/null @@ -1,803 +0,0 @@ -{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImplicitParams, ExistentialQuantification #-} - -module Main where -import OpenAFP -import Control.Applicative -import System.Exit -import System.Environment --- import System.Posix.Resource -import qualified Data.ByteString as S -import qualified Data.ByteString.Unsafe as S -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Char8 as C - -{- LINE2PDF -} -import Data.IORef -import System.IO -import System.IO.Unsafe -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.IntMap as IM -{- END LINE2PDF -} - -deriving instance Eq Encoding -deriving instance Ord Encoding - -__1GB__ :: Integer -__1GB__ = 1024 * 1024 * 1024 - --- mkLimit :: Integer -> ResourceLimits --- mkLimit x = ResourceLimits (ResourceLimit x) (ResourceLimit x) - -main :: IO () -main = do - -- setResourceLimit ResourceTotalMemory (mkLimit __1GB__) - -- setResourceLimit ResourceCoreFileSize (mkLimit 0) - - hSetBinaryMode stdout True - args <- getArgs - when (null args) $ do - putStrLn "Usage: afp2line2pdf input.afp > output.pdf" - forM_ args $ \f -> do - ft <- guessFileType f - processFile ft f - -data FileType = F_ASCII | F_EBCDIC | F_AFP | F_PDF | F_Unknown deriving Show - -guessFileType :: FilePath -> IO FileType -guessFileType fn = do - fh <- openBinaryFile fn ReadMode - bs <- S.hGet fh 1 - hClose fh - return $ if S.null bs then F_Unknown else case C.head bs of - 'Z' -> F_AFP - '%' -> F_PDF - '1' -> F_ASCII - '0' -> F_ASCII - ' ' -> F_ASCII - '\xF0' -> F_EBCDIC - '\xF1' -> F_EBCDIC - '@' -> F_EBCDIC - _ -> F_Unknown - -imageChunkTypes :: [ChunkType] -imageChunkTypes = - [ chunkTypeOf _BII - , chunkTypeOf _BIM - , chunkTypeOf _MIO - , chunkTypeOf _IRD - , chunkTypeOf _IPD - ] - -_blank1, _blank2 :: C.ByteString -_blank1 = C.pack "BLANK" -_blank2 = C.pack "BLN" - -isBlank :: [AFP_] -> Bool -isBlank cs = case find (~~ _BR) cs of - Just c -> let str = S.drop 2 (packAStr $ br (decodeChunk c)) in - (_blank1 `S.isPrefixOf` str) || (_blank2 `S.isPrefixOf` str) - _ -> False - -processFile :: FileType -> FilePath -> IO () -processFile F_ASCII _ = do - -- ...Look at each line's first byte to determine what to output... - return () -processFile F_AFP f = do - -- Read the first byte to determine its file type: - -- '1' indicates ASCII Plain Text line data - -- '\xF1' indicates EBCDIC line data - -- 'Z' indicates AFP file - -- '%' indicates PDF file - cs <- readAFP f - - env <- getEnvironment - case lookup "AFP2PDF2LINE_SKIP_IMAGE" env of - Just "1" -> return () - _ | not (isBlank cs), any ((`elem` imageChunkTypes) . chunkType) cs -> do - -- We can't process image data, sorry. - exitWith (ExitFailure 1) - _ -> return () - - hSetBinaryMode stdout True - pr$ "%PDF-1.2\n" ++ "%\xE2\xE3\xCF\xD3\n" - (info, root, tPages, resources) <- writeHeader [Latin, TraditionalChinese, Japanese] - - forM_ (filter (~~ _PGD) cs) $ \c -> do - let pgd = decodeChunk c - xSize = toPt $ pgd_XPageSize pgd - ySize = toPt $ pgd_YPageSize pgd - modifyIORef __MAX_WIDTH__ (max xSize) - modifyIORef __MAX_HEIGHT__ (max ySize) - - modifyIORef __MAX_WIDTH__ (+30) - modifyIORef __MAX_HEIGHT__ (+30) - - forM_ (tail $ splitRecords _BPG cs) $ \pageChunks -> do - -- Start page - 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" - - streamStart <- currentLocation - pr$ "BT\n"; - - pageChunks ..> - [ _PTX ... ptxDump - , _MCF ... mcfHandler - , _MCF1 ... mcf1Handler - ] - - -- End Page - 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" - - pageObjs <-reverse <$> readRef __PAGE__ - markLocation root - writeObj root $ do - pr$ "/Type/Catalog" ++ "/Pages " - pr$ show tPages ++ " 0 R" - - maxPageWidth <- readIORef __MAX_WIDTH__ - maxPageHeight <- readIORef __MAX_HEIGHT__ - - markLocation tPages - writeObj tPages $ do - pr$ "/Type/Pages" ++ "/Count " - pr$ show (length pageObjs) - ++ "/MediaBox[0 0 " - ++ show maxPageWidth ++ " " ++ show maxPageHeight - 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" - -processFile t f = warn $ "Unknown file type: " ++ show t ++ " (" ++ f ++ ")" - -{-# NOINLINE __MAX_WIDTH__ #-} -__MAX_WIDTH__ :: IORef Float -__MAX_WIDTH__ = unsafePerformIO $ newIORef 0 - -{-# NOINLINE __MAX_HEIGHT__ #-} -__MAX_HEIGHT__ :: IORef Float -__MAX_HEIGHT__ = unsafePerformIO $ newIORef 0 - -{-# NOINLINE _CurrentLine #-} -_CurrentLine :: IORef Float -_CurrentLine = unsafePerformIO $ newIORef 0 - -{-# NOINLINE _CurrentColumn #-} -_CurrentColumn :: IORef Float -_CurrentColumn = unsafePerformIO $ newIORef 0 - -{-# NOINLINE _MaxColumn #-} -_MaxColumn :: IORef Int -_MaxColumn = unsafePerformIO $ newIORef 0 - -{-# NOINLINE _MaxLine #-} -_MaxLine :: IORef Int -_MaxLine = unsafePerformIO $ newIORef 0 - -{-# NOINLINE _MaxEncoding #-} -_MaxEncoding :: IORef Encoding -_MaxEncoding = unsafePerformIO $ newIORef CP37 - -{-# NOINLINE _MinFontSize #-} -_MinFontSize :: IORef Size -_MinFontSize = unsafePerformIO $ newIORef 12 - -lookupFontEncoding :: N1 -> IO (Maybe Encoding) -lookupFontEncoding = hashLookup _FontToEncoding - -insertFonts :: [(N1, ByteString)] -> IO () -insertFonts = mapM_ $ \(i, f) -> do - let (enc, sz) = fontInfoOf f - modifyIORef _MinFontSize $ \szMin -> case szMin of - 0 -> sz - _ -> min szMin sz - modifyIORef _MaxEncoding (max enc) - hashInsert _FontToEncoding i enc - -{-# NOINLINE _FontToEncoding #-} -_FontToEncoding :: HashTable N1 Encoding -_FontToEncoding = unsafePerformIO $ hashNew (==) fromIntegral - --- | Record font Id to Name mappings in MCF's RLI and FQN chunks. -mcfHandler :: MCF -> IO () -mcfHandler r = do - readChunks r ..> - [ _MCF_T ... \mcf -> do - let cs = readChunks mcf - ids = [ t_rli (decodeChunk c) | c <- cs, c ~~ _T_RLI ] - fonts = [ t_fqn (decodeChunk c) | c <- cs, c ~~ _T_FQN ] - insertFonts (ids `zip` map packAStr fonts) - ] - --- | Record font Id to Name mappings in MCF1's Data chunks. -mcf1Handler :: MCF1 -> IO () -mcf1Handler r = do - insertFonts - [ (mcf1_CodedFontLocalId mcf1, packA8 $ mcf1_CodedFontName mcf1) - | Record mcf1 <- readData r - ] - -encToLang :: Encoding -> Language -encToLang CP37 = Latin -encToLang CP835 = TraditionalChinese -encToLang CP939 = Japanese -encToLang CP950 = TraditionalChinese - -ptxDump :: PTX -> IO () -ptxDump ptx = mapM_ ptxGroupDump . splitRecords _PTX_SCFL $ readChunks ptx - -ptxGroupDump :: [PTX_] -> IO () -ptxGroupDump (scfl:cs) | scfl ~~ _PTX_SCFL = do - let scflId = ptx_scfl (decodeChunk scfl) - - rv <- lookupFontEncoding scflId - case rv of - Nothing -> return () - Just curEncoding -> do - height <- readIORef __MAX_HEIGHT__ - curSize <- readIORef _MinFontSize - let display (lang, getBStr) = do - font <- case lang of - Latin -> do - (fontOf . encToLang) <$> readIORef _MaxEncoding - _ -> return (fontOf lang) - pr$ "/F" ++ font ++ " " ++ show curSize ++ " Tf\n" - pr$ show curSize ++ " TL\n" - col <- readIORef _CurrentColumn - ln <- readIORef _CurrentLine - pr$ "1 0 0 1 " ++ show (col + 25) ++ " " ++ show (height - ln - 25) ++ " Tm(" - let escape ch = C.intercalate (C.pack ['\\', ch]) . C.split ch - escapeTxt = escape '(' . escape ')' . escape '\\' - bstr <- escapeTxt <$> getBStr - C.putStr bstr - let len = S.length bstr - modifyRef __POS__ (+ len) - pr$ ")Tj\n" - modifyIORef _CurrentColumn (+ (realToFrac (len * curSize) * 0.5)) - cs ..> - [ _PTX_TRN ... \trn -> display $ case curEncoding of - CP37 -> (Latin, return $ packAStr' (ptx_trn trn)) - CP835 -> (TraditionalChinese, pack835 (ptx_trn trn)) - CP939 -> (Japanese, pack939 (ptx_trn trn)) - CP950 -> (TraditionalChinese, return $ packBuf (ptx_trn trn)) - , _PTX_BLN ... \_ -> do - writeIORef _CurrentColumn 0 -- XXX - modifyIORef _CurrentLine (+ realToFrac curSize) - , _PTX_AMB ... \x -> do - -- hPrint stderr ("AMB", fromEnum $ ptx_amb x) - movePosition Absolute _CurrentLine . ptx_amb $ x - , _PTX_RMB ... \x -> do - -- hPrint stderr ("RMB", fromEnum $ ptx_rmb x) - movePosition Relative _CurrentLine . ptx_rmb $ x - , _PTX_AMI ... movePosition Absolute _CurrentColumn . ptx_ami - , _PTX_RMI ... movePosition Relative _CurrentColumn . ptx_rmi - ] -ptxGroupDump _ = return () - -data Position = Absolute | Relative - -movePosition :: Position -> IORef Float -> N2 -> IO () -movePosition p ref n = do - case p of - Absolute -> writeIORef ref (toPt n) - Relative -> modifyIORef ref (+ (toPt n)) - - -toPt :: Enum a => a -> Float -toPt x = realToFrac (fromEnum x) * 0.3 - -packAStr' :: AStr -> S.ByteString -packAStr' astr = S.map (ebc2ascIsPrintW8 !) (packBuf astr) - -{-# INLINE pack835 #-} -{-# INLINE pack939 #-} -pack835, pack939 :: NStr -> IO S.ByteString -pack835 = packWith convert835to950 -pack939 = packWith convert939to932 - -{-# INLINE packWith #-} -packWith :: (Int -> Int) -> NStr -> IO S.ByteString -packWith f nstr = S.unsafeUseAsCStringLen (packBuf nstr) $ \(src, len) -> S.create len $ \target -> do - let s = castPtr src - let t = castPtr target - forM_ [0..(len `div` 2)-1] $ \i -> do - hi <- peekByteOff s (i*2) :: IO Word8 - lo <- peekByteOff s (i*2+1) :: IO Word8 - let ch = f (fromEnum hi * 256 + fromEnum lo) - (hi', lo') = ch `divMod` 256 - pokeByteOff t (i*2) (toEnum hi' :: Word8) - pokeByteOff t (i*2+1) (toEnum lo' :: Word8) - --------------- - - -{-# 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 Language - = Latin - | TraditionalChinese - | SimplifiedChinese - | Japanese - | Korean - -data AppConfig = forall a. MkAppConfig - { pageWidth :: Int - , pageHeight :: Int - , ptSize :: Float - , languages :: [Language] - , srcLines :: [a] - , srcPut :: a -> IO () - , srcLength :: a -> Int - , srcHead :: a -> Char - } - -defaultConfig :: Language -> L.ByteString -> AppConfig -defaultConfig lang txt = MkAppConfig - { pageWidth = 842 - , pageHeight = 595 - , ptSize = 12 - , languages = [lang] - , srcLines = L.lines txt - , srcPut = L.putStr - , 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 $ languages 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 :: [Language] -> M (Obj, Obj, Obj, Obj) -writeHeader langs = 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` langs) $ \lang -> case lang of - Latin -> return [] - TraditionalChinese -> writeTradChineseFonts - SimplifiedChinese -> writeSimpChineseFonts - Japanese -> writeJapaneseFonts - Korean -> writeKoreanFonts - 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 :: Language -> String -fontOf Latin = "1" -fontOf TraditionalChinese = "30" -fontOf SimplifiedChinese = "35" -fontOf Japanese = "20" -fontOf Korean = "40" - -startPage :: (?tPages :: Obj, ?resources :: Obj) => AppConfig -> M Int -startPage MkAppConfig{ pageHeight = height, ptSize = pt, languages = langs } = 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 langs 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 - , pageHeight = height - } = do - pos <- newRef =<< startPage appConfig - - (`mapM_` lns) $ \ln -> do - case fromEnum (len ln) of - 1 | hd ln == '\f' -> do - endPage =<< readRef pos - writeRef pos =<< startPage appConfig - len -> do - pr$ "T*(" - put ln - modifyRef __POS__ (+ len) - 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 - } - -writeJapaneseFonts :: M [String] -writeJapaneseFonts = writeFonts japaneseFonts $ MkFontConfig --- { encoding = "EUC-H" - { 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<>>>>" - } - -writeKoreanFonts :: M [String] -writeKoreanFonts = writeFonts koreanFonts $ 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<>>" - } - -writeSimpChineseFonts :: M [String] -writeSimpChineseFonts = writeFonts simpChineseFonts $ 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" - } - -writeTradChineseFonts :: M [String] -writeTradChineseFonts = writeFonts tradChineseFonts $ 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") - ] - -japaneseFonts :: [(Int, String)] -japaneseFonts = concatMap (uncurry fontFamily) --- [ (20, "HeiseiMin-W3-EUC-H") - [ (20, "HeiseiMin-W3-90ms-RKSJ-H") --- , (24, "HeiseiKakuGo-W5-EUC-H") - ] - -tradChineseFonts :: [(Int, String)] -tradChineseFonts = fontFamily 30 "MingLiU" - -simpChineseFonts :: [(Int, String)] -simpChineseFonts = fontFamily 35 "STSong" - -koreanFonts :: [(Int, String)] -koreanFonts = fontFamily 40 "#B5#B8#BF#F2#C3#BC" - --- Target size = AFP size / 3