OpenAFP-Utils 1.2 → 1.2.1
raw patch · 14 files changed
+89/−883 lines, 14 files
Files
- LICENSE +1/−1
- OpenAFP-Utils.cabal +43/−49
- afp-dump.hs +2/−0
- afp-page.hs +2/−0
- afp-replace.hs +1/−0
- afp-scanudc.hs +2/−0
- afp-split-scb.hs +2/−0
- afp-split-tcb.hs +2/−0
- afp-split.hs +2/−0
- afp-type.hs +2/−0
- afp-udcfix.hs +2/−0
- afp-validate.hs +2/−0
- afp2line.hs +26/−30
- afp2line2pdf.hs +0/−803
LICENSE view
@@ -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
OpenAFP-Utils.cabal view
@@ -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
afp-dump.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS -O -fglasgow-exts -funbox-strict-fields -fimplicit-params #-}+ module Main where import Text.XHtml import Codec.Text.UConv
afp-page.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS -O -fglasgow-exts #-}+ module Main where import OpenAFP import System.Exit
afp-replace.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, PatternGuards #-} module Main where import OpenAFP import qualified Data.ByteString.Lazy as L
afp-scanudc.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS -O -fglasgow-exts -funbox-strict-fields -fbang-patterns #-}+ module Main where import OpenAFP import System.Mem
afp-split-scb.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS -O -fglasgow-exts #-}+ module Main where import OpenAFP import System.Exit
afp-split-tcb.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS -O -fglasgow-exts #-}+ module Main where import OpenAFP import System.Exit
afp-split.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS -O -fglasgow-exts #-}+ module Main where import OpenAFP import System.Exit
afp-type.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS -O -fglasgow-exts #-}+ module Main where import OpenAFP
afp-udcfix.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS -O -fglasgow-exts -funbox-strict-fields #-}+ module Main where import OpenAFP import qualified Data.Map as Map
afp-validate.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS -O -fglasgow-exts #-}+ module Main where import OpenAFP import System.Exit
afp2line.hs view
@@ -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)
− afp2line2pdf.hs
@@ -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<</Panose<010502020400000000000000>>>>>"- }--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<</Panose<000000400000000000000000>>>"- }--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