OpenAFP-Utils 1.1 → 1.2
raw patch · 4 files changed
+974/−54 lines, 4 filesdep +binarynew-component:exe:afp-olndumpnew-component:exe:afp2line2pdf
Dependencies added: binary
Files
- OpenAFP-Utils.cabal +51/−40
- afp-olndump.hs +101/−0
- afp2line.hs +19/−14
- afp2line2pdf.hs +803/−0
OpenAFP-Utils.cabal view
@@ -1,5 +1,5 @@ Name: OpenAFP-Utils-Version: 1.1+Version: 1.2 License: BSD3 License-file: LICENSE Author: Audrey Tang@@ -8,53 +8,64 @@ Description: Assorted utilities to work with AFP data streams Category: Data Build-type: Simple+Cabal-Version : >= 1.2 -Executable: afp-dump-Main-is: afp-dump.hs-Build-depends: OpenAFP, haskell98, base, bytestring, containers, uconv, xhtml-Extensions: DeriveDataTypeable, PatternGuards+Executable afp2line2pdf+ Main-is: afp2line2pdf.hs+ Build-depends: OpenAFP, haskell98, base+ Extensions: StandaloneDeriving, GeneralizedNewtypeDeriving, ImplicitParams,+ ExistentialQuantification, PatternGuards -Executable: afp-page-Main-is: afp-page.hs-Build-depends: OpenAFP, haskell98, base+Executable afp-olndump+ Main-is: afp-olndump.hs+ Build-depends: OpenAFP, haskell98, base, bytestring, containers, binary -Executable: afp-replace-Main-is: afp-replace.hs-Build-depends: OpenAFP, haskell98, base-Extensions: DeriveDataTypeable, FlexibleContexts, PatternGuards+Executable afp-dump+ Main-is: afp-dump.hs+ Build-depends: OpenAFP, haskell98, base, bytestring, containers, uconv, xhtml+ Extensions: DeriveDataTypeable, PatternGuards -Executable: afp-scanudc-Main-is: afp-scanudc.hs-Build-depends: OpenAFP, haskell98, base, directory-Extensions: BangPatterns+Executable afp-page+ Main-is: afp-page.hs+ Build-depends: OpenAFP, haskell98, base -Executable: afp-split-Main-is: afp-split.hs-Build-depends: OpenAFP, haskell98, base+Executable afp-replace+ Main-is: afp-replace.hs+ Build-depends: OpenAFP, haskell98, base+ Extensions: DeriveDataTypeable, FlexibleContexts, PatternGuards -Executable: afp-split-scb-Main-is: afp-split-scb.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-tcb-Main-is: afp-split-tcb.hs-Build-depends: OpenAFP, haskell98, base, filepath-Extensions: ImplicitParams+Executable afp-split+ Main-is: afp-split.hs+ Build-depends: OpenAFP, haskell98, base -Executable: afp-type-Main-is: afp-type.hs-Build-depends: OpenAFP, haskell98, base+Executable afp-split-scb+ Main-is: afp-split-scb.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+Executable afp-split-tcb+ Main-is: afp-split-tcb.hs+ Build-depends: OpenAFP, haskell98, base, filepath+ Extensions: ImplicitParams -Executable: afp-validate-Main-is: afp-validate.hs-Build-depends: OpenAFP, haskell98, base+Executable afp-type+ Main-is: afp-type.hs+ Build-depends: OpenAFP, haskell98, base -Executable: afp2line-Main-is: afp2line.hs-Build-depends: OpenAFP, haskell98, base-Extensions: GeneralizedNewtypeDeriving +Executable afp-udcfix+ Main-is: afp-udcfix.hs+ Build-depends: OpenAFP, haskell98, base, regex-base, regex-posix+ Extensions: DeriveDataTypeable, MultiParamTypeClasses, FlexibleContexts, PatternGuards++Executable afp-validate+ Main-is: afp-validate.hs+ Build-depends: OpenAFP, haskell98, base++Executable afp2line+ Main-is: afp2line.hs+ Build-depends: OpenAFP, haskell98, base+ Extensions: GeneralizedNewtypeDeriving
+ afp-olndump.hs view
@@ -0,0 +1,101 @@+import OpenAFP+import Control.Applicative+import Data.Binary.Get+import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Lazy as L++data F = MkF+ { _OFLLen :: N4+ , _Checksum :: N4+ , _OIDLen :: N2+ , _OIDName :: ByteString+ , _ODescLen :: N2+ , _ObjDesc :: Desc+ , _ObjData :: ByteString+ }+ deriving Show++data Desc+ = CMap+ { _ObjType :: N1+ , _Precedence :: N1+ , _Linkage :: N1+ , _WritingDirection :: N1+ , _GCSGID :: N2+ , _CPGID :: N2+ }+ | CID+ { _ObjType :: N1+ , _Precedence :: N1+ , _MaximumV :: N2+ , _MaximumW :: N2+ }+ | NA { _ObjType :: N1 }+ | PFB { _ObjType :: N1 }+ | AFM { _ObjType :: N1 }+ | FMap { _ObjType :: N1 }+ | Reserved { _ObjType :: N1 }+ deriving Show++descExt :: Desc -> String+descExt CMap{} = "CMP"+descExt CID{} = "CID"+descExt NA{} = "NA"+descExt PFB{} = "PFB"+descExt AFM{} = "AFM"+descExt FMap{} = "DAT"+descExt Reserved{} = "RES"++instance Binary Desc where+ put = undefined+ get = do+ objType <- get+ case objType of+ 0 -> return $ NA objType+ 1 -> liftM5 (CMap objType) get get get get get+ 5 -> liftM3 (CID objType) get get get+ 6 -> return $ PFB objType+ 7 -> return $ AFM objType+ 8 -> return $ FMap objType+ _ -> return $ Reserved objType++instance Binary F where+ put = undefined+ get = do+ oflLen <- get+ checksum <- get+ oidLen <- get+ let szOID = fromEnum oidLen - 2+ oidName <- getByteString szOID+ oDescLen <- get+ let szDesc = fromEnum oDescLen - 2+ objDesc <- decodeBuf <$> getByteString szDesc+ objData <- getByteString (fromEnum oflLen - 12 - szOID - szDesc)+ return $ MkF oflLen checksum oidLen oidName oDescLen objDesc objData+ where+ decodeBuf :: Binary a => ByteString -> a+ decodeBuf = decode . L.fromChunks . (:[])++main :: IO ()+main = do+ args <- getArgs+ if null args then error "Usage: afp-olndump input.oln [outputDirectory]" else do+ let inputFile = head args+ outDir = case args of+ (_:d:_) -> d+ _ -> let d = takeWhile (/= '.') inputFile in+ if d == inputFile then d ++ ".out" else d+ cs <- filter (~~ _FNG) <$> readAFP (head args)+ let fs = decodeList $ L.fromChunks (map (packBuf . fng . decodeChunk) cs)+ createDirectoryIfMissing True outDir+ mapM_ (dump outDir) fs++dump :: FilePath -> F -> IO ()+dump d f = do+ putStrLn $ unwords [ file, ":", show len, "bytes" ]+ C.writeFile file dat+ where+ ext = descExt $ _ObjDesc f+ file = d ++ "/" ++ C.unpack (_OIDName f) ++ ('.':ext)+ len = C.length dat+ dat = _ObjData f
afp2line.hs view
@@ -154,22 +154,27 @@ ptxGroupDump :: [PTX_] -> IO () ptxGroupDump (scfl:cs) = do let scflId = ptx_scfl (decodeChunk scfl)+ curEncoding <- lookupFontEncoding scflId cs ..>- [ _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_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_BLN ... \_ -> do writeIORef _CurrentColumn 0 modifyIORef _CurrentLine (+1)
+ afp2line2pdf.hs view
@@ -0,0 +1,803 @@+{-# 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