diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,178 @@ +# Changelog + +## 0.4.6.0 (2026-07-05) + +### Changed + +- **Breaking:** Bare `hpdft FILE` (no subcommand, no mode flags) is now a lightweight viewer: on a TTY it opens an ANSI preview in the lower half of the terminal using fast legacy stream-order extraction; when stdout is a pipe or file it streams legacy text page by page. `hpdft text FILE` keeps the high-quality tagged → geometry batch output on stdout. +- `hpdft text --legacy FILE` now streams page by page (first bytes within about a second on large PDFs) instead of printing one full-document batch; total output is unchanged. Progress `hpdft: page N/M...` goes to stderr on a TTY; suppress with `--quiet`. + +### Added + +- `PDF.Text.pdfToTextStreamDoc` — legacy extraction with a per-page IO callback (document opened once). +- Self-contained ANSI TUI preview (`TuiPreview`, `TuiScroll`); no brick/vty dependency. Top and bottom border bars, vi-style and arrow-key scrolling, less-style regex search (`/PATTERN`, `n`/`N`) with match highlighting, and East Asian width-aware rendering (IME-friendly search input). + +### Fixed + +- `hpdft toc` no longer fails with `missing key /Dest in outline` on PDFs whose outline entries use GoTo actions with named destinations (e.g. hyperref output); the name tree under `/Names` → `/Dests` is now resolved, and entries without a resolvable destination keep their title. + +## 0.4.5.0 (2026-07-05) + +### Changed + +- CLI: `extract` subcommand removed; use top-level `text`, `image`, and `form` instead (`hpdft text FILE`, `hpdft image -p PAGE …`, `hpdft form -p PAGE …`) +- `hpdft FILE` with no subcommand runs text extraction (same as `hpdft text FILE`); no deprecation warning for plain text invocation +- Full-document geometry/tagged extraction: streaming per-page layout, Document-level font/stream caches, parallel page interpretation, RTS defaults (`-N -A64m`), and `filterPageGlyphs` band precomputation — `book.pdf` (150 pages) geom ~142s → ~13s (see `dev/performance-0.4.md`) +- Development roadmaps moved from `docs/` to `dev/`; `docs/` is user-facing library guide only + +### Added + +- `PDF.FormExtract` — extract a named Form XObject from a page to a standalone vector PDF (`pageFormNames`, `extractFormPdf`, `extractFormToFile`) +- Transitive object closure, renumbering, and minimal PDF-1.5 serialization (stream bytes copied as stored in the source index) +- `hpdft form -p PAGE [-n NAME] [-o DIR] [-P PASSWORD] FILE` CLI subcommand; omit `-n` to list top-level Form names on stdout +- English Haddock on primary public API modules (`PDF.Document`, `PDF.Page`, `PDF.Text`, `PDF.Layout`, `PDF.Error`, `PDF.Diff`, `PDF.Image`, `PDF.FormExtract`) +- Example executables `extract-text` and `page-api` under `examples/` + +### Documentation + +- Library usage guide: `docs/library.md` +- Performance investigation (Japanese): `dev/performance-0.4.md` +- Benchmark scripts: `scripts/bench_book.sh`, `scripts/bench_pages.hs` + +### Fixed + +- Form extraction no longer double-compresses FlateDecode streams (broken content streams in output PDFs) +- Indirect array objects (e.g. `/DescendantFonts`, OCG `/Intent`) are serialized correctly instead of empty `<< >>` dictionaries +- Unicode strings in copied objects are written as valid PDF hex strings (UTF-16BE) +- Fixture `test/fixtures/form-export-parent.pdf` and unit tests (optional integration test for Fm42 when user PDF is present) + +## 0.4.4.0 (2026-07-05) + +### Added + +- GitHub Actions CI workflow (GHC 9.14.1: build, test, fixture verification) + +## 0.4.3.0 (2026-07-05) + +### Added + +- `PDF.Image` — extract `/Image` XObjects from a page (`extractPageImages`, `extractPageImagesToDir`) +- `hpdft extract images -p PAGE -o DIR FILE` CLI subcommand (JPEG pass-through; DeviceRGB/Gray 8-bit → minimal PNG encoder) +- Nested Form XObject images collected via extended `PDF.Interpret` walk +- Fixture `data/fixtures/jpeg-image.pdf` and unit tests for image extraction and PNG encoding + +### Known limitations + +- Inline images (`BI` … `EI`) are not extracted in 0.4.3 (planned for a later release) +- Non-JPEG, non–8-bit DeviceRGB/Gray images are written as `.raw` with a JSON sidecar + +## 0.4.2.0 (2026-07-05) + +### Added + +- `PDF.Diff` — paragraph-level text diff between two documents (`compareDocuments`, `diffParagraphs`) +- `hpdft diff FILE_A FILE_B` CLI subcommand with `--json`, `-P`, `--ruby` (and `--geom`/`--legacy` flags) +- `/DCTDecode` stream filter support (JPEG pass-through) in `decodeStreamBytes` +- Filter array cascade and `/ASCII85Decode` in stream decoding +- Unit tests for diff and DCTDecode filter + +## 0.4.1.0 (2026-07-05) + +### Changed + +- CLI refactored into subcommands: `extract`, `info`, `title`, `toc`, `trailer`, `object`, `refs`, `grep` +- Text extraction flags (`-p`, `--geom`, `--tagged`, `--legacy`, `--footnotes`, `--ruby`, `-P`) moved under `hpdft extract` +- Legacy flat-flag invocation (`hpdft FILE`, `hpdft -p 3 FILE`, etc.) retained with a one-time deprecation warning on stderr + +### Migration + +- Replace `hpdft FILE` with `hpdft extract FILE` +- Replace `hpdft -I FILE` with `hpdft info FILE`, `-T` → `title`, `-O` → `toc`, `-R` → `refs`, `-r` → `object -r`, `-g` → `grep -g` + +## 0.4.0.0 (2026-07-05) + +### Added + +- `PDF.Page` — stable public API for page enumeration and structured extraction +- `pageCount`, `pageRefAt`, `pageItems`, `pageGlyphs`, `pageLines`, `pageParagraphs`, `pageRegions` +- `PageRegion` for per-page paragraph regions (page number, index, bbox, text) +- Unit tests for page API on fixture documents + +### Changed + +- Page catalog walk centralized in `PDF.Page` (replaces duplicated logic in scripts and `PDF.Text`) +- `interpret-page` script uses `PDF.Page` instead of `DocumentStructure` internals + +### Migration + +- Prefer `PDF.Page` over direct `DocumentStructure` page-walk helpers in new code +- `PDF.DocumentStructure` remains exposed; no breaking removals in this release + +## 0.3.2.0 (2026-07-05) + +### Fixed + +- `parsePdfNumber` now accepts leading-dot numbers (`.913` → `0.913`, `-.5` → `-0.5`) used by LaTeX/pdflatex `cm` operators; fixes zero glyph size and char-per-line layout fallback +- Type0/CID fonts with `/DescendantFonts` as a direct object reference (not only array-wrapped) now resolve Adobe-Japan1 encoding and descendant `/W` widths +- `codeToUnicode` falls back to Adobe-Japan1-6 when ToUnicode is missing on 2-byte CID fonts +- Glyph advance uses `fiDefaultWidth` when per-code width lookup returns 0 +- Coordinate outlier glyphs (e.g. footnote digits at negative y) filtered before line building; fixes spurious paragraph splits +- CJK line-wrap continuation heuristic joins mid-word breaks (e.g. 記/法) without merging distinct paragraphs +- Interleaved ruby/body stream order merged into `base《ruby》` (e.g. 冪等《べきとう》); orphan ruby lines suppressed when `--ruby` is off +- Lettered list markers (`a.`, `b.`), hang-indent bullet items, and list-item boundaries split paragraphs correctly +- Code blocks (numbered lines, small monospace font) extracted with line breaks and x-position indent inference +- ZapfDingbats bullet glyphs (`r` etc.) mapped to `•`; `/ZapfDingbats` encoding recognized + +## 0.3.1.0 (2026-07-05) + +### Added + +- Ruby extraction in Aozora bunko notation (`《…》`, `｜` for mixed-script bases) +- `--ruby` CLI flag (default off); wired through geometry and tagged extraction paths +- `needsAozoraBar`, `aozoraRuby` in `PDF.Layout` +- Tagged PDF `/Ruby` structure parsing (`PDF.Structure.collectRubySpans`) +- Geometry ruby heuristic (horizontal: small line above; vertical: small line to the right) +- Unit tests for ruby detection and Aozora formatting + +## 0.3.0.0 (2026-07-05) + +Includes backwards-incompatible changes from `master` (0.2.0.0). + +### Added + +- Structured error model (`PDF.Error`: `PdfError`, `PdfResult`, `PdfWarning`) +- Single-read `Document` API (`PDF.Document`) +- Geometry interpreter (`PDF.Interpret`) with positioned glyphs and graphics marks +- Layout engine (`PDF.Layout`): paragraph heuristics, header/footer removal, cross-page merge, spatial reading order +- Tagged PDF extraction (`PDF.Structure`, MCID tracking, `--tagged`) +- CLI flags: `--geom`, `--tagged`, `--legacy`, `--footnotes` +- Test suites: `hpdft-golden` (11 fixtures × default/legacy), `hpdft-unit` (267 cases) +- Utilities: `interpret-page`, `inspect_font`, Haskell fixture generator + +### Changed + +- Default text extraction: tagged structure → geometry layout (replaces stream-order walkdown) +- `-p` / `-g` use the geometry pipeline (not legacy ContentStream) +- Dictionaries and indexes use `Map` (sorted output) +- Core PDF object types (`PdfText`, `PdfName`, `PdfHex`, `Dict` keys, `CMap`, `Encoding`) use `Data.Text.Text` +- Dependency `cryptonite` replaced with `crypton` +- Stream reading is `/Length`-driven and binary-safe +- Xref/trailer/object loading returns `PdfResult` instead of crashing + +### Fixed + +- Hex string tokenizer eating byte after `>` (CID/Type0 Japanese text) +- Tokenizer O(n²) scan on large content streams +- Incremental PDF `/Prev` chain merge order +- RC4/AES decryption, object streams, indirect `/Length` + +### Known limitations + +- RTL horizontal text unsupported +- `--legacy` retains pre-0.3 stream-order extraction for comparison +- See `dev/0.3-roadmap.md` for details + +## 0.2.0.0 + +- Xref streams, object streams, encryption (R2/R4), incremental updates +- Breaking API changes from 0.1.x diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,30 +1,132 @@ # hpdft (Haskell PDF Tools) -hpdft is a PDF parsing tool. It can also be used as a command to grab text, metadata outline (i.e. table of contents) from PDF. +[![CI](https://github.com/k16shikano/hpdft/actions/workflows/ci.yml/badge.svg)](https://github.com/k16shikano/hpdft/actions/workflows/ci.yml) -Command usage: +hpdft is a PDF parsing tool and library. It extracts text, metadata, and outlines (table of contents) from PDF files. +## Quick start + +```bash +cabal install +hpdft document.pdf # quick viewer (TUI in lower half of terminal) +hpdft text document.pdf # high-quality text to stdout (tagged → geometry) +hpdft text -p 3 document.pdf # page 3 only +hpdft text --geom document.pdf # geometry-only extraction +hpdft text --legacy document.pdf # fast stream-order text, streamed page by page ``` -hpdft [-p|--page PAGE] [-r|--ref REF] [-g|--grep RegExp] [-R|--refs] - [-T|--title] [-I|--info] [-O|--toc] [--trailer] FILE -Available options: - -p,--page PAGE Page number (nomble) - -r,--ref REF Object reference - -g,--grep RegExp grep PDF - -R,--refs Show object references in page order - -T,--title Show title (from metadata) - -I,--info Show PDF metainfo - -O,--toc Show table of contents (from metadata) - --trailer Show the trailer of PDF +`hpdft FILE` (no subcommand) is a lightweight viewer: it shows fast stream-order text in an ANSI preview on a TTY, or streams it to stdout when piped. `hpdft text FILE` always writes high-quality tagged → geometry output to stdout. Legacy flat flags (`hpdft -I FILE`, `hpdft -r REF FILE`, etc.) still work but print a deprecation warning for non-text modes. + +## Command usage + +``` +hpdft FILE # quick viewer (TUI on a TTY, stream on a pipe) +hpdft text [OPTIONS] FILE # text extraction to stdout (tagged → geom) +hpdft image -p PAGE -o DIR FILE # image XObjects from one page +hpdft form -p PAGE FILE # list top-level Form names (stdout) +hpdft form -p PAGE -n NAME -o DIR FILE # extract one Form to standalone PDF +hpdft diff [OPTIONS] FILE_A FILE_B # paragraph-level diff +hpdft info FILE # PDF metadata +hpdft title FILE # document title +hpdft toc FILE # table of contents +hpdft trailer FILE # PDF trailer dictionary +hpdft object -r REF FILE # show object by reference +hpdft refs FILE # page object references +hpdft grep -g REGEXP FILE # search extracted text + +Text options: + -p,--page PAGE Page number (1-based; 0 = all pages) + --geom Geometry-based layout extraction + --tagged Tagged PDF structure extraction (default) + --legacy Pre-0.3 stream-order extractor, streamed page by page + --quiet Suppress page progress on stderr during --legacy streaming + --footnotes Inline footnote bodies as tags + --ruby Embed ruby in Aozora bunko notation + -P,--password PASSWORD Password for encrypted PDF FILE input pdf file - -h,--help Show this help text + -h,--help Show help text + +Image options: + -p,--page PAGE Page number (1-based, required) + -o,--output DIR Output directory (default: current directory) + -P,--password PASSWORD Password for encrypted PDF + FILE input pdf file + +Form options: + -p,--page PAGE Page number (1-based, required) + -n,--name NAME Top-level Form name (e.g. Fm42); omit to list names on stdout + -o,--output DIR Output directory (default: current directory) + -P,--password PASSWORD Password for encrypted PDF + FILE input pdf file + +Diff options: + --json JSON output + --ruby Embed ruby in Aozora bunko notation + -P,--password PASSWORD Password for encrypted PDF (both files) + FILE_A FILE_B PDF files to compare ``` -## install +`hpdft FILE` (no subcommand) opens the viewer: an ANSI preview in the lower half of the terminal showing fast stream-order text (`j`/`k` or arrow keys to scroll, `d`/`u` half page, `g`/`G` top/end, `/PATTERN` + `n`/`N` for regex search like less, `q` quit). When stdout is a pipe or file the viewer is skipped and the same text is streamed page by page. -Clone this repository and do cabal-install. +`hpdft text FILE` extracts text in logical order using the tagged PDF structure when the document has a usable one, and otherwise falls back to geometry-based paragraph reconstruction (equivalent to `--geom`). `-p N` extracts one page with geometry layout. `--legacy` selects the fast stream-order extractor on stdout. +## Library + +hpdft is also a Haskell library. See **[docs/library.md](docs/library.md)** for installation, error handling, text pipelines, page API, diff, images, and form extraction. + +| Module | Purpose | +|--------|---------| +| `PDF.Document` | Single-read document handle (`openDocument`) | +| `PDF.Error` | `PdfResult`, `PdfError`, `PdfWarning` | +| `PDF.Text` | Text extraction (tagged, geometry, legacy) | +| `PDF.Layout` | `LayoutOptions`, line/paragraph layout | +| `PDF.Page` | Page enumeration and structured extraction | +| `PDF.Diff` | Paragraph-level document comparison | +| `PDF.Image` | Image XObject extraction | +| `PDF.FormExtract` | Form XObject extraction to standalone PDF | +| `PDF.Interpret` | Content-stream geometry interpreter | +| `PDF.Structure` | Tagged PDF logical structure | + +Example programs (from repo root): + +```bash +cabal run extract-text -- data/fixtures/classic.pdf +cabal run page-api -- data/fixtures/paragraphs.pdf ``` -$ cabal install + +Build Haddock API docs locally: + +```bash +cabal haddock --haddock-all ``` + +## Install + +Clone this repository and run cabal-install. + +```bash +cabal install +``` + +## Development + +Requires GHC 9.14+ (see `hpdft.cabal`). + +```bash +cabal build +cabal test # golden (22) + unit +bash scripts/verify_text.sh # compare all fixture outputs +cabal run interpret-page -- FILE PAGE # debug glyph positions +``` + +### Documentation + +- [Library guide](docs/library.md) — using hpdft as a Haskell library +- [Changelog](CHANGELOG.md) — release notes + +Developer notes (roadmaps, performance write-ups): [`dev/`](dev/) + +## Version + +Released: **0.4.6.0** (2026-07-05) — Quick viewer (`hpdft FILE`) with ANSI TUI, legacy streaming, toc fix. +Previous release: **0.4.5.0**. diff --git a/TuiPreview.hs b/TuiPreview.hs new file mode 100644 --- /dev/null +++ b/TuiPreview.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TuiPreview (runTuiPreview) where + +import PDF.Document (Document) +import PDF.Text (pdfToTextStreamDoc) +import TuiScroll + ( ScrollState(..) + , initialScrollState + , clampScrollTop + , scrollBy + , scrollToTop + , scrollToEnd + , scrollHalfPageDown + , scrollHalfPageUp + , searchForwardFrom + , searchBackwardFrom + , visibleLineRange + , statusLineNumber + , stringDisplayWidth + , clipToDisplayWidth + , padToDisplayWidth + ) + +import Control.Concurrent (forkIO, killThread, threadDelay) +import Control.Exception (AsyncException(UserInterrupt), bracket, catch, finally, throwIO) +import Control.Monad (when) +import Data.Array ((!)) +import Data.Char (isPrint) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString.Lazy as BSL +import System.Console.Terminal.Size (Window(..), hSize) +import System.IO + ( BufferMode(..) + , Handle + , hFlush + , hGetBuffering + , hGetChar + , hGetEcho + , hPutStr + , hReady + , hSetBuffering + , hSetEcho + , stderr + , stdin + , stdout + ) +import Text.Regex.Base.RegexLike (makeRegexM, matchAll, matchTest) +import Text.Regex.TDFA (Regex) + +runTuiPreview :: FilePath -> Document -> IO () +runTuiPreview path doc = + let run term = + uiLoop term path doc `catch` \e -> + case e of + UserInterrupt -> return () + _ -> throwIO e + in bracket acquireTerminal releaseTerminal run + +data Terminal = Terminal + { termStdout :: Handle + , termStderr :: Handle + , termStdin :: Handle + , termOldEcho :: Bool + , termOldBuffer :: BufferMode + , termRows :: Int + , termCols :: Int + , termViewportH :: Int + , termTextRows :: Int + , termViewportTop :: Int + } + +data Key + = KChar Char + | KUp + | KDown + | KPageUp + | KPageDown + | KEnter + | KBackspace + | KEsc + | KOther + +-- | Status-line mode: normal view, or entering a search pattern after @/@. +data UiMode = ModeView | ModeInput String + +acquireTerminal :: IO Terminal +acquireTerminal = do + oldEcho <- hGetEcho stdin + oldBuf <- hGetBuffering stdin + hSetEcho stdin False + hSetBuffering stdin NoBuffering + (rows, cols, vh, textRows, vTop) <- queryGeometry stdout + -- Hide the cursor and disable autowrap: a wrap on the bottom row would + -- scroll the whole screen and drag the viewport out of place. + hPutStr stdout "\ESC[?25l\ESC[?7l" + hFlush stdout + return Terminal + { termStdout = stdout + , termStderr = stderr + , termStdin = stdin + , termOldEcho = oldEcho + , termOldBuffer = oldBuf + , termRows = rows + , termCols = cols + , termViewportH = vh + , termTextRows = textRows + , termViewportTop = vTop + } + +releaseTerminal :: Terminal -> IO () +releaseTerminal term = do + clearViewport term + hPutStr (termStdout term) "\ESC[?25h\ESC[?7h\ESC[0m" + hPutStr (termStdout term) $ "\ESC[" ++ show (termRows term + 1) ++ ";1H" + hFlush (termStdout term) + hSetEcho (termStdin term) (termOldEcho term) + hSetBuffering (termStdin term) (termOldBuffer term) + +-- Viewport layout: top bar, text rows, status bar (bottom). +queryGeometry :: Handle -> IO (Int, Int, Int, Int, Int) +queryGeometry h = do + mw <- hSize h + let reported f dflt = case mw of + Just w | fromIntegral (f w) > 0 -> fromIntegral (f w) + _ -> dflt + rows = reported height 24 + cols = reported width 80 + vh = max 6 (rows `div` 2) + textRows = max 1 (vh - 2) + vTop = rows - vh + 1 + return (rows, cols, vh, textRows, vTop) + +readKey :: Handle -> IO Key +readKey h = do + c <- hGetChar h + case c of + '\ESC' -> do + pending <- hReady h + if not pending + then return KEsc + else do + c1 <- hGetChar h + if c1 /= '[' + then return KEsc + else do + c2 <- hGetChar h + case c2 of + 'A' -> return KUp + 'B' -> return KDown + '5' -> swallowTilde >> return KPageUp + '6' -> swallowTilde >> return KPageDown + _ -> return KOther + '\r' -> return KEnter + '\n' -> return KEnter + '\DEL' -> return KBackspace + '\b' -> return KBackspace + _ -> return (KChar c) + where + swallowTilde = do + pending <- hReady h + when pending $ hGetChar h >> return () + +uiLoop :: Terminal -> FilePath -> Document -> IO () +uiLoop term path doc = do + linesRef <- newIORef ([] :: [Text]) + pagesLoadedRef <- newIORef (0 :: Int) + totalPagesRef <- newIORef (0 :: Int) + doneRef <- newIORef False + scrollRef <- newIORef (initialScrollState (termTextRows term)) + redrawRef <- newIORef True + modeRef <- newIORef ModeView + searchRef <- newIORef (Nothing :: Maybe (String, Regex)) + matchRef <- newIORef (Nothing :: Maybe Int) + msgRef <- newIORef (Nothing :: Maybe String) + + let producer = do + _ <- pdfToTextStreamDoc doc $ \pg total bs -> do + writeIORef totalPagesRef total + modifyIORef' linesRef $ appendChunk (decodeLenient bs) + writeIORef pagesLoadedRef pg + ls <- readIORef linesRef + modifyIORef' scrollRef (\st -> st {scrollTotalLines = length ls}) + writeIORef redrawRef True + writeIORef doneRef True + writeIORef redrawRef True + + let syncTotal = do + ls <- readIORef linesRef + modifyIORef' scrollRef (\st -> st {scrollTotalLines = length ls}) + return ls + + -- Jump forward (or backward) to the next line matching the active pattern. + searchStep forward = do + msearch <- readIORef searchRef + case msearch of + Nothing -> writeIORef msgRef (Just "No previous search") + Just (_, re) -> do + ls <- syncTotal + st <- readIORef scrollRef + cur <- readIORef matchRef + let p = matchTest re . T.unpack + top = scrollTopLine st + found + | forward = searchForwardFrom p (maybe (top + 1) (+ 1) cur) ls + | otherwise = searchBackwardFrom p (maybe (top - 1) (subtract 1) cur) ls + case found of + Nothing -> writeIORef msgRef (Just "Pattern not found") + Just i -> do + writeIORef matchRef (Just i) + modifyIORef' scrollRef (clampScrollTop i) + + startSearch q + | null q = do + msearch <- readIORef searchRef + case msearch of + Just _ -> searchStep True + Nothing -> return () + | otherwise = + case makeRegexM q :: Maybe Regex of + Nothing -> writeIORef msgRef (Just "Invalid pattern") + Just re -> do + writeIORef searchRef (Just (q, re)) + writeIORef matchRef Nothing + searchStep True + + handleViewKey key = case key of + KChar 'q' -> return True + KChar '\ETX' -> return True + KChar '/' -> writeIORef modeRef (ModeInput "") >> return False + KChar 'n' -> searchStep True >> return False + KChar 'N' -> searchStep False >> return False + _ -> do + _ <- syncTotal + modifyIORef' scrollRef (moveKey (termTextRows term) key) + return False + + handleInputKey q key = do + case key of + KEsc -> writeIORef modeRef ModeView + KEnter -> do + writeIORef modeRef ModeView + startSearch q + KBackspace -> + writeIORef modeRef $ + if null q then ModeView else ModeInput (init q) + KChar c + | c == '\ETX' -> writeIORef modeRef ModeView + | isPrint c -> writeIORef modeRef (ModeInput (q ++ [c])) + _ -> return () + return False + + let loop = do + needRedraw <- readIORef redrawRef + when needRedraw $ do + writeIORef redrawRef False + ls <- readIORef linesRef + pg <- readIORef pagesLoadedRef + total <- readIORef totalPagesRef + done <- readIORef doneRef + scroll <- readIORef scrollRef + mode <- readIORef modeRef + msg <- readIORef msgRef + msearch <- readIORef searchRef + drawFrame term path scroll ls pg total done mode msg (fmap snd msearch) + ready <- hReady (termStdin term) + if ready + then do + key <- readKey (termStdin term) + writeIORef msgRef Nothing + mode <- readIORef modeRef + quit <- case mode of + ModeView -> handleViewKey key + ModeInput q -> handleInputKey q key + writeIORef redrawRef True + if quit then return () else loop + else do + threadDelay 50000 + loop + + tid <- forkIO producer + loop `finally` killThread tid + +moveKey :: Int -> Key -> ScrollState -> ScrollState +moveKey textRows key st = case key of + KChar 'j' -> scrollBy 1 st + KChar ' ' -> scrollBy 1 st + KChar 'k' -> scrollBy (-1) st + KDown -> scrollBy 1 st + KUp -> scrollBy (-1) st + KPageDown -> scrollBy textRows st + KPageUp -> scrollBy (-textRows) st + KChar 'g' -> scrollToTop st + KChar 'G' -> scrollToEnd st + KChar 'd' -> scrollHalfPageDown st + KChar 'u' -> scrollHalfPageUp st + _ -> st + +-- | Line buffer invariant: the last element is the still-open line +-- (empty when the previous chunk ended with a newline). +appendChunk :: Text -> [Text] -> [Text] +appendChunk chunk [] = T.split (== '\n') chunk +appendChunk chunk ls = + case T.split (== '\n') chunk of + (c : cs) -> init ls ++ (last ls <> c) : cs + [] -> ls + +decodeLenient :: BSL.ByteString -> Text +decodeLenient bs = + TE.decodeUtf8With (\_ _ -> Just '\xfffd') (BSL.toStrict bs) + +drawFrame :: + Terminal -> FilePath -> ScrollState -> [Text] -> + Int -> Int -> Bool -> UiMode -> Maybe String -> Maybe Regex -> IO () +drawFrame term path scroll ls pg total done mode msg mre = do + let (start, end) = visibleLineRange scroll + visible = take (end - start) (drop start ls) + status = case mode of + ModeInput q -> "/" ++ q + ModeView -> case msg of + Just m -> " " ++ m + Nothing -> + " page " + ++ show (if total > 0 then pg else 0) + ++ "/" + ++ show total + ++ (if done then "" else "...") + ++ " | line " + ++ show (statusLineNumber scroll) + ++ "/" + ++ show (max (length ls) 1) + ++ " | j/k \x2193/\x2191 d/u g/G /:search n/N q:quit" + drawBarRow term (termViewportTop term) (" " ++ path) + mapM_ (drawTextRow term mre) (zip [0 ..] visible) + let filled = length visible + statusRow = termViewportTop term + termViewportH term - 1 + mapM_ (\i -> drawTextRow term Nothing (i, "")) [filled .. termTextRows term - 1] + drawBarRow term statusRow status + -- During search input, park the visible cursor after the query so IME + -- composition windows anchor to the right spot. + case mode of + ModeInput _ -> do + let col = min (termCols term) (stringDisplayWidth status + 1) + hPutStr (termStdout term) $ + "\ESC[" ++ show statusRow ++ ";" ++ show col ++ "H\ESC[?25h" + ModeView -> + hPutStr (termStdout term) "\ESC[?25l" + hFlush (termStdout term) + +drawTextRow :: Terminal -> Maybe Regex -> (Int, Text) -> IO () +drawTextRow term mre (i, txt) = do + let row = termViewportTop term + 1 + i + clipped = clipToDisplayWidth (termCols term) (T.unpack txt) + rendered = maybe clipped (`highlightMatches` clipped) mre + hPutStr (termStdout term) $ "\ESC[" ++ show row ++ ";1H\ESC[K" ++ rendered + +-- | Wrap every regex match on the (already clipped) line in reverse video. +highlightMatches :: Regex -> String -> String +highlightMatches re s = go 0 s spans + where + spans = [(off, len) | ma <- matchAll re s, let (off, len) = ma ! 0, len > 0] + go _ rest [] = rest + go pos rest ((off, len) : more) = + let (before, rest') = splitAt (off - pos) rest + (hit, rest'') = splitAt len rest' + in before ++ "\ESC[7m" ++ hit ++ "\ESC[0m" ++ go (off + len) rest'' more + +-- | Full-width reverse-video bar (used for the top border and the status line). +drawBarRow :: Terminal -> Int -> String -> IO () +drawBarRow term row content = do + let padded = padToDisplayWidth (termCols term) content + hPutStr (termStdout term) $ + "\ESC[" ++ show row ++ ";1H\ESC[7m" ++ padded ++ "\ESC[0m" + +clearViewport :: Terminal -> IO () +clearViewport term = + mapM_ clearRow [termViewportTop term .. termViewportTop term + termViewportH term - 1] + where + clearRow r = hPutStr (termStdout term) $ "\ESC[" ++ show r ++ ";1H\ESC[K" diff --git a/TuiScroll.hs b/TuiScroll.hs new file mode 100644 --- /dev/null +++ b/TuiScroll.hs @@ -0,0 +1,118 @@ +module TuiScroll + ( ScrollState(..) + , initialScrollState + , clampScrollTop + , scrollBy + , scrollToTop + , scrollToEnd + , scrollHalfPageDown + , scrollHalfPageUp + , searchForwardFrom + , searchBackwardFrom + , visibleLineRange + , statusLineNumber + , charDisplayWidth + , stringDisplayWidth + , clipToDisplayWidth + , padToDisplayWidth + ) where + +import Data.Char (ord) +import Data.List (findIndex) + +data ScrollState = ScrollState + { scrollTopLine :: !Int + , scrollTotalLines :: !Int + , scrollTextRows :: !Int + } deriving (Eq, Show) + +initialScrollState :: Int -> ScrollState +initialScrollState textRows = + ScrollState {scrollTopLine = 0, scrollTotalLines = 0, scrollTextRows = textRows} + +maxScrollTop :: ScrollState -> Int +maxScrollTop st = + max 0 (scrollTotalLines st - scrollTextRows st) + +clampScrollTop :: Int -> ScrollState -> ScrollState +clampScrollTop n st = st {scrollTopLine = clamp 0 (maxScrollTop st) n} + where + clamp lo hi x = max lo (min hi x) + +scrollBy :: Int -> ScrollState -> ScrollState +scrollBy delta st = + clampScrollTop (scrollTopLine st + delta) st + +scrollToTop :: ScrollState -> ScrollState +scrollToTop st = st {scrollTopLine = 0} + +scrollToEnd :: ScrollState -> ScrollState +scrollToEnd st = clampScrollTop maxBound st + +scrollHalfPageDown :: ScrollState -> ScrollState +scrollHalfPageDown st = + scrollBy (max 1 (scrollTextRows st `div` 2)) st + +scrollHalfPageUp :: ScrollState -> ScrollState +scrollHalfPageUp st = + scrollBy (-max 1 (scrollTextRows st `div` 2)) st + +-- | Index of the first line at or after @start@ satisfying the predicate. +searchForwardFrom :: (a -> Bool) -> Int -> [a] -> Maybe Int +searchForwardFrom p start ls = + let from = max 0 start + in (+ from) <$> findIndex p (drop from ls) + +-- | Index of the last line at or before @start@ satisfying the predicate. +searchBackwardFrom :: (a -> Bool) -> Int -> [a] -> Maybe Int +searchBackwardFrom p start ls = + let upto = min (length ls - 1) start + hits = [i | (i, l) <- zip [0 ..] (take (upto + 1) ls), p l] + in if upto < 0 || null hits then Nothing else Just (last hits) + +visibleLineRange :: ScrollState -> (Int, Int) +visibleLineRange st = + let top = scrollTopLine st + end = min (scrollTotalLines st) (top + scrollTextRows st) + in (top, end) + +statusLineNumber :: ScrollState -> Int +statusLineNumber st = + if scrollTotalLines st == 0 + then 0 + else scrollTopLine st + 1 + +-- | Terminal display width: East Asian wide/fullwidth characters occupy +-- two columns. Covers the common CJK blocks; combining marks are not handled. +charDisplayWidth :: Char -> Int +charDisplayWidth c + | w >= 0x1100 && w <= 0x115F = 2 -- Hangul Jamo + | w >= 0x2E80 && w <= 0xA4CF = 2 -- CJK radicals .. Yi + | w >= 0xAC00 && w <= 0xD7A3 = 2 -- Hangul syllables + | w >= 0xF900 && w <= 0xFAFF = 2 -- CJK compatibility ideographs + | w >= 0xFE30 && w <= 0xFE4F = 2 -- CJK compatibility forms + | w >= 0xFF00 && w <= 0xFF60 = 2 -- fullwidth forms + | w >= 0xFFE0 && w <= 0xFFE6 = 2 + | w >= 0x20000 && w <= 0x3FFFD = 2 -- CJK extensions + | otherwise = 1 + where w = ord c + +stringDisplayWidth :: String -> Int +stringDisplayWidth = sum . map charDisplayWidth + +-- | Longest prefix that fits in @width@ display columns. +clipToDisplayWidth :: Int -> String -> String +clipToDisplayWidth width = go width + where + go _ [] = [] + go left (c : cs) + | cw <= left = c : go (left - cw) cs + | otherwise = [] + where cw = charDisplayWidth c + +-- | Clip and right-pad with spaces to exactly @width@ display columns +-- (may fall one column short when a wide character straddles the edge). +padToDisplayWidth :: Int -> String -> String +padToDisplayWidth width s = + let clipped = clipToDisplayWidth width s + in clipped ++ replicate (width - stringDisplayWidth clipped) ' ' diff --git a/dev/0.3-roadmap.md b/dev/0.3-roadmap.md new file mode 100644 --- /dev/null +++ b/dev/0.3-roadmap.md @@ -0,0 +1,165 @@ +# hpdft 0.3 開発ロードマップ + +hpdft 0.3 開発ロードマップ（**0.3.0.0 リリース済み**、2026-07-05）。 + +`master` @ 0.3.0.0。0.2.0.0 からの非互換変更を含む。 + +## テキスト抽出パイプライン（現行） + +既定の `hpdft FILE` は次の順でパイプラインを選択する。 + +``` +tagged（StructTreeRoot + MCID ≥50%） + ↓ 不可 +geometry（PDF.Interpret → PDF.Layout） + ↓ 座標 unusable（<70%） +stream-order fallback（Layout 内） +``` + +| フラグ | パイプライン | +|--------|-------------| +| （なし） | tagged → geometry（上記） | +| `--geom` | geometry のみ | +| `--tagged` | tagged → geometry フォールバック | +| `--legacy` | 旧 ContentStream 抽出（0.2 以前） | +| `--footnotes` | geometry 系で脚注本文を `…` にインライン化 | + +`-p` / `-g` も geometry パイプラインを使用（`--legacy` 除く）。 + +### geometry パイプラインの内部段階 + +1. **PDF.Interpret** — コンテンツストリームをオペランドスタックで解釈し、`PageItem`（グリフ + グラフィック矩形）を生成 +2. **行形成** (`buildLines`) — ストリーム順でグリフを行にマージ（上付き・下付き・ハイフン継続） +3. **ヘッダ/フッタ除去** — 全ページ横断で反復する上下帯テキストを除去（document-level） +4. **脚注処理** (`--footnotes`) — ページ下部の小字体 + マーカー行を検出し、アンカーへインライン +5. **読み順ソート** (`sortLinesByReadingOrder`) — 行の先頭座標で並べ替え + - 横書き (wmode 0): 上→下、左→右 + - 縦書き (wmode 1): 右→左（列）、列内上→下 + - RTL 横書き: **未対応** + - wmode 混在ページ: 横書きブロック → 縦書きブロック（interleave なし） +6. **段落化** — ベースライン跳躍・インデント・グラフィック要素で段落境界を判定 +7. **ページ跨ぎ結合** — 終端句読点・インデント・フォントサイズ変化で段落を連結 + +### ライブラリ API（主要） + +| モジュール | 役割 | +|-----------|------| +| `PDF.Document` | 1 回読込の Document ハンドル | +| `PDF.Error` | `PdfError` / `PdfResult` / `PdfWarning` | +| `PDF.Interpret` | 幾何インタプリタ → `[Glyph]` / `[PageItem]` | +| `PDF.Layout` | 行・段落・document-level レイアウト | +| `PDF.Structure` | Tagged PDF 構造ツリー解析 | +| `PDF.Text` | 抽出ドライバ（legacy / geom / tagged） | +| `PDF.Matrix` | 2D アフィン変換 | + +--- + +## 完了したフェーズ + +### A: 堅牢性（完了） + +- [x] A1 xref/trailer 系の `Either` 化 +- [x] A2 パーサ全域化（`error` / 部分関数排除） +- [x] A3 CLI エラー表面化（exit code・メッセージ） +- [x] A4 stream 読み取りのバイナリ安全化（`/Length` 主導） +- [x] A5 `orError` 解消 + Show/表示分離 +- [x] A6 診断を `PdfWarning` チャネルへ + +### B: 性能・API（完了） + +- [x] B1 `Document` ハンドル（1 回読込） +- [x] B2 xref 遅延パース + type 2 直接解決 +- [x] B3 `Dict` / `PDFObjIndex` の Map 化 +- [x] B4 CMap/Encoding lookup の Map 化 + +### C: テキスト表現（完了） + +- [x] C1a `PDF.Matrix` +- [x] C1b `FontInfo` 幅テーブル・WMode・bytesPerCode +- [x] C1c `PDF.Interpret` 幾何インタプリタ（オペランドスタック） +- [x] C1c-CID hex トークナイザ修正 + inline Dict フォント解決 +- [x] C1d `PDF.Layout` 段落ヒューリスティック + グラフィックマーク +- [x] C1e Tagged PDF（MCID + StructTreeRoot）論理順抽出 +- [x] C1f コーパス比較・既定パイプライン切替（tagged→geom、`--legacy` 退避） +- [x] document-level ヘッダ/フッタ除去 + ページ跨ぎ段落結合 +- [x] 上付き文字インライン化 + `--footnotes` オプション +- [x] Latin 語間スペース + ハイフン行結合修正 +- [x] 座標ベース読み順ソート +- [x] **C2** String→Text 移行（PdfText/PdfName/CMap/出力系） + +### D: インフラ（D1・D2・D4 完了、D3・D5–D7 未着手） + +- [x] D1 cabal test-suite + フィクスチャ拡充（golden 11 × 2 パイプライン、unit 267） +- [x] **D2** GitHub Actions CI（v0.4.4.0） +- [ ] **D3** パーサ基盤統一（attoparsec/parsec 二本立て解消） +- [x] **D4** cryptonite→crypton 移行 +- [ ] **D5** Filter 拡充（LZW/ASCII85/ASCIIHex/RunLength/カスケード） +- [ ] **D6** AES-256（R5/R6）鍵導出 +- [ ] **D7** CLI サブコマンド化 + +--- + +## テスト + +```bash +cabal build +cabal test # golden 22件 + unit 267件 +bash scripts/verify_text.sh # 全 fixture（default + legacy） +HPDFT=dist-newstyle/build/.../hpdft bash scripts/verify_xref.sh # data/sample +``` + +| スクリプト | 用途 | +|-----------|------| +| `scripts/gen_fixtures.hs` | CI 安全な synthetic PDF 生成 | +| `scripts/verify_text.sh [--update]` | golden テキスト比較 | +| `scripts/verify_xref.sh` | `data/sample/*.pdf` スモーク | +| `cabal run interpret-page -- FILE PAGE [--full]` | ページのグリフ/グラフィックダンプ | + +フィクスチャ: `data/fixtures/`（公開可）。期待値は `expected/`（default）と `expected-legacy/`（`--legacy`）。 +ローカル PDF: `data/sample/`（`.gitignore`、公開リポジトリ非収載）。 + +--- + +## 既知の制限・フォローアップ + +| 項目 | 状態 | メモ | +|------|------|------| +| RTL 横書き | 未対応 | 明示的にスコープ外 | +| wmode 混在ページ | 制限あり | 横→縦ブロック連結 | +| 同一行内ストリーム逆順 | 未対応 | 行内 LTR 補正は将来タスク | +| ページ外アーティファクト | 残存 | 例: irtls p19 の `22360`（MediaBox 外フィルタ要） | +| SecureFont / ToUnicode 欠損 | 部分 | heatstroke 等で文字化け（poppler も同様） | +| Form XObject の MCID | 簡易 | 親スタック引継ぎのみ | +| tagged パスの artifact 脚注 | 未統合 | geometry フォールバック時のみ `--footnotes` 有効 | +| CLI | フラグ連鎖 | D7 でサブコマンド化予定 | + +--- + +## 推奨する次の作業順 + +0.3.0.0 リリース済み。以降は [0.4 ロードマップ](0.4-roadmap.md) を参照。 + +1. **0.3.1** — ルビ抽出（青空文庫記法、`--ruby`、Structure 優先） +2. **0.4.0 E0** — 公開 API 整備（`PDF.Page` 等） +3. **D2 CI** — E0 前後で導入 +4. **0.4.1 D7** — CLI サブコマンド化 +5. **0.4.2 D5+E2** — DCTDecode + 段落 diff +6. **0.4.3 E3** — `hpdft extract images -p PAGE FILE` + +--- + +## コミット履歴（feature/0.3-error-model、新しい順） + +`master` から約 30 コミット。主要マイルストーン: + +| コミット | 内容 | +|---------|------| +| f27e78f | 座標ベース読み順ソート | +| 1d2187b | Latin 語間スペース + ハイフン行結合 | +| 1453624 | 上付きインライン化 + `--footnotes` | +| 56778da | document-level ヘッダ/フッタ + ページ跨ぎ段落 | +| fc312ce | 既定パイプライン切替（tagged→geom、`--legacy`） | +| 05a0c6d | PDF.Layout + `--geom` | +| e6f5118 | PDF.Interpret 幾何インタプリタ | +| 47fa202 | 0.3.0.0 + PDF.Error 骨格 | +| … | A/B フェーズ（堅牢性・Document API・Map 化） | diff --git a/dev/0.4-roadmap.md b/dev/0.4-roadmap.md new file mode 100644 --- /dev/null +++ b/dev/0.4-roadmap.md @@ -0,0 +1,227 @@ +# hpdft 0.3.1 / 0.4 ロードマップ + +`master` @ 0.3.0.0（2026-07-05）以降の方針。 + +## リリース方針 + +| 版 | 位置づけ | 主な内容 | +|----|---------|---------| +| **0.3.1** | 0.3 の拡張 | ルビ抽出（青空文庫記法） | +| **0.4.0** | API 基盤 | E0 公開 API 整備 | +| **0.4.x** | 機能拡張 | D7 → D5+E2 → E3（順次） | + +0.3 残タスク（D2–D7）は **0.4 目標との関連で取捨選択** する。下記「0.3 残タスクの扱い」参照。 + +--- + +## 0.3.1 — ルビ抽出 + +0.4 API 整備とは独立して進められる。Layout / Interpret の延長として **0.3.1 で先行リリース** する。 + +### 出力形式（青空文庫） + +[青空文庫 注記一覧・ルビ](https://www.aozora.gr.jp/annotation/etc.html) に準拠。 + +| ケース | 出力例 | +|--------|--------| +| 単一文字種の基底 | `青空文庫《あおぞらぶんこ》` | +| 混在文字種の基底 | `霧の｜ロンドン警視庁《スコットランドヤード》` | + +- ルビ本体は `《…》`（全角括弧） +- 基底が漢字・仮名・英字など **複数文字種混在** するときは基底直前に `｜`（全角縦棒）を付ける +- 平仮名と片仮名は別文字種として扱う（青空文庫マニュアル準拠） +- **0.3.1 の MVP** は上記の横書き・縦書き geometry ヒューリスティック + Structure パス。左付きルビ・ママ注記・外字注記は **注記形式**（`［＃…］`）として後回し可 + +### 抽出パイプライン（優先順） + +``` +Structure（/Ruby, /RB, /RT 等が利用可能） + ↓ 不可・不完全 +geometry ヒューリスティック（Layout 拡張） +``` + +- **Tagged PDF に Ruby 構造がある場合は Structure パスを優先**（MCID 紐付けと同様の方針） +- geometry フォールバック: + - 横書き (wmode 0): 親行の直上、小字体、親文字 span と X 範囲が重なる行 + - 縦書き (wmode 1): 親列の右側、小字体、親文字 span と Y 範囲が重なる行 +- 脚注・上付き処理（`--footnotes`）と競合しないよう、**ルビ行の分離を脚注処理より前** に行う +- CLI: 既存テキスト抽出に `--ruby` を追加（既定 off）。有効時は行内に青空記法を埋め込む + +### 0.3.1 で触るモジュール（想定） + +- `PDF.Structure` — Ruby 要素の解析・MCID/座標との対応 +- `PDF.Layout` — ルビ行検出・基底への結合、`aozoraRuby` 整形（`｜` 判定含む） +- `PDF.Text` — `--ruby` 配線 +- `hpdft.hs` — フラグ追加 +- `test/Unit.hs` — synthetic glyph 配置の unit テスト + +### 0.3.1 スコープ外 + +- 左付きルビ（青空の `［＃…の左に…］` 注記形式） +- 外字・長基底の開始/終了型注記 +- wmode 混在ページの interleave（既知制限のまま） + +--- + +## 0.4 — 全体像 + +```mermaid +flowchart LR + subgraph v031 [0.3.1] + Ruby[ルビ] + end + subgraph v040 [0.4.0 E0] + API[公開 API 整備] + end + subgraph v04x [0.4.x] + D7[CLI サブコマンド] + D5E2[D5 Filter + テキスト diff] + E3[画像抽出] + end + Ruby --> API + API --> D7 + D7 --> D5E2 + D5E2 --> E3 +``` + +**作業順（合意）:** E0 → D7 → D5+E2 → E3 + +D2（CI）は E0 と並行または直後。API とテスト基盤が整うと E2 の fixture 化が容易になる。 + +--- + +## E0 — ライブラリ API 整備（0.4.0） + +`scripts/` が `DocumentStructure` 内部関数に直接依存している状態を解消し、**安定した公開境界** を設ける。 + +### 目標 API（案） + +```haskell +-- PDF.Page（新規） +pageCount :: Document -> PdfResult Int +pageRefAt :: Document -> Int -> PdfResult PageRef -- 1-based +pageItems :: Document -> PageRef -> PdfResult [PageItem] +pageGlyphs :: Document -> PageRef -> PdfResult [Glyph] +pageLines :: Document -> PageRef -> LayoutOptions -> PdfResult [Line] +pageParagraphs :: Document -> PageRef -> LayoutOptions -> PdfResult [T.Text] + +-- 構造化出力（diff 共用） +data PageRegion = PageRegion + { regionPage :: Int + , regionParagraph :: Int -- ページ内段落番号 + , regionBBox :: Rect -- 段落 bbox 概算 + , regionText :: T.Text + } + +pageRegions :: Document -> PageRef -> LayoutOptions -> PdfResult [PageRegion] +``` + +- `interpret-page` / `inspect_font` / 将来の `diff` が **公開 API のみ** で書けるようにする +- `hpdft.cabal` の `exposed-modules` を明示的に整理 +- breaking change は 0.4.0 で一括（CHANGELOG に移行ガイド） + +--- + +## D7 — CLI サブコマンド化 + +フラグ連鎖を廃止し、サブコマンドで整理。 + +``` +hpdft extract [OPTIONS] FILE # テキスト（現行 default） +hpdft extract text [OPTIONS] FILE # 明示的テキスト +hpdft extract images -p PAGE FILE # E3: 画像書き出し +hpdft diff FILE_A FILE_B # E2: 段落 diff +hpdft inspect page FILE PAGE # interpret-page 相当 +hpdft info FILE # メタデータ +``` + +- 0.3 の `-p`, `--geom`, `--legacy`, `--ruby` 等は `extract` サブコマンド配下へ +- 旧フラグ形式は **1 版 deprecated 警告** のうえ互換維持を検討 + +--- + +## E2 — テキスト diff（段落単位） + +### 粒度 + +**段落単位**。ページ番号 + ページ内段落 index + bbox 概算で「どこが変わったか」を返す。 + +### 設計 + +```haskell +data TextChange + = TextChange + { changePageA :: Maybe Int + , changePageB :: Maybe Int + , changeParaA :: Maybe Int + , changeParaB :: Maybe Int + , changeBBox :: Maybe Rect + , changeOld :: T.Text + , changeNew :: T.Text + } + | PageCountMismatch { pagesA :: Int, pagesB :: Int } + +compareDocuments :: LayoutOptions -> Document -> Document -> PdfResult [TextChange] +``` + +- 各ページを `layoutPageText` / `pageParagraphs` で段落列に分解（**document-level 結合は diff では使わない**） +- 正規化（空白・ヘッダ除去は LayoutOptions で制御）後、段落列の LCS +- CLI: `hpdft diff a.pdf b.pdf [--json]` +- ライブラリファースト。CLI は薄いラッパー + +--- + +## E3 — 画像抽出 + +### 意図する挙動 + +```bash +hpdft extract images -p 3 FILE.pdf -o ./out/ +# → FILE.pdf 3 ページ目の Image XObject を out/page3-001.jpg 等として書き出す +``` + +- **ファイル書き出しが本体**。bbox はファイル名や sidecar JSON に付随させる程度 +- `/Image` XObject の stream を Filter に応じてデコードし、JPEG はそのまま `.jpg`、raw/Flate は PNG 化または raw 保存 +- Form XObject 内のネスト画像は **再帰追跡**（Interpret の XObject 走査を拡張） +- インライン画像は 0.4.x 後半または 0.5 候補 +- **D5 前提:** 最低限 `/DCTDecode`（JPEG）。Flate+PNG predictor は既存。LZW 等はコーパス需要に応じて追加 + +--- + +## 0.3 残タスクの扱い + +| ID | 0.4 関連 | 判断 | +|----|---------|------| +| **D2** CI | E0/E2 のテスト自動化 | E0 前後で導入。0.3.1 ルビ PR から optional で可 | +| **D3** パーサ統一 | なし | **延期**（痛みが出たら） | +| **D5** Filter | E3 必須（DCTDecode） | **E3 直前に DCTDecode を先行**。LZW/ASCII85 は後追い | +| **D6** AES-256 | 暗号化 PDF 対象時 | コーパス次第。**0.4 スコープ外可** | +| **D7** CLI | E2/E3 の CLI | **E0 直後**（合意順序） | + +0.3 フォローアップ: + +| 項目 | 判断 | +|------|------| +| MediaBox 外フィルタ | E2/diff ノイズ削減のため **E0〜E2 で検討** | +| wmode 混在 interleave | **0.3.1 ルビでは既知制限のまま** | +| RTL / 行内逆順 | スコープ外継続 | + +--- + +## 推奨マイルストーン + +| 順 | 版 | 内容 | 状態 | +|----|-----|------|------| +| 1 | **0.3.1** | ルビ（Structure 優先 → geometry、`--ruby`、青空記法） | **完了** v0.3.1.0 | +| 2 | **0.4.0** | E0 公開 API + exposed-modules 整理 | **完了** | +| 3 | **0.4.0/1** | D2 CI（並行可） | **完了** v0.4.4.0 | +| 4 | **0.4.1** | D7 CLI サブコマンド | **完了** | +| 5 | **0.4.2** | D5（DCTDecode）+ E2 段落 diff | **完了** | +| 6 | **0.4.3** | E3 `extract images` | **完了** v0.4.3.0 | + +--- + +## 参照 + +- [青空文庫 ルビとルビのように付く文字](https://www.aozora.gr.jp/annotation/etc.html) +- [0.3 ロードマップ](0.3-roadmap.md) — 0.3.0.0 までの完了内容 diff --git a/dev/0.5-text-ux.md b/dev/0.5-text-ux.md new file mode 100644 --- /dev/null +++ b/dev/0.5-text-ux.md @@ -0,0 +1,138 @@ +# テキスト抽出 UX 方針（0.4.6 でリリース） + +Phase 1–2（全文 geom 逐次化・Layout O(n) 化）完了後に実装する CLI / 出力 UX の設計メモ。 + +> **最終決定（2026-07-05、0.4.6.0 として実装・リリース）**: 当初 0.5 として計画したが、TUI ビューワーは性能改善の一環として 0.4 系に含めることにした。役割分担は「`hpdft FILE` = 軽量ビューワー（TUI / パイプ時は legacy 逐次 stdout）」「`hpdft text FILE` = tagged→geom の高品質 stdout（0.4.5 までと同じ）」。`--no-tui` は不要になり削除（text は常に stdout、ビューワーは非 TTY で自動フォールバック）。以下の記述のうち「text デフォルトを legacy にする」案は破棄。`-o` ファイル出力（UX-3）は未実装のまま。 + +## 背景 + +| 用途 | 求める品質 | 許容レイテンシ | +|------|-----------|---------------| +| ターミナルでざっと読む（`-p` なし） | 低（stream-order で十分） | **即時・逐次** | +| ファイルに保存（`-o`） | 高（tagged → geom） | 数十秒〜数分可 | + +現状は `-p` なしでも tagged/geom 全文バッチを走らせるため、`book.pdf`（150 ページ）で 1 分以上無出力になる。legacy は約 10 秒で全文取得できるが、段落・読み順は劣る。 + +## 出力モード一覧（目標） + +``` +hpdft FILE # TUI プレビュー（legacy 逐次） +hpdft text FILE # 同上（明示） +hpdft text -o OUT FILE # 高品質全文をファイルへ（tagged → geom） +hpdft text -p N FILE # 1 ページ geom（現行どおり stdout） +hpdft text --legacy FILE # legacy 全文 stdout（スクリプト向け、TUI なし） +hpdft text --geom -o OUT FILE # geom のみファイル（デバッグ用） +``` + +`-o` 未指定かつ `-p 0`（全文）のときだけ TUI モード。`-p` 指定・`-o` 指定・パイプ先がファイルでない場合の挙動は下記。 + +## モード A: TUI プレビュー（デフォルト全文） + +### パイプライン + +- **legacy の `walkdown` をページ単位で逐次実行**（Document 1 回 open、ページツリーを walk しながら chunk 出力） +- geom / tagged は使わない（品質より速度・即応） + +### UI 仕様 + +- ターミナル**下半分**をビューポートとして固定（`tui` / `vty` / `brick` 等を検討；依存追加は cabal flag `tui` 推奨） +- 先頭から順次テキストを流し込み；バッファはビューポート行数 + α のみ保持（全文メモリ非保持） +- キー操作（最小）: + - `Space` / `j`: スクロール down + - `k`: up + - `g` / `G`: 先頭 / 末尾（末尾は legacy 全文取得完了後） + - `q`: 終了 + - `Ctrl-C`: 中断 +- **stderr** に進捗: `hpdft: page 12/150...`（オプション `--quiet` で抑制） + +### 非 TTY + +- stdout がパイプ / リダイレクトの場合は TUI を使わず **legacy 全文を stdout**（現行 `--legacy` 相当） +- `hpdft FILE | head` 等が壊れないようにする + +### 実装フェーズ（UX-1） + +1. [x] `PDF.Text.pdfToTextStreamDoc` — page ごとに `(pageNum, total, ByteString)` を IO callback +2. [x] `hpdft` — TTY 判定（`System.IO.hIsTerminalDevice stdout`） +3. [x] 依存なしプロトタイプ: 行単位 legacy 逐次 stdout（TUI 前の段階） +4. [x] 自前 ANSI で下半分ペイン（UX-2） +5. ~~cabal flag `tui` で optional dependency~~（2026-07-05 決定: 不要） + +## モード B: ファイル出力（`-o PATH`） + +### パイプライン + +- **tagged → geom フォールバック**（Phase 1 の逐次 geom を使用） +- `-o` 指定時のみ高品質パス；完了まで時間がかかってもよい +- 進捗は stderr（`hpdft: extracting page 40/150...`） + +### オプション整理 + +| オプション | `-o` あり | `-o` なし（TTY） | `-o` なし（pipe） | +|-----------|----------|-----------------|-----------------| +| （なし） | tagged→geom → file | legacy TUI | legacy stdout | +| `--geom` | geom → file | legacy TUI（geom は -o 専用） | legacy stdout | +| `--tagged` | tagged→geom → file | legacy TUI | legacy stdout | +| `--legacy` | legacy → file | legacy TUI | legacy stdout | +| `-p N` | page N geom → file | page N geom stdout | page N geom stdout | + +`-p` と `-o` の併用: 1 ページだけ高品質でファイルへ。 + +### 実装フェーズ（UX-3） + +1. `text` サブコマンドに `-o/--output FILE` 追加 +2. `-o` 時 `pdfToTextTaggedBSWith` / 逐次 geom をファイルへ +3. 原子性: `OUT.tmp` へ書き込み完了後 `rename`（途中 kill で壊れたファイルを残さない） +4. `-o` と TUI の相互排他を parser レベルで保証 + +## モード C: 既存互換 + +- `hpdft text --legacy FILE` — スクリプト用 legacy 全文 stdout（TUI なし、`--no-tui` フラグでも可） +- Golden / CI — 従来どおり geom/tagged を直接テスト（CLI デフォルト変更の回帰） + +## アーキテクチャ + +``` + ┌─────────────────┐ + │ openDocument │ + └────────┬────────┘ + │ + ┌──────────────────┼──────────────────┐ + ▼ ▼ ▼ + walkdownStream pageTextGeom pdfToTextTagged + (legacy/TUI) (-p / page API) (-o file) + │ │ │ + ▼ ▼ ▼ + TUI / stdout stdout OUT file +``` + +## 依存関係 + +``` +Phase 1–2（性能） → UX-3（-o 高品質ファイル） + → UX-1（legacy 逐次ストリーム） +UX-1 プロトタイプ → UX-2（brick TUI） +``` + +## ベンチマーク + +- `data/sample/book.pdf` — 全文 geom < 90s（Phase 1 合格） +- `scripts/bench_book.sh` — legacy / geom / -p1 計測 +- UX 追加後: TUI 初回表示 < 1s（legacy 1 ページ目相当） + +## 決定事項（2026-07-05） + +- **TUI ライブラリ: 軽量自前 ANSI に決定**。brick/vty は alternate screen（全画面）前提で「下半分固定」と相性が悪く、依存も重い。エスケープシーケンス直書き＋stdin raw モード（`hSetBuffering`/`hSetEcho`）で依存追加なし。cabal flag `tui` も不要になった +- **バッファは全行保持に変更**。`G`（末尾ジャンプ）に必要で、150 ページ書籍でも数 MB のため「viewport+α のみ保持」は簡素化して撤回 +- **`--no-tui` フラグ追加**。TTY でも plain stdout を強制（Mode C のスクリプト用途） +- **Windows は対象外**（ANSI 前提、Linux/macOS のみ） +- Golden テストはライブラリ API（`pdfToTextTaggedBS` / `pdfToTextBS`）直呼びのため CLI デフォルト変更の影響なし + +## 未決事項 + +- `-o` で tagged と geom の両方を出すか（`OUT.tagged.txt` / `OUT.geom.txt`）— 現案は **tagged→geom の単一結果**のみ；比較用は `--geom` 併用で別名保存 + +## バージョン + +0.4.6.0（リリース済み）: UX-1（legacy 逐次ストリーム）+ UX-2（自前 ANSI TUI ビューワー） +0.5 以降: `-o` ファイル出力統合（UX-3） diff --git a/dev/README.md b/dev/README.md new file mode 100644 --- /dev/null +++ b/dev/README.md @@ -0,0 +1,12 @@ +# 開発者向けメモ + +このディレクトリは **hpdft の開発・設計メモ** 用です。利用者向けの解説は [`docs/`](../docs/) のみに置きます。 + +| ファイル | 内容 | +|----------|------| +| [performance-0.4.md](performance-0.4.md) | 0.4.5 前後の全文テキスト抽出の高速化（調査・対策・計測） | +| [0.3-roadmap.md](0.3-roadmap.md) | 0.3.0.0 までの開発ロードマップ（完了） | +| [0.4-roadmap.md](0.4-roadmap.md) | 0.4 系 API / diff / images / form の計画 | +| [0.5-text-ux.md](0.5-text-ux.md) | 0.5 候補: CLI 出力 UX（TUI プレビュー / `-o` ファイル出力） | + +ベンチマーク用 PDF（`data/sample/book.pdf` など）は `.gitignore` 対象のためリポジトリには含めません。手元に置いて `scripts/bench_book.sh` を実行してください。 diff --git a/dev/performance-0.4.md b/dev/performance-0.4.md new file mode 100644 --- /dev/null +++ b/dev/performance-0.4.md @@ -0,0 +1,182 @@ +# 全文テキスト抽出の高速化（0.4.5） + +2026-07-05。`data/sample/book.pdf`（150 ページ、約 8 MB）を契機に、tagged / geometry パイプラインの全文抽出が実用時間を大きく超える問題を調査し、段階的に対策した記録です。 + +## 症状 + +| コマンド | 所要時間（目安） | +|----------|------------------| +| `hpdft --legacy book.pdf` | 約 8 秒 | +| `hpdft -p 1 book.pdf` | 約 0.5 秒 | +| `hpdft --geom book.pdf`（修正前） | **120 秒超**（タイムアウト相当） | +| `hpdft book.pdf`（デフォルト = tagged→geom） | 同上 | + +`-p` なしの全文が `-p 1` の 150 倍どころか **300 倍以上** 遅く、legacy より桁違いに遅い。 + +## 誤解しやすい点：遅延読み込みは壊れていない + +0.3 で入れた xref 遅延パース（`buildIndex` の lazy `Map`）は正常に動作している。 + +- 暗号化 7923 オブジェクトの `test.pdf` で `-p 1` が約 0.8 秒なのは、全オブジェクトを先読みしていない証拠。 +- 遅い原因は「オブジェクト index の構築」ではなく、**全文パス固有の処理**にある。 + +## 原因の切り分け + +### 1. 全文と `-p` でパイプラインが違う + +- `-p N` → `pageTextGeomWith`（1 ページだけ interpret + layout） +- 全文 → `interpretAllPages` で全 `PageItem` を保持 → `layoutDocumentWith`（document-level のヘッダ除去・ページ跨ぎ段落結合） + +ページ数に比例するのは当然だが、150 × 0.5 秒 ≈ 75 秒を大きく超えていた。 + +### 2. バッチ処理と O(n²) の蓄積 + +Phase 1（逐次化）以前の全文 geom: + +``` +openDocument + → interpretAllPages（全 [[PageItem]] を一括生成・保持） + → layoutDocumentWith / documentParagraphs +``` + +`documentParagraphs` 内の `done ++ ...` がページ数・段落数に対して O(n²) だった（`assembleTagged` の `T.append` 連鎖と同型）。 + +tagged フォールバック時は全ページを **2 回** interpret していた（tagged 判定用 + geom 再実行）。 + +### 3. ページごとに同じ重い仕事を繰り返す（キャッシュ前） + +In-process ベンチマーク（`scripts/bench_pages.hs`、Haskell のみ、Python は使わない）: + +| 計測 | 時間 | +|------|------| +| 全 150 ページ interpret+layout 合計 | **134 秒** | +| 重いページ（p50）初回 | 0.76 秒 | +| 同じ p50 を 2 回目以降 | 0.17 秒 | + +オブジェクト index は共有されるが、次は **毎ページ再計算** されていた: + +- フォントテーブル（`fontInfo` / `findCMap` / ToUnicode CMap パース） +- FlateDecode stream の展開（`rawStreamByRef`） +- 埋め込み OpenType の cmap パース（`noToUnicodeFromDict`） + +日本語書籍 PDF はフォント参照数は少なくても CMap が巨大なため、150 回の繰り返しが支配的だった。 + +### 4. 真のボトルネック（プロファイル後） + +キャッシュと並列化後も `--geom` は 40 秒台。GHC プロファイル（`-p -N1`）で判明: + +- **`PDF.Layout.filterPageGlyphs` が約 54%**（継承コスト含む） +- 外れ値グリフ除去の `baselineBand` が **グリフ 1 個ごとにページ全グリフを sort** しており、O(n² log n) +- `readToken` / interpret 本体は top 10 外（修正後は主因に移行） + +これが「ページ並列化だけでは足りない」「`-p` ループより全文が異常に遅い」主因だった。 + +## 実施した対策（時系列） + +### Step A: 全文 geom の逐次化 + Layout O(n) 化 + +**変更:** `PDF.Text`, `PDF.Layout` + +- `interpretAllPages` 一括 → ページごと `interpretPageLinesRaw` → `PageLines` のみ保持 +- `documentParagraphsFromPageLines` を新設、`Data.DList` で `done ++` を O(n) 化 +- tagged → geom フォールバック時の二重 interpret を解消 + +**効果:** 120 秒超・未完 → **約 142 秒で完走**（まだ遅いが hang 解消）。Layout の document-level 上乗せは数秒程度。 + +### Step B: Document レベルキャッシュ + +**変更:** `PDF.Document`, `PDF.Interpret`, `PDF.Image` + +`Document` に lazy knot-tied な Map を追加: + +```haskell +docStreamCache :: Map Int (PdfResult BSL.ByteString) -- 展開済み stream +docFontCache :: Map Int FontInfo -- 構築済み FontInfo +``` + +初回参照時だけ計算し、同一 Document 内では共有。`IState` 経由で interpret が参照。 + +**効果（book.pdf）:** + +| 指標 | Before | After | +|------|--------|-------| +| 全ページ合計（bench_pages） | 136 s | **95 s** | +| `--geom` 全文 | 142 s | **98 s** | + +### Step C: ページ並列化 + +**変更:** `PDF.Text`, `hpdft.cabal` + +- `Control.Parallel.Strategies` の `parList` でページ単位 interpret を並列化 +- `FontInfo` に関数が含まれるため `NFData` 不可 → `forcePageLines` / `forcePageItems` で手動 seq +- exe / test に `-threaded -rtsopts` + +**効果:** geom 98 s → **64 s**（8 コア、150 sparks 全変換） + +### Step D: RTS チューニング + +**変更:** `hpdft.cabal` + +- `-with-rtsopts=-N -A64m`（Gen0 GC が並列実行時に ~20 s 消費していたのを抑制） + +**効果:** geom **42 s** 程度。legacy は `-N` だけだと 10 s 台に悪化していたが `-A64m` で **6.8 s** に回復。 + +### Step E: `filterPageGlyphs` の band 事前計算 + +**変更:** `PDF.Layout` + +- 水平・垂直それぞれ `baselineBand` を **1 回だけ** 計算し、全グリフの membership 判定に再利用 +- 出力は golden / diff で **byte-identical** を確認 + +**効果（最終、book.pdf 150 ページ）:** + +| モード | 修正前 | 修正後 | +|--------|--------|--------| +| `--geom` 全文 | 142 s+ | **12.9 s** | +| デフォルト（tagged）全文 | 120 s+ | **13.0 s** | +| `test.pdf` 全文（53 p） | 56 s | **16.3 s** | +| `--legacy` | 6.8 s | 6.8 s | +| `-p 1` | 0.45 s | 0.67 s（`-N` 起動オーバーヘッド） | + +## 並列化は有効か + +**有効。ただしキャッシュとアルゴリズム修正が先。** + +| 順序 | 結果 | +|------|------| +| 並列化のみ（キャッシュ前） | CPU 総量は減らない（全コアでフォント再構築を並列実行するだけ） | +| キャッシュ → 並列化 | 95 s → 64 s | +| 上記 + RTS + filterPageGlyphs | **13 s** | + +`interpretPageItems` は `PdfResult` の純粋計算なので `parList` は素直に適用できる。ページ順序は Strategies が保持するため出力は決定的。 + +## ベンチマークの使い方 + +```bash +# CLI ベンチ（legacy / geom / -p1） +bash scripts/bench_book.sh + +# In-process ベンチ（openDocument 1 回、ページ単価） +cabal exec -- ghc -O2 scripts/bench_pages.hs -o /tmp/bench_pages -outputdir /tmp/bench_pages_obj +/tmp/bench_pages data/sample/book.pdf +``` + +`data/sample/book.pdf` は `.gitignore` 対象。手元に配置して使う。 + +## 残課題 + +1. **interpret トークナイザ** — プロファイル上、Step E 後は ByteString 走査が次の主因。全面書き換えはリスク大。 +2. **library の `-O1`** — exe のみ `-O2`。library も `-O2` にするとさらに短縮の余地あり。 +3. **`-p 1` の微増** — `-N` スレッド起動コスト。気になる場合は RTS を環境変数で `-N1` に限定可能。 +4. **UX** — 全文の TTY 表示は legacy 逐次 + TUI、ファイル出力は tagged→geom。方針は [0.5-text-ux.md](0.5-text-ux.md)。 + +## 関連ファイル + +| パス | 役割 | +|------|------| +| `src/PDF/Document.hs` | `docStreamCache`, `docFontCache` | +| `src/PDF/Text.hs` | 逐次 geom、並列 `parList` | +| `src/PDF/Layout.hs` | `filterPageGlyphs` 修正、DList、`layoutDocumentFromPageLines` | +| `src/PDF/Interpret.hs` | キャッシュ参照、`forcePageItems` 向け | +| `scripts/bench_book.sh` | CLI 計測 | +| `scripts/bench_pages.hs` | In-process 計測 | diff --git a/docs/library.md b/docs/library.md new file mode 100644 --- /dev/null +++ b/docs/library.md @@ -0,0 +1,217 @@ +# hpdft library guide + +hpdft is a Haskell library (and CLI) for parsing PDF files: text extraction with geometry and tagged structure, page-level paragraph regions, document diff, image export, and Form XObject extraction. + +## Installation + +Add a dependency on Hackage (when published): + +```cabal +build-depends: hpdft >= 0.4.6 +``` + +Or build from this repository: + +```bash +cabal install +# library + hpdft CLI + examples +``` + +Requires GHC 9.14+ (see `hpdft.cabal`). + +## Opening a document + +Load a file once and reuse the parsed `Document` for every operation: + +```haskell +import PDF.Document (openDocument) +import PDF.Error (PdfError(..), PdfResult) + +main :: IO () +main = do + result <- openDocument "paper.pdf" Nothing + case result of + Left err -> print err + Right doc -> ... +``` + +For encrypted PDFs, pass `Just password` as the second argument. Failures (broken xref, missing objects, bad password) are returned as `Left` values of type `PdfError` in `PdfResult` (`Either PdfError a`) instead of raising exceptions. + +## Text extraction + +### Streaming (viewer pipeline) + +As of 0.4.6, the bare `hpdft FILE` viewer uses legacy stream-order extraction streamed page by page. Library callers use `pdfToTextStreamDoc`: + +```haskell +import PDF.Text (pdfToTextStreamDoc) +import qualified Data.ByteString.Lazy as BSL + +pdfToTextStreamDoc doc $ \page total bs -> do + putStrLn ("page " ++ show page ++ "/" ++ show total) + BSL.putStr bs +``` + +Concatenating all page outputs in order equals `fst (pdfToTextDoc doc)`. + +### Default pipeline (tagged → geometry) + +The CLI default (`hpdft text FILE`) matches `pdfToTextTaggedDoc`: + +```haskell +import PDF.Text (pdfToTextTaggedDoc) +import qualified Data.ByteString.Lazy.Char8 as BSL + +case pdfToTextTaggedDoc doc of + Left err -> print err + Right bs -> BSL.putStr bs +``` + +When the PDF has a usable tagged structure tree, text is assembled in logical order. Otherwise hpdft falls back to geometry-based paragraph reconstruction (same as `pdfToTextGeomDoc`). + +### Geometry-only + +```haskell +import PDF.Text (pdfToTextGeomDoc) +``` + +Equivalent to `hpdft text --geom FILE`. + +### Tagged-only attempt + +Use `pdfToTextTaggedDocWith` / `pdfToTextTaggedBSWith` with `LayoutOptions`. When no structure tree exists, these still fall back to geometry. + +### Legacy stream-order extractor + +```haskell +import PDF.Text (pdfToTextDoc, pdfToTextStreamDoc) +``` + +`pdfToTextDoc` returns `(ByteString, [PdfWarning])` for the full document in one pass (not `PdfResult`). `pdfToTextStreamDoc` invokes a callback per page in document order; see above. Same output style as `hpdft text --legacy FILE`. Prefer geometry or tagged paths when reading order matters. + +### Layout options + +Footnotes and ruby (Aozora bunko notation) are controlled by `PDF.Layout.LayoutOptions`: + +```haskell +import PDF.Layout (LayoutOptions(..), defaultLayoutOptions) + +opts = defaultLayoutOptions { optRuby = True, optFootnotes = False } +``` + +Pass `opts` to `pdfToTextGeomDocWith`, `pdfToTextTaggedDocWith`, page APIs, and diff. + +## Page-level API + +`PDF.Page` exposes stable page enumeration and structured extraction: + +| Function | Role | +|----------|------| +| `pageCount` | Number of pages | +| `pageRefAt` | Resolve 1-based page number to internal page reference | +| `pageItems` | Raw interpreted page items (glyphs, graphics) | +| `pageGlyphs` | Glyph list for one page | +| `pageLines` | Layout lines with `LayoutOptions` | +| `pageParagraphs` | Paragraph texts for one page | +| `pageRegions` | Paragraph text plus bounding box and indices | + +Example: + +```haskell +import PDF.Layout (defaultLayoutOptions) +import PDF.Page (pageCount, pageRefAt, pageRegions) + +n <- pageCount doc +ref <- pageRefAt doc 1 +regions <- pageRegions doc ref defaultLayoutOptions +``` + +See `examples/page-api/Main.hs` for a runnable program. + +## Document diff + +`PDF.Diff.compareDocuments` aligns pages by number and diffs paragraph text: + +```haskell +import PDF.Diff (compareDocuments, TextChange(..)) +import PDF.Layout (defaultLayoutOptions) + +changes <- compareDocuments defaultLayoutOptions docA docB +``` + +Each `TextChange` records old/new paragraph text and optional page/paragraph indices. A `PageCountMismatch` entry appears when page counts differ. + +CLI equivalent: `hpdft diff FILE_A FILE_B`. + +## Image extraction + +`PDF.Image.extractPageImages` returns `/Image` XObjects on a page (including nested forms): + +```haskell +import PDF.Image (extractPageImages, extractPageImagesToDir) + +images <- extractPageImages doc pageNum +paths <- extractPageImagesToDir doc pageNum "out/" +``` + +JPEG streams are passed through; 8-bit DeviceRGB/Gray become minimal PNG. Inline images (`BI` … `EI`) are not extracted yet. + +## Form extraction + +`PDF.FormExtract` exports a named Form XObject to a standalone vector PDF: + +```haskell +import PDF.FormExtract (pageFormNames, extractFormPdf, extractFormToFile) + +names <- pageFormNames doc pageNum +bytes <- extractFormPdf doc pageNum "Fm42" +path <- extractFormToFile doc pageNum "Fm42" "out/" +``` + +`pageFormNames` lists top-level form names on the page resources (not nested forms). + +## Example programs + +From the repository root: + +```bash +cabal run extract-text -- data/fixtures/classic.pdf +cabal run page-api -- data/fixtures/paragraphs.pdf +``` + +With no argument, each example walks up from the current directory to find `data/fixtures/…`. + +Sources: `examples/extract-text/Main.hs`, `examples/page-api/Main.hs`. + +## API reference (Haddock) + +Generate HTML documentation locally: + +```bash +cabal haddock --haddock-all +``` + +Open `dist/doc/html/hpdft/index.html` (path may vary slightly by cabal version). + +Primary public modules: + +| Module | Purpose | +|--------|---------| +| `PDF.Document` | `openDocument`, `Document` | +| `PDF.Error` | `PdfResult`, `PdfError`, `PdfWarning` | +| `PDF.Text` | Full-document text extraction | +| `PDF.Layout` | `LayoutOptions`, paragraph heuristics | +| `PDF.Page` | Page count, paragraphs, regions | +| `PDF.Diff` | Paragraph-level diff | +| `PDF.Image` | Image XObject extraction | +| `PDF.FormExtract` | Form XObject export | + +Lower-level modules (`PDF.Interpret`, `PDF.Structure`, `PDF.DocumentStructure`, …) are exposed for advanced use but may change more often. + +## Known limitations + +- RTL horizontal text is unsupported. +- Inline images are not extracted (see CHANGELOG 0.4.3). +- Some image color spaces are written as `.raw` plus JSON sidecar. +- Legacy stream-order extraction remains for comparison only. +- Details and roadmap: [CHANGELOG](../CHANGELOG.md). Developer notes: [dev/](../dev/). diff --git a/examples/extract-text/Main.hs b/examples/extract-text/Main.hs new file mode 100644 --- /dev/null +++ b/examples/extract-text/Main.hs @@ -0,0 +1,60 @@ +-- | Minimal text extraction example for hpdft. +-- +-- Usage: +-- +-- @ +-- cabal run extract-text -- path/to/file.pdf +-- cabal run extract-text +-- -- uses data/fixtures/classic.pdf when run from the repo tree +-- @ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import PDF.Document (openDocument) +import PDF.Text (pdfToTextTaggedDoc) + +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.FilePath ((), takeDirectory) + +import qualified Data.ByteString.Lazy.Char8 as BSL + +main :: IO () +main = do + args <- getArgs + pdf <- case args of + (f : _) -> return f + _ -> defaultFixture + result <- openDocument pdf Nothing + case result of + Left err -> print err >> exitFailure + Right doc -> case pdfToTextTaggedDoc doc of + Left err -> print err >> exitFailure + Right bs -> BSL.putStr bs + +defaultFixture :: IO FilePath +defaultFixture = findRepoFile "data/fixtures/classic.pdf" + +findRepoFile :: FilePath -> IO FilePath +findRepoFile rel = do + cwd <- getCurrentDirectory + go cwd + where + go dir = do + let candidate = dir rel + exists <- doesFileExist candidate + if exists + then return candidate + else + let parent = takeDirectory dir + in if parent == dir + then do + putStrLn $ + "usage: extract-text [FILE.pdf]\n" + ++ " (default fixture not found: " + ++ rel + ++ ")" + exitFailure + else go parent diff --git a/examples/page-api/Main.hs b/examples/page-api/Main.hs new file mode 100644 --- /dev/null +++ b/examples/page-api/Main.hs @@ -0,0 +1,94 @@ +-- | Page-level API example: count pages and print paragraph regions. +-- +-- Usage: +-- +-- @ +-- cabal run page-api -- path/to/file.pdf +-- cabal run page-api +-- -- uses data/fixtures/paragraphs.pdf when run from the repo tree +-- @ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import PDF.Document (openDocument) +import PDF.Error (PdfResult) +import PDF.Interpret (Rect(..)) +import PDF.Layout (LayoutOptions(..), defaultLayoutOptions) +import PDF.Page (PageRegion(..), pageCount, pageParagraphs, pageRefAt, pageRegions) + +import Control.Monad (forM_) +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.FilePath ((), takeDirectory) + +import qualified Data.Text as T + +main :: IO () +main = do + args <- getArgs + pdf <- case args of + (f : _) -> return f + _ -> defaultFixture + result <- openDocument pdf Nothing + case result of + Left err -> print err >> exitFailure + Right doc -> do + n <- runOrDie (pageCount doc) + putStrLn $ "pages: " ++ show n + let opts = defaultLayoutOptions {optRuby = False} + forM_ [1 .. n] $ \pageNo -> do + ref <- runOrDie (pageRefAt doc pageNo) + paras <- runOrDie (pageParagraphs doc ref opts) + regions <- runOrDie (pageRegions doc ref opts) + putStrLn $ "--- page " ++ show pageNo ++ " (" ++ show (length paras) ++ " paragraphs) ---" + forM_ regions $ \PageRegion{regionParagraph = idx, regionBBox = bbox, regionText = txt} -> + putStrLn $ + " [" + ++ show idx + ++ "] " + ++ showRect bbox + ++ ": " + ++ T.unpack (T.take 80 txt) + +defaultFixture :: IO FilePath +defaultFixture = findRepoFile "data/fixtures/paragraphs.pdf" + +findRepoFile :: FilePath -> IO FilePath +findRepoFile rel = do + cwd <- getCurrentDirectory + go cwd + where + go dir = do + let candidate = dir rel + exists <- doesFileExist candidate + if exists + then return candidate + else + let parent = takeDirectory dir + in if parent == dir + then do + putStrLn $ + "usage: page-api [FILE.pdf]\n" + ++ " (default fixture not found: " + ++ rel + ++ ")" + exitFailure + else go parent + +showRect :: Rect -> String +showRect r = + "(" + ++ show (rectX0 r) + ++ "," + ++ show (rectY0 r) + ++ ")-(" + ++ show (rectX1 r) + ++ "," + ++ show (rectY1 r) + ++ ")" + +runOrDie :: PdfResult a -> IO a +runOrDie (Right x) = return x +runOrDie (Left err) = print err >> exitFailure diff --git a/hpdft.cabal b/hpdft.cabal --- a/hpdft.cabal +++ b/hpdft.cabal @@ -1,14 +1,14 @@ -cabal-version: 3.0 +cabal-version: 3.12 name: hpdft -version: 0.1.1.3 -synopsis: A tool for looking through PDF file using Haskell +version: 0.4.6.0 +synopsis: PDF parsing library and CLI for text, layout, diff, images, and forms description: - - A command line PDF-to-text converter. It may take a much longer than other similar tools but could yield better results. - - This package can also serve as a library for working with text data in PDF files. - You could write your own PDF-to-text converter for some particular PDF files, utilizing any meta data or special data structures of those. - + hpdft is a Haskell library and command-line tool for parsing PDF files. + The library exposes document loading, geometry- and tagged-PDF text extraction, + page-level paragraph regions, paragraph-level diff, image XObject export, and + Form XObject extraction to standalone PDFs. + The @hpdft@ executable provides the same features for shell workflows. + See @docs/library.md@ for a usage guide and @examples/@ for sample programs. homepage: https://github.com/k16shikano/hpdft license: MIT license-file: LICENSE @@ -18,59 +18,156 @@ category: PDF build-type: Simple extra-source-files: README.md + , CHANGELOG.md + , docs/library.md + , dev/README.md + , dev/performance-0.4.md + , dev/0.3-roadmap.md + , dev/0.4-roadmap.md + , dev/0.5-text-ux.md + , scripts/bench_book.sh + , scripts/bench_pages.hs + , examples/extract-text/Main.hs + , examples/page-api/Main.hs data-dir: data/ data-files: map/Adobe-Japan1-6.map +source-repository head + type: git + location: https://github.com/k16shikano/hpdft + library hs-source-dirs: src/ exposed-modules: PDF.PDFIO + , PDF.Document , PDF.ContentStream , PDF.Character , PDF.Cmap , PDF.Definition , PDF.DocumentStructure + , PDF.Error , PDF.Outlines , PDF.Object , PDF.OpenType , PDF.CFF + , PDF.Encrypt + , PDF.Text + , PDF.Page + , PDF.Diff + , PDF.Image + , PDF.FormExtract , PDF.Type1 + , PDF.Matrix + , PDF.Interpret + , PDF.Layout + , PDF.Structure other-modules: Paths_hpdft other-extensions: OverloadedStrings build-depends: attoparsec >= 0.14.4 && < 0.15 - , base >= 4.18.0 && < 4.19 + , base >= 4.20.0 && < 4.23 , binary >= 0.8.9 && < 0.9 - , bytestring >= 0.11.4 && < 0.12 - , containers >= 0.6.7 && < 0.7 - , directory >= 1.3.8 && < 1.4 - , file-embed >= 0.0.15 && < 0.1 + , bytestring >= 0.11.5 && < 0.13 + , containers >= 0.7 && < 0.9 + , crypton >= 0.34 && < 0.36 + , directory >= 1.3.9 && < 1.4 + , dlist >= 1.0 && < 1.1 + , file-embed >= 0.0.16 && < 0.1 + , filepath >= 1.5.2 && < 1.6 , memory >= 0.18.0 && < 0.19 , optparse-applicative >= 0.18.1 && < 0.19 - , parsec >=3.0 && <3.2 + , parallel >= 3.2.2 && < 3.4 + , deepseq >= 1.4.8 && < 1.6 + , parsec >= 3.1.18 && < 3.2 , semigroups >= 0.20 && < 0.21 - , text >= 2.0.2 && < 2.1 + , text >= 2.1.2 && < 2.2.2 , utf8-string >= 1.0.2 && < 1.1 - , zlib >= 0.6.3 && < 0.7 - autogen-modules: Paths_hpdft - default-language: Haskell2010 + , zlib >= 0.7.1 && < 0.8 + autogen-modules: Paths_hpdft + default-language: Haskell2010 buildable: True executable hpdft main-is: hpdft.hs + ghc-options: -O2 -threaded -rtsopts "-with-rtsopts=-N -A64m" hs-source-dirs: . other-modules: Paths_hpdft + , TuiPreview + , TuiScroll other-extensions: OverloadedStrings - build-depends: base >= 4.18.0 && < 4.19 - , bytestring >= 0.11.4 && < 0.12 + build-depends: array >= 0.5 && < 0.6 + , base >= 4.20.0 && < 4.23 + , bytestring >= 0.11.5 && < 0.13 , hpdft , memory >= 0.18.0 && < 0.19 , optparse-applicative >= 0.18.1 && < 0.19 , regex-base >= 0.94.0 && < 0.95 , regex-tdfa >= 1.3.2 && < 1.4 , semigroups >= 0.20 && < 0.21 - , text >= 2.0.2 && < 2.1 + , terminal-size >= 0.3 && < 0.4 + , text >= 2.1.2 && < 2.2.2 , utf8-string >= 1.0.2 && < 1.1 - default-language: Haskell2010 + autogen-modules: Paths_hpdft + default-language: Haskell2010 buildable: True + +test-suite hpdft-golden + type: exitcode-stdio-1.0 + main-is: Golden.hs + hs-source-dirs: test + ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A64m" + build-depends: base >= 4.20.0 && < 4.23 + , bytestring >= 0.11.5 && < 0.13 + , directory >= 1.3.9 && < 1.4 + , filepath >= 1.5.2 && < 1.6 + , hpdft + default-language: Haskell2010 + +test-suite hpdft-unit + type: exitcode-stdio-1.0 + main-is: Unit.hs + hs-source-dirs: test + , . + ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A64m" + build-depends: base >= 4.20.0 && < 4.23 + , bytestring >= 0.11.5 && < 0.13 + , containers >= 0.7 && < 0.9 + , directory >= 1.3.9 && < 1.4 + , filepath >= 1.5.2 && < 1.6 + , hpdft + , text >= 2.1.2 && < 2.2.2 + other-modules: TuiScroll + default-language: Haskell2010 + +executable interpret-page + main-is: scripts/interpret_page.hs + hs-source-dirs: . + build-depends: base >= 4.20.0 && < 4.23 + , hpdft + , text >= 2.1.2 && < 2.2.2 + default-language: Haskell2010 + buildable: True + +executable extract-text + main-is: Main.hs + hs-source-dirs: examples/extract-text + build-depends: base >= 4.20.0 && < 4.23 + , bytestring >= 0.11.5 && < 0.13 + , directory >= 1.3.9 && < 1.4 + , filepath >= 1.5.2 && < 1.6 + , hpdft + default-language: Haskell2010 + buildable: True + +executable page-api + main-is: Main.hs + hs-source-dirs: examples/page-api + build-depends: base >= 4.20.0 && < 4.23 + , directory >= 1.3.9 && < 1.4 + , filepath >= 1.5.2 && < 1.6 + , hpdft + , text >= 2.1.2 && < 2.2.2 + default-language: Haskell2010 + buildable: True diff --git a/hpdft.hs b/hpdft.hs --- a/hpdft.hs +++ b/hpdft.hs @@ -7,170 +7,681 @@ import PDF.Definition import PDF.Object +import PDF.Document (Document(..), openDocument, docRootRef, docInfoDict) import PDF.DocumentStructure import PDF.PDFIO import PDF.Outlines +import PDF.Encrypt (Security) +import PDF.Text (pdfToTextGeomBSWith, pdfToTextTaggedBSWith, pageTextGeomWith, pdfToTextStreamDoc) +import PDF.Layout (LayoutOptions(..), defaultLayoutOptions) +import PDF.Diff (TextChange(..), compareDocuments) +import PDF.Image (extractPageImagesToDir) +import PDF.FormExtract (pageFormNames, extractFormToFile) +import PDF.Error (PdfError(..), PdfResult, PdfWarning(..), renderPdfWarning) import System.Environment (getArgs) +import System.Exit (exitWith, ExitCode(..)) +import System.IO (hPutStr, hPutStrLn, stderr, stdout, hFlush, hIsTerminalDevice) +import System.IO.Error (isDoesNotExistError) +import Control.Exception (catch, IOException, ioError) +import Control.Monad (when) import Data.ByteString.UTF8 (ByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Text.Lazy as TL (unpack) import Data.Text.Lazy.Encoding as TL -import Data.List (nub, find) -import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.List (find, intercalate) +import Data.Maybe (listToMaybe) import Options.Applicative import Data.Semigroup ((<>)) import Text.Regex.Base.RegexLike ( makeRegex ) import Text.Regex.TDFA.String ( regexec ) +import TuiPreview (runTuiPreview) -import Options.Applicative (strOption) -import Control.Monad (when) import PDF.Definition (Obj(PdfStream)) +import Data.IORef (newIORef, readIORef, writeIORef) -import Debug.Trace +import qualified Paths_hpdft as Autogen (version) +import Data.Version (showVersion) -initstate = PSR { linex=0 - , liney=0 - , absolutex=0 - , absolutey=0 - , leftmargin=0.0 - , text_lm=(1,0,0,1,0,0) - , text_m=(1,0,0,1,0,0) - , text_break=False - , top=0.0 - , bottom=0.0 - , fontfactor=1 - , curfont="" - , fontmaps=[] - , cmaps=[] - , colorspace="" - , xcolorspaces=[] - } +deprecationMsg :: String +deprecationMsg = + "hpdft: flat flags are deprecated; use subcommands (e.g. hpdft text, hpdft info)" +subcommandNames :: [String] +subcommandNames = + [ "text", "image", "form" + , "diff", "info", "title", "toc", "trailer", "object", "refs", "grep" + ] main :: IO () -main = hpdft =<< execParser opts - where - opts = info (options <**> helper) - (fullDesc - <> progDesc "Show text of a PDF file" - <> header "hpdft - a PDF parsing tool" ) +main = do + args <- getArgs + when (listToMaybe args == Just "extract") $ do + hPutStrLn stderr "hpdft: 'extract' subcommand removed; use text, image, or form" + exitWith (ExitFailure 1) + let useSubcommands = case listToMaybe args of + Just a | a `elem` subcommandNames -> True + _ -> False + isMeta = any (`elem` args) ["--help", "-h", "--version", "-V"] + parserExtras = helper <**> simpleVersioner versionInfo + cmd <- if useSubcommands + then execParser (info (commandParser <**> parserExtras) (fullDesc <> header versionInfo)) + else if isMeta + then execParser (info (legacyCmd <**> parserExtras) (fullDesc <> header versionInfo)) + else do + when (legacyNeedsDeprecation args) $ + hPutStrLn stderr deprecationMsg + execParser (info (legacyCmd <**> parserExtras) (fullDesc <> header versionInfo)) + runCmd cmd --- option parser +versionInfo :: String +versionInfo = "hpdft - a PDF to text converter, version " <> showVersion Autogen.version -data CmdOpt = CmdOpt { - page :: Int, - ref :: Int, - grep :: String, - refs :: Bool, - pdftitle :: Bool, - pdfinfo :: Bool, - pdfoutline :: Bool, - trailer :: Bool, - file :: FilePath +-- | Top-level command dispatch. +data Cmd + = CmdText ExtractOpt + | CmdView FilePath (Maybe String) + | CmdImage ImagesOpt + | CmdForm FormOpt + | CmdDiff DiffOpt + | CmdInfo FilePath (Maybe String) + | CmdTitle FilePath (Maybe String) + | CmdToc FilePath (Maybe String) + | CmdTrailer FilePath + | CmdObject Int FilePath (Maybe String) + | CmdRefs FilePath (Maybe String) + | CmdGrep String FilePath (Maybe String) + +data ExtractOpt = ExtractOpt + { eoPage :: Int + , eoGeom :: Bool + , eoTagged :: Bool + , eoLegacy :: Bool + , eoQuiet :: Bool + , eoFootnotes :: Bool + , eoRuby :: Bool + , eoPassword :: String + , eoFile :: FilePath } -options :: Parser CmdOpt -options = CmdOpt - <$> option auto - ( long "page" - <> short 'p' - <> value 0 - <> metavar "PAGE" - <> help "Page number (nomble)" ) - <*> option auto - ( long "ref" - <> short 'r' - <> value 0 - <> metavar "REF" - <> help "Object reference" ) - <*> strOption - ( long "grep" - <> short 'g' - <> value "" - <> metavar "RegExp" - <> help "grep PDF" ) - <*> switch - ( long "refs" - <> short 'R' - <> help "Show object references in page order" ) - <*> switch - ( long "title" - <> short 'T' - <> help "Show title (from metadata)" ) - <*> switch - ( long "info" - <> short 'I' - <> help "Show PDF metainfo" ) - <*> switch - ( long "toc" - <> short 'O' - <> help "Show table of contents (from metadata) " ) - <*> switch - ( long "trailer" - <> help "Show the trailer of PDF" ) - <*> strArgument - ( help "input pdf file" - <> metavar "FILE" - <> action "file" ) +data ImagesOpt = ImagesOpt + { ioPage :: Int + , ioOut :: FilePath + , ioPassword :: String + , ioFile :: FilePath + } -hpdft :: CmdOpt -> IO () -hpdft (CmdOpt 0 0 "" False False False False False fn) = pdfToText fn -hpdft (CmdOpt 0 0 "" False True _ _ _ fn) = showTitle fn -hpdft (CmdOpt 0 0 "" False _ True _ _ fn) = showInfo fn -hpdft (CmdOpt 0 0 "" False _ _ True _ fn) = showOutlines fn -hpdft (CmdOpt 0 0 "" False _ _ _ True fn) = print =<< getTrailer fn -hpdft (CmdOpt 0 0 "" True _ _ _ _ fn) = print =<< refByPage fn -hpdft (CmdOpt n 0 "" False _ _ _ _ fn) = showPage fn n -hpdft (CmdOpt 0 r "" False _ _ _ _ fn) = showContent fn r -hpdft (CmdOpt 0 0 r False _ _ _ _ fn) = grepPDF fn r -hpdft _ = return () +data FormOpt = FormOpt + { foPage :: Int + , foName :: Maybe String + , foOut :: FilePath + , foPassword :: String + , foFile :: FilePath + } --- | Get a whole text from 'filename'. It works as: --- (1) grub objects --- (2) parse within each object, deflating its stream --- (3) linearize stream +data DiffOpt = DiffOpt + { doGeom :: Bool + , doLegacy :: Bool + , doRuby :: Bool + , doJson :: Bool + , doPassword :: String + , doFileA :: FilePath + , doFileB :: FilePath + } -pdfToText filename = do - objs <- getPDFObjFromFile filename - rootref <- getRootRef filename - BSL.putStrLn $ walkdown initstate rootref objs +commandParser :: Parser Cmd +commandParser = subparser + ( command "text" (info (CmdText <$> extractOpts) (progDesc "Extract text to stdout (tagged -> geometry)")) + <> command "image" (info (CmdImage <$> imagesOpts) (progDesc "Extract image XObjects from a page")) + <> command "form" (info (CmdForm <$> formOpts) (progDesc "List or extract top-level Form XObjects on a page")) + <> command "diff" (info diffCommand (progDesc "Compare two PDFs (paragraph-level diff)")) + <> command "info" (info infoCommand (progDesc "Show PDF metadata")) + <> command "title" (info titleCommand (progDesc "Show document title")) + <> command "toc" (info tocCommand (progDesc "Show table of contents")) + <> command "trailer" (info trailerCommand (progDesc "Show PDF trailer")) + <> command "object" (info objectCommand (progDesc "Show object by reference")) + <> command "refs" (info refsCommand (progDesc "Show page object references")) + <> command "grep" (info grepCommand (progDesc "Search text in PDF")) + ) -walkdown :: PSR -> Int -> [PDFObj] -> PDFStream -walkdown st parent objs = - case findObjsByRef parent objs of - Just os -> case findDictOfType "/Catalog" os of - Just dict -> case findPages dict of - Just pr -> walkdown st pr objs - Nothing -> "" - Nothing -> case findDictOfType "/Pages" os of - Just dict -> case findKids dict of - Just kidsrefs -> BSL.concat $ map ((\f -> f objs) . (walkdown st)) kidsrefs - Nothing -> "" - Nothing -> case findDictOfType "/Page" os of - Just dict -> contentsStream dict st objs - Nothing -> "" - Nothing -> "" +imagesOpts :: Parser ImagesOpt +imagesOpts = ImagesOpt + <$> option auto + ( long "page" + <> short 'p' + <> metavar "PAGE" + <> help "Page number (1-based, required)" ) + <*> strOption + ( long "output" + <> short 'o' + <> value "." + <> metavar "DIR" + <> help "Output directory (default: current directory)" ) + <*> strOption + ( long "password" + <> short 'P' + <> value "" + <> metavar "PASSWORD" + <> help "Password for encrypted PDF" ) + <*> strArgument + ( help "input pdf file" + <> metavar "FILE" + <> action "file" ) +formOpts :: Parser FormOpt +formOpts = FormOpt + <$> option auto + ( long "page" + <> short 'p' + <> metavar "PAGE" + <> help "Page number (1-based, required)" ) + <*> optional + ( strOption + ( long "name" + <> short 'n' + <> metavar "NAME" + <> help "Top-level Form XObject name (e.g. Fm42); omit to list extractable names on stdout" ) ) + <*> strOption + ( long "output" + <> short 'o' + <> value "." + <> metavar "DIR" + <> help "Output directory (default: current directory)" ) + <*> strOption + ( long "password" + <> short 'P' + <> value "" + <> metavar "PASSWORD" + <> help "Password for encrypted PDF" ) + <*> strArgument + ( help "input pdf file" + <> metavar "FILE" + <> action "file" ) +extractOpts :: Parser ExtractOpt +extractOpts = ExtractOpt + <$> option auto + ( long "page" + <> short 'p' + <> value 0 + <> metavar "PAGE" + <> help "Page number (1-based; 0 = all pages)" ) + <*> switch + ( long "geom" + <> help "Extract text using geometry-based layout" ) + <*> switch + ( long "tagged" + <> help "Extract text using tagged PDF structure" ) + <*> switch + ( long "legacy" + <> help "Extract text using the pre-0.3 stream-order extractor" ) + <*> switch + ( long "quiet" + <> help "Suppress page progress on stderr during --legacy streaming" ) + <*> switch + ( long "footnotes" + <> help "Inline footnote bodies at their anchors as tags (geometry pipeline)" ) + <*> switch + ( long "ruby" + <> help "Embed ruby in Aozora bunko notation (geometry/tagged pipeline)" ) + <*> strOption + ( long "password" + <> short 'P' + <> value "" + <> metavar "PASSWORD" + <> help "Password for encrypted PDF" ) + <*> strArgument + ( help "input pdf file" + <> metavar "FILE" + <> action "file" ) -data PageTree = Nop | Page Int | Pages [PageTree] - deriving Show +diffCommand :: Parser Cmd +diffCommand = CmdDiff <$> diffOpts --- | Sort object references in page order. +diffOpts :: Parser DiffOpt +diffOpts = DiffOpt + <$> switch + ( long "geom" + <> help "Use geometry-based layout (default for diff)" ) + <*> switch + ( long "legacy" + <> help "Ignored for diff (geometry pipeline always used)" ) + <*> switch + ( long "ruby" + <> help "Embed ruby in Aozora bunko notation during layout" ) + <*> switch + ( long "json" + <> help "Emit JSON instead of human-readable diff" ) + <*> strOption + ( long "password" + <> short 'P' + <> value "" + <> metavar "PASSWORD" + <> help "Password for encrypted PDF (applied to both files)" ) + <*> strArgument + ( help "first PDF file" + <> metavar "FILE_A" + <> action "file" ) + <*> strArgument + ( help "second PDF file" + <> metavar "FILE_B" + <> action "file" ) -refByPage filename = do - root <- getRootRef filename - objs <- getPDFObjFromFile filename - return $ pageTreeToList $ pageorder root objs +passwordOpt :: Parser String +passwordOpt = strOption + ( long "password" + <> short 'P' + <> value "" + <> metavar "PASSWORD" + <> help "Password for encrypted PDF" ) -pageorder :: Int -> [PDFObj] -> PageTree -pageorder parent objs = +fileArg :: Parser FilePath +fileArg = strArgument + ( help "input pdf file" + <> metavar "FILE" + <> action "file" ) + +maybePassword :: String -> Maybe String +maybePassword pw = if null pw then Nothing else Just pw + +infoCommand :: Parser Cmd +infoCommand = CmdInfo <$> fileArg <*> (maybePassword <$> passwordOpt) + +titleCommand :: Parser Cmd +titleCommand = CmdTitle <$> fileArg <*> (maybePassword <$> passwordOpt) + +tocCommand :: Parser Cmd +tocCommand = CmdToc <$> fileArg <*> (maybePassword <$> passwordOpt) + +trailerCommand :: Parser Cmd +trailerCommand = CmdTrailer <$> fileArg + +objectCommand :: Parser Cmd +objectCommand = CmdObject + <$> option auto + ( long "ref" + <> short 'r' + <> metavar "REF" + <> help "Object reference number" ) + <*> fileArg + <*> (maybePassword <$> passwordOpt) + +refsCommand :: Parser Cmd +refsCommand = CmdRefs <$> fileArg <*> (maybePassword <$> passwordOpt) + +grepCommand :: Parser Cmd +grepCommand = CmdGrep + <$> strOption + ( long "grep" + <> short 'g' + <> metavar "REGEXP" + <> help "Regular expression to search for" ) + <*> fileArg + <*> (maybePassword <$> passwordOpt) + +-- Legacy flat-flag parser (deprecated). +legacyCmd :: Parser Cmd +legacyCmd = legacyToCmd <$> legacyOptions + +legacyOptions :: Parser LegacyOpt +legacyOptions = LegacyOpt + <$> option auto + ( long "page" + <> short 'p' + <> value 0 + <> metavar "PAGE" + <> help "Page number (nomble)" ) + <*> option auto + ( long "ref" + <> short 'r' + <> value 0 + <> metavar "REF" + <> help "Object reference" ) + <*> strOption + ( long "grep" + <> short 'g' + <> value "" + <> metavar "RegExp" + <> help "grep PDF" ) + <*> switch + ( long "refs" + <> short 'R' + <> help "Show object references in page order" ) + <*> switch + ( long "geom" + <> help "Extract text using geometry-based layout" ) + <*> switch + ( long "tagged" + <> help "Extract text using tagged PDF structure" ) + <*> switch + ( long "legacy" + <> help "Extract text using the pre-0.3 stream-order extractor" ) + <*> switch + ( long "footnotes" + <> help "Inline footnote bodies at their anchors as tags (geometry pipeline)" ) + <*> switch + ( long "ruby" + <> help "Embed ruby in Aozora bunko notation (geometry/tagged pipeline)" ) + <*> switch + ( long "title" + <> short 'T' + <> help "Show title (from metadata)" ) + <*> switch + ( long "info" + <> short 'I' + <> help "Show PDF metainfo" ) + <*> switch + ( long "toc" + <> short 'O' + <> help "Show table of contents (from metadata) " ) + <*> switch + ( long "trailer" + <> help "Show the trailer of PDF" ) + <*> strOption + ( long "password" + <> short 'P' + <> value "" + <> metavar "PASSWORD" + <> help "Password for encrypted PDF" ) + <*> strArgument + ( help "input pdf file" + <> metavar "FILE" + <> action "file" ) + +data LegacyOpt = LegacyOpt + { loPage :: Int + , loRef :: Int + , loGrep :: String + , loRefs :: Bool + , loGeom :: Bool + , loTagged :: Bool + , loLegacy :: Bool + , loFootnotes :: Bool + , loRuby :: Bool + , loTitle :: Bool + , loInfo :: Bool + , loToc :: Bool + , loTrailer :: Bool + , loPassword :: String + , loFile :: FilePath + } + +legacyToCmd :: LegacyOpt -> Cmd +legacyToCmd LegacyOpt{loPage=pg, loRef=rf, loGrep=gr, loRefs=rs, loGeom=gm, + loTagged=tg, loLegacy=lg, loFootnotes=fnn, loRuby=rb, + loTitle=tt, loInfo=ii, loToc=oo, loTrailer=tr, + loPassword=pw, loFile=fn} = + let mpw = maybePassword pw + noMode = not gm && not tg && not lg + plainView = noMode && not fnn && not rb + textCmd = CmdText (ExtractOpt pg gm tg lg False fnn rb pw fn) + in case () of + _ | pg==0 && rf==0 && null gr && not rs && lg && not gm && not tg && not tt && not ii && not oo && not tr -> + textCmd + | pg==0 && rf==0 && null gr && not rs && gm && not tg && not lg && not tt && not ii && not oo && not tr -> + textCmd + | pg==0 && rf==0 && null gr && not rs && plainView && not tt && not ii && not oo && not tr -> + CmdView fn mpw + | pg==0 && rf==0 && null gr && not rs && (tg || noMode) && not gm && not lg && not tt && not ii && not oo && not tr -> + textCmd + | pg==0 && rf==0 && null gr && not rs && noMode && tt -> + CmdTitle fn mpw + | pg==0 && rf==0 && null gr && not rs && noMode && ii -> + CmdInfo fn mpw + | pg==0 && rf==0 && null gr && not rs && noMode && oo -> + CmdToc fn mpw + | pg==0 && rf==0 && null gr && not rs && noMode && tr -> + CmdTrailer fn + | pg==0 && rf==0 && null gr && rs && noMode -> + CmdRefs fn mpw + | rf==0 && null gr && pg/=0 -> + textCmd + | pg==0 && null gr && rf/=0 -> + CmdObject rf fn mpw + | pg==0 && rf==0 && not (null gr) -> + CmdGrep gr fn mpw + | otherwise -> + textCmd + +legacyNeedsDeprecation :: [String] -> Bool +legacyNeedsDeprecation args = + any (`elem` args) + [ "-I","--info","-T","--title","-O","--toc","--trailer","-R","--refs","-g","--grep" ] + || containsFlag args "-r" + +containsFlag :: [String] -> String -> Bool +containsFlag [] _ = False +containsFlag (a:as) f = a == f || containsFlag as f + +runCmd :: Cmd -> IO () +runCmd cmd = case cmd of + CmdText opt -> runExtractText opt + CmdView fn mpw -> withFile fn $ runViewer fn mpw + CmdImage opt -> runExtractImages opt + CmdForm opt -> runExtractForm opt + CmdDiff opt -> runDiff opt + CmdInfo fn mpw -> withFile fn $ showInfo fn mpw + CmdTitle fn mpw -> withFile fn $ showTitle fn mpw + CmdToc fn mpw -> withFile fn $ showOutlines fn mpw + CmdTrailer fn -> withFile fn $ showTrailer fn + CmdObject rf fn mpw -> withFile fn $ showContent fn mpw rf + CmdRefs fn mpw -> withFile fn $ showRefs fn mpw + CmdGrep re fn mpw -> withFile fn $ grepPDF defaultLayoutOptions fn mpw re + +runExtractText :: ExtractOpt -> IO () +runExtractText ExtractOpt{eoPage=pg, eoGeom=gm, eoTagged=tg, eoLegacy=lg, + eoQuiet=quiet, eoFootnotes=fnn, eoRuby=rb, + eoPassword=pw, eoFile=fn} = + withFile fn $ + let mpw = maybePassword pw + lopts = defaultLayoutOptions {optFootnotes = fnn, optRuby = rb} + in if pg /= 0 + then showPage lopts fn mpw pg + else case () of + _ | lg && not gm && not tg -> do + doc <- runOrDie (openDocument fn mpw) + streamLegacyToStdout doc quiet + | gm && not tg && not lg -> pdfToTextGeom lopts fn mpw + | otherwise -> pdfToTextTagged lopts fn mpw + +runExtractImages :: ImagesOpt -> IO () +runExtractImages ImagesOpt{ioPage=pg, ioOut=out, ioPassword=pw, ioFile=fn} = + withFile fn $ + if pg < 1 + then do + hPutStrLn stderr "hpdft: image requires -p PAGE (1-based)" + exitWith (ExitFailure 1) + else do + doc <- runOrDie (openDocument fn (maybePassword pw)) + paths <- runOrDie (extractPageImagesToDir doc pg out) + if null paths + then hPutStrLn stderr ("hpdft: no image XObjects on page " ++ show pg) + else mapM_ putStrLn paths + +runExtractForm :: FormOpt -> IO () +runExtractForm FormOpt{foPage=pg, foName=mn, foOut=out, foPassword=pw, foFile=fn} = + withFile fn $ + if pg < 1 + then do + hPutStrLn stderr "hpdft: form requires -p PAGE (1-based)" + exitWith (ExitFailure 1) + else do + doc <- runOrDie (openDocument fn (maybePassword pw)) + case mn of + Nothing -> do + names <- runOrDie (return (pageFormNames doc pg)) + if null names + then hPutStrLn stderr ("hpdft: no Form XObjects on page " ++ show pg) + else mapM_ (putStrLn . T.unpack) names + Just nm -> do + path <- runOrDie (extractFormToFile doc pg (T.pack nm) out) + putStrLn path + +runDiff :: DiffOpt -> IO () +runDiff DiffOpt{doRuby=rb, doJson=json, doPassword=pw, doFileA=fa, doFileB=fb} = + withFile fa $ + withFile fb $ + let mpw = maybePassword pw + lopts = defaultLayoutOptions {optRuby = rb} + in do + docA <- runOrDie (openDocument fa mpw) + docB <- runOrDie (openDocument fb mpw) + changes <- runOrDie (return (compareDocuments lopts docA docB)) + if json + then putStrLn (renderDiffJson changes) + else mapM_ putStrLn (renderDiffHuman changes) + +renderDiffHuman :: [TextChange] -> [String] +renderDiffHuman = map renderOne + where + renderOne (PageCountMismatch pa pb) = + "page count mismatch: " ++ show pa ++ " vs " ++ show pb + renderOne TextChange{changePageA = pa, changePageB = pb, + changeParaA = pxa, changeParaB = pxb, + changeOld = old, changeNew = new} = + unlines + ( pageLine + : paraLine + : ("- old: " ++ T.unpack old) : ("+ new: " ++ T.unpack new) : [] + ) + where + pageLine = + case (pa, pb) of + (Just a, Just b) | a == b -> "page " ++ show a ++ ":" + (Just a, Just b) -> "page " ++ show a ++ " vs " ++ show b ++ ":" + (Just a, Nothing) -> "page " ++ show a ++ " (only in first file):" + (Nothing, Just b) -> "page " ++ show b ++ " (only in second file):" + _ -> "page ?:" + paraLine = + case (pxa, pxb) of + (Just a, Just b) | a == b -> "para " ++ show (a + 1) ++ ":" + (Just a, Just b) -> "para " ++ show (a + 1) ++ " vs " ++ show (b + 1) ++ ":" + (Just a, Nothing) -> "para " ++ show (a + 1) ++ ":" + (Nothing, Just b) -> "para " ++ show (b + 1) ++ ":" + _ -> "para ?:" + +renderDiffJson :: [TextChange] -> String +renderDiffJson changes = "[" ++ intercalate "," (map encodeChange changes) ++ "]" + where + encodeChange (PageCountMismatch pa pb) = + "{\"type\":\"pageCountMismatch\",\"pagesA\":" ++ show pa + ++ ",\"pagesB\":" ++ show pb ++ "}" + encodeChange TextChange{changePageA = pa, changePageB = pb, + changeParaA = pxa, changeParaB = pxb, + changeOld = old, changeNew = new} = + "{\"type\":\"textChange\"" + ++ maybeField "pageA" pa + ++ maybeField "pageB" pb + ++ maybeField "paraA" pxa + ++ maybeField "paraB" pxb + ++ ",\"old\":" ++ jsonString old + ++ ",\"new\":" ++ jsonString new + ++ "}" + maybeField _ Nothing = "" + maybeField k (Just v) = ",\"" ++ k ++ "\":" ++ show v + jsonString t = + "\"" ++ concatMap esc (T.unpack t) ++ "\"" + esc '\\' = "\\\\" + esc '"' = "\\\"" + esc '\n' = "\\n" + esc '\r' = "\\r" + esc '\t' = "\\t" + esc c = [c] + +describeError :: PdfError -> String +describeError (ParseError msg _) = "parse error: " ++ msg +describeError (BrokenXref msg) = "broken cross-reference: " ++ msg +describeError (MissingObject n) = "missing object: " ++ show n ++ " 0 R" +describeError (MissingKey key ctx) = "missing key " ++ key ++ " in " ++ ctx +describeError (UnsupportedFeature msg) = "unsupported feature: " ++ msg +describeError (DecryptionError msg) = + "cannot decrypt: " ++ msg ++ ". Use -P to supply a password." +describeError (FontError n msg) = "font error in object " ++ show n ++ ": " ++ msg + +printWarnings :: [PdfWarning] -> IO () +printWarnings = mapM_ (hPutStrLn stderr . ("hpdft: warning: " ++) . renderPdfWarning) + +runOrDie :: IO (PdfResult a) -> IO a +runOrDie action = do + result <- action + case result of + Right a -> return a + Left err -> do + hPutStrLn stderr ("hpdft: " ++ describeError err) + exitWith (ExitFailure 1) + +withFile :: FilePath -> IO () -> IO () +withFile fp action = + action `catch` \e -> do + if isDoesNotExistError (e :: IOException) + then do + hPutStrLn stderr ("hpdft: " ++ fp ++ ": does not exist") + exitWith (ExitFailure 1) + else ioError e + +-- | Bare @hpdft FILE@: TUI preview on a TTY, legacy streaming on a pipe. +runViewer :: FilePath -> Maybe String -> IO () +runViewer filename mpw = do + doc <- runOrDie (openDocument filename mpw) + stdoutTTY <- hIsTerminalDevice stdout + if stdoutTTY + then runTuiPreview filename doc + else streamLegacyToStdout doc False + +streamLegacyToStdout :: Document -> Bool -> IO () +streamLegacyToStdout doc quiet = do + stderrTTY <- hIsTerminalDevice stderr + let showProgress pg total = + when (not quiet && stderrTTY && total > 0) $ + hPutStr stderr ("\rhpdft: page " ++ show pg ++ "/" ++ show total ++ "...") + clearProgress total = + when (not quiet && stderrTTY && total > 0) $ + hPutStr stderr ("\r\ESC[K") + totalRef <- newIORef (0 :: Int) + ws <- pdfToTextStreamDoc doc $ \pg total txt -> do + writeIORef totalRef total + showProgress pg total + BSL.putStr txt + hFlush stdout + total <- readIORef totalRef + clearProgress total + -- Trailing newline for parity with the pre-0.4.6 batch output (putStrLn). + putStrLn "" + printWarnings ws + +pdfToTextGeom :: LayoutOptions -> FilePath -> Maybe String -> IO () +pdfToTextGeom lopts filename mpw = do + txt <- runOrDie (pdfToTextGeomBSWith lopts filename mpw) + BSL.putStrLn txt + +pdfToTextTagged :: LayoutOptions -> FilePath -> Maybe String -> IO () +pdfToTextTagged lopts filename mpw = do + txt <- runOrDie (pdfToTextTaggedBSWith lopts filename mpw) + BSL.putStrLn txt + +data PageTree = Nop | Page Int | Pages [PageTree] + deriving Show + +showRefs :: FilePath -> Maybe String -> IO () +showRefs filename mpw = do + doc <- runOrDie (openDocument filename mpw) + root <- runOrDie (return (docRootRef doc)) + print $ pageTreeToList $ pageorder root (docObjs doc) + +refByPage :: FilePath -> Maybe String -> IO [Int] +refByPage filename mpw = do + doc <- runOrDie (openDocument filename mpw) + root <- runOrDie (return (docRootRef doc)) + return $ pageTreeToList $ pageorder root (docObjs doc) + +pageorder :: Int -> PDFObjIndex -> PageTree +pageorder parent objs = case findObjsByRef parent objs of Just os -> case findDictOfType "/Catalog" os of - Just dict -> case findPages dict of + Just dict -> case findPages dict of Just pr -> pageorder pr objs Nothing -> Nop Nothing -> case findDictOfType "/Pages" os of @@ -187,35 +698,32 @@ pageTreeToList (Page n) = [n] pageTreeToList Nop = [] --- | Show contents of page 'page' in 'filename'. - -showPage filename page = do - pagetree <- refByPage filename - case length pagetree >= page of - True -> contentByRef filename $ pagetree !! (page - 1) - False -> putStrLn $ "hpdft: No Page "++(show page) - --- | Show /Content referenced from the 'ref'ed-object in 'filename'. - -contentByRef filename ref = do - objs <- getPDFObjFromFile filename - obj <- getObjectByRef ref objs - BSL.putStrLn $ contentInObject obj objs - where contentInObject obj objs = - case findDictOfType "/Page" obj of - Just dict -> contentsStream dict initstate objs - Nothing -> "" +showPage :: LayoutOptions -> FilePath -> Maybe String -> Int -> IO () +showPage lopts filename mpw page = do + doc <- runOrDie (openDocument filename mpw) + root <- runOrDie (return (docRootRef doc)) + let pagetree = pageTreeToList $ pageorder root (docObjs doc) + if page >= 1 && length pagetree >= page + then do + txt <- runOrDie (return (pageTextGeomWith lopts doc (pagetree !! (page - 1)))) + BSL.putStr txt + else putStrLn $ "hpdft: No Page "++(show page) -showContent filename ref = do - objs <- getPDFObjFromFile filename - obj <- getObjectByRef ref objs - let d = fromMaybe [] $ findDict obj +showContent :: FilePath -> Maybe String -> Int -> IO () +showContent filename mpw ref = do + doc <- runOrDie (openDocument filename mpw) + let objs = docObjs doc + sec = docSecurity doc + obj <- runOrDie (getObjectByRef ref objs) if hasStream obj - then - if hasSubtype d -- then it's not content stream - then printStreamWithDict d obj - else BSL.putStrLn =<< getStream False obj - else print =<< getObjectByRef ref objs + then case findDict obj of + Just d | hasSubtype d -> printStreamWithDict sec ref d obj + _ -> do + strm <- runOrDie (getStream sec ref False obj) + BSL.putStrLn strm + else do + objs' <- runOrDie (getObjectByRef ref objs) + putStrLn $ "[" ++ intercalate ", " (map ppObj objs') ++ "]" where hasStream obj = case find isStream obj of @@ -224,60 +732,59 @@ isStream (PdfStream _) = True isStream _ = False - hasSubtype d = case find isSubtype d of - Just _ -> True - Nothing -> False - isSubtype (PdfName "/Subtype", _) = True - isSubtype x = False - - printStreamWithDict :: Dict -> [Obj] -> IO () - printStreamWithDict d obj = print (PdfDict d) >> (BSL.putStrLn =<< getStream True obj) + hasSubtype d = case findObjFromDict d "/Subtype" of + Just _ -> True + Nothing -> False --- | Show /Title from meta information in 'filename' + printStreamWithDict :: Maybe Security -> Int -> Dict -> [Obj] -> IO () + printStreamWithDict sec' ref' d obj = do + putStrLn $ ppObj (PdfDict d) + strm <- runOrDie (getStream sec' ref' True obj) + BSL.putStrLn strm -showTitle filename = do - d <- getInfo filename - let title = +showTitle :: FilePath -> Maybe String -> IO () +showTitle filename mpw = do + doc <- runOrDie (openDocument filename mpw) + d <- runOrDie (return (docInfoDict doc)) + let title = case findObjFromDict d "/Title" of - Just (PdfText s) -> s - Just x -> show x + Just (PdfText s) -> T.unpack s + Just x -> ppObj x Nothing -> "No title anyway" putStrLn title - return () --- | Show /Info from meta information in 'filename' - -showInfo filename = do - d <- getInfo filename - putStrLn $ toString 0 (PdfDict d) - return () - --- | Show /Outlines from meta information in 'filename' +showInfo :: FilePath -> Maybe String -> IO () +showInfo filename mpw = do + doc <- runOrDie (openDocument filename mpw) + d <- runOrDie (return (docInfoDict doc)) + putStrLn $ ppObj (PdfDict d) -showOutlines filename = do - d <- getOutlines filename +showOutlines :: FilePath -> Maybe String -> IO () +showOutlines filename mpw = do + d <- runOrDie (getOutlines filename mpw) putStrLn $ show d - return () --- | Find string in each page. +showTrailer :: FilePath -> IO () +showTrailer filename = do + doc <- runOrDie (openDocument filename Nothing) + putStrLn $ ppDictEntries (docTrailer doc) -grepPDF filename re = do - root <- getRootRef filename - objs <- getPDFObjFromFile filename - mapM - (\(strm, pagenm) -> (grepByPage pagenm re . contentInObjs objs) strm) +grepPDF :: LayoutOptions -> FilePath -> Maybe String -> String -> IO () +grepPDF lopts filename mpw re = do + doc <- runOrDie (openDocument filename mpw) + root <- runOrDie (return (docRootRef doc)) + let objs = docObjs doc + mapM_ + (\(ref, pagenm) -> grepByPage pagenm re (pageText doc ref)) $ zip (pageTreeToList $ pageorder root objs) [1..] - return () - + where - contentInObjs objs ref = - case findObjsByRef ref objs of - Just obj -> case findDictOfType "/Page" obj of - Just dict -> contentsStream dict initstate objs - Nothing -> "" - Nothing -> error $ "No Object with Ref " ++ show ref + pageText doc ref = + case pageTextGeomWith lopts doc ref of + Right txt -> txt + Left _ -> "" - grepByPage :: Int -> String -> PDFStream -> IO () + grepByPage :: Int -> String -> BSL.ByteString -> IO () grepByPage pagenm re txt = do let matched = filter (not . null) $ map (grepByLine re) $ BSL.lines txt when (not $ null matched) (showResult pagenm matched) diff --git a/scripts/bench_book.sh b/scripts/bench_book.sh new file mode 100644 --- /dev/null +++ b/scripts/bench_book.sh @@ -0,0 +1,7 @@ +#!/bin/bash +set -euo pipefail +HPDFT=$(cabal list-bin exe:hpdft) +PDF=data/sample/book.pdf +echo "legacy:" && time "$HPDFT" --legacy "$PDF" > /dev/null +echo "geom:" && time "$HPDFT" --geom "$PDF" > /dev/null +echo "-p1:" && time "$HPDFT" -p 1 "$PDF" > /dev/null diff --git a/scripts/bench_pages.hs b/scripts/bench_pages.hs new file mode 100644 --- /dev/null +++ b/scripts/bench_pages.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +-- In-process benchmark: per-page interpret+layout cost on a PDF. +-- Usage: cabal exec -- ghc -O2 -package hpdft scripts/bench_pages.hs -o /tmp/bench_pages +-- /tmp/bench_pages data/sample/book.pdf +import PDF.Document (openDocument) +import PDF.Page (pageRefs) +import PDF.Interpret (interpretPageItems) +import PDF.Layout (defaultLayoutOptions, layoutPageTextWith) + +import qualified Data.Text as T +import Control.Monad (forM_) +import System.Environment (getArgs) +import Data.Time.Clock (getCurrentTime, diffUTCTime) +import Text.Printf (printf) + +timeIt :: IO a -> IO (Double, a) +timeIt io = do + t0 <- getCurrentTime + x <- io + t1 <- getCurrentTime + return (realToFrac (diffUTCTime t1 t0), x) + +forcePage :: (Int -> Either e [item]) -> ([item] -> T.Text) -> Int -> IO Int +forcePage interp layout ref = + case interp ref of + Right items -> let n = T.length (layout items) in n `seq` return n + Left _ -> return 0 + +main :: IO () +main = do + [path] <- getArgs + doc <- openDocument path Nothing >>= either (error . show) return + refs <- either (error . show) return (pageRefs doc) + printf "pages: %d\n" (length refs) + let interp = interpretPageItems doc + layout = layoutPageTextWith defaultLayoutOptions + -- Same heavy page repeatedly: if iterations 2+ stay slow, per-page cost + -- is recomputed every call (no font/CMap caching across calls). + let heavy = refs !! min 49 (length refs - 1) + forM_ [1 .. 5 :: Int] $ \i -> do + (t, n) <- timeIt (forcePage interp layout heavy) + printf "page50 iter %d: %.3fs (%d chars)\n" i t n + (ttot, _) <- timeIt $ + forM_ (zip [1 :: Int ..] refs) $ \(i, r) -> do + (t, _) <- timeIt (forcePage interp layout r) + if i `mod` 25 == 0 then printf " page %3d: %.3fs\n" i t else return () + printf "sum of all pages (interpret+layout, per page): %.3fs\n" ttot diff --git a/scripts/interpret_page.hs b/scripts/interpret_page.hs new file mode 100644 --- /dev/null +++ b/scripts/interpret_page.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import PDF.Document (Document, openDocument) +import PDF.Error (PdfResult) +import PDF.Interpret (Glyph(..), PageItem(..), Rect(..)) +import PDF.Page (pageCount, pageRefAt, pageItems) + +import qualified Data.Text as T +import Control.Monad (forM_) +import System.Environment (getArgs) +import System.Exit (exitFailure) + +main :: IO () +main = do + args <- getArgs + let (pdf, pageNo, full) = case args of + (f:n:m:_) -> (f, read n :: Int, m == "--full") + (f:n:_) -> (f, read n :: Int, False) + (f:_) -> (f, 1, False) + _ -> ("data/sample/test.pdf", 1, False) + result <- openDocument pdf Nothing + case result of + Left err -> print err >> exitFailure + Right doc -> inspect doc pageNo full + +inspect :: Document -> Int -> Bool -> IO () +inspect doc pageNo full = do + n <- runOrDie (pageCount doc) + if pageNo < 1 || pageNo > n + then putStrLn "page out of range" >> exitFailure + else do + pageRef <- runOrDie (pageRefAt doc pageNo) + items <- runOrDie (pageItems doc pageRef) + let glyphs = [g | ItemGlyph g <- items] + graphics = length [() | ItemGraphic _ <- items] + putStrLn $ "page ref " ++ show pageRef ++ ": " + ++ show (length glyphs) ++ " glyph segments, " + ++ show graphics ++ " graphics" + let shown = if full then items else take 10 [i | i@(ItemGlyph _) <- items] + forM_ shown $ \item -> case item of + ItemGlyph g -> putStrLn $ + "G " ++ show (glyphText g) + ++ " x=" ++ show (glyphX g) ++ " y=" ++ show (glyphY g) + ++ " w=" ++ show (glyphWidth g) ++ " size=" ++ show (glyphSize g) + ++ " wm=" ++ show (glyphWMode g) ++ " font=" ++ T.unpack (glyphFont g) + ItemGraphic r -> putStrLn $ + "R x0=" ++ show (rectX0 r) ++ " y0=" ++ show (rectY0 r) + ++ " x1=" ++ show (rectX1 r) ++ " y1=" ++ show (rectY1 r) + +runOrDie :: PdfResult a -> IO a +runOrDie (Right x) = return x +runOrDie (Left err) = print err >> exitFailure diff --git a/src/PDF/CFF.hs b/src/PDF/CFF.hs --- a/src/PDF/CFF.hs +++ b/src/PDF/CFF.hs @@ -20,7 +20,8 @@ import Control.Applicative -import Debug.Trace +import qualified Data.Map as Map +import qualified Data.Text as T import PDF.Definition @@ -32,81 +33,89 @@ encoding :: ByteString -> Encoding encoding c = - Encoding $ map findEncodings $ zip charset encodings + case parseOnly (header >> index *> index) c of + Left _ -> NullMap + Right ds | null ds -> NullMap + Right ds -> + let encodings = concatMap (parseEncoding c) ds + charset = concatMap (parseCharset c) ds + strings = case parseOnly stringInd c of + Right arr -> arr + Left _ -> [] + in Encoding $ Map.fromListWith (flip const) $ + map (findEncodings strings) $ zip charset encodings where - ds = parseTopDictInd c - encodings = concatMap (parseEncoding c) ds - charset = concatMap (parseCharset c) ds - fontname = concat $ map (parseFontname c) ds - strings = case parseOnly stringInd c of - Right arr -> arr - Left e -> error "Failed to parse STRING Index" - - findEncodings :: (SID, Char) -> (Char, String) - findEncodings (char,enc) = + findEncodings strings (char,enc) = case char of - s | s > 390 -> (enc, stringToText $ strings !! fromInteger (char - 390 - 1)) + s | s > 390 -> + let idx = fromInteger (char - 390 - 1) + in (enc, stringToText $ safeAt strings idx) | s > 95 -> (enc, sidToText s) - | otherwise -> (enc, [enc]) + | otherwise -> (enc, T.singleton enc) + safeAt xs i = if i >= 0 && i < length xs then xs !! i else "" + -- defined in String INDEX of each font stringToText "a113" = "‡" stringToText "a114" = "・" stringToText "trianglesolid" = "▲" - stringToText x = "[CFF:String " <> x <> "]" + stringToText x = "[CFF:String " <> T.pack x <> "]" -- pre-defined in Appendix C of CFF specs - sidToText n = [complementSID 0 predefinedChars !! fromInteger n] + sidToText n = + let i = fromInteger n + chars = complementSID 0 predefinedChars + in if i >= 0 && i < length chars then T.singleton (chars !! i) else "?" parseTopDictInd :: ByteString -> [ByteString] parseTopDictInd c = case parseOnly (header >> index *> index) c of Right ds -> ds - Left e -> error "Can not find Top DICT INDEX" + Left _ -> [] parseEncoding :: ByteString -> ByteString -> [Char] parseEncoding c d = case parseOnly (many1 dict) d of - -- '16' is key for 'Encoding' in Top DICT Right dictData -> case lookup [16] dictData of - Just (DictInt 0:[]) -> [] -- Standard Encoding (not supported) - Just (DictInt 1:[]) -> [] -- Expert Encoding (not supported) - Just (DictInt n:[]) -> -- n is offset - case parseOnly encodingArray $ BS.drop n c of + Just (DictInt 0:[]) -> [] + Just (DictInt 1:[]) -> [] + Just (DictInt n:[]) -> + case parseOnly encodingArray $ BS.drop (fromIntegral n) c of Right arr -> map (chr . fromInteger) arr - Left e -> error "Failed to parse Encoding Array" - Just a -> error (show a) - Nothing -> error $ "No Encodind Array in " ++ show dictData - Left _ -> error "Failed to parse Top DICT in CFF" + Left _ -> [] + Just _ -> [] + Nothing -> [] + Left _ -> [] parseFontname c d = case parseOnly (many1 dict) d of Right dictData -> case lookup [2] dictData of Just (DictInt n:[]) -> case parseOnly stringInd c of - Right arr -> arr !! (n - 390 - 1) -- 390 seems to be a magic number - Left e -> error "Failed to parse Fontname" - Just a -> error (show a) - Nothing -> error $ "No Fontname in " <> show dictData - Left _ -> error "Failed to parse Top DICT in CFF" + Right arr -> + let idx = fromIntegral n - 390 - 1 + in if idx >= 0 && idx < length arr then [arr !! idx] else [] + Left _ -> [] + Just _ -> [] + Nothing -> [] + Left _ -> [] parseCharset c d = case parseOnly (many1 dict) d of Right dictData -> case lookup [15] dictData of Just (DictInt offset:[]) -> case parseOnly (charsetData $ charStringsInd c dictData) $ - BS.drop offset c of + BS.drop (fromIntegral offset) c of Right arr -> arr - Left _ -> error "" - Just a -> error (show a) - Nothing -> error $ "No Charset in " <> show dictData - Left _ -> error "Failed to parse Top DICT in CFF" + Left _ -> [] + Just _ -> [] + Nothing -> [] + Left _ -> [] charStringsInd c dictData = case lookup [17] dictData of Just (DictInt offset:[]) -> - case parseOnly index (BS.drop offset c) of - Right [] -> error "failed to get CharStrings" + case parseOnly index (BS.drop (fromIntegral offset) c) of Right ind -> ind - Left "" -> error "failed to get CharStrings" - Nothing -> error $ "No CharStrings in " <> show dictData + Left _ -> [] + Nothing -> [] nameInd = map BSC.unpack <$> (header *> index) @@ -134,7 +143,7 @@ encodeObj :: Integer -> Int -> Parser [Integer] encodeObj 0 p = count (p - 1) (getCard 1) encodeObj 1 p = concat <$> count p getRange1 - encodeObj _ p = error "CFF Supplement Format is not supported." + encodeObj _ _ = return [] getRange1 :: Parser [Integer] getRange1 = do @@ -175,7 +184,7 @@ r <- many1 $ AP.satisfy (\w -> (240 .|. w) `xor` 255 /= 0) f <- getCard 1 return $ DictReal $ readNibble r f - | otherwise = error (show b0) + | otherwise = fail (show b0) readNibble s1 s2 = 0 dictKey :: Parser [Word8] diff --git a/src/PDF/Cmap.hs b/src/PDF/Cmap.hs --- a/src/PDF/Cmap.hs +++ b/src/PDF/Cmap.hs @@ -6,7 +6,9 @@ import Data.Char (chr) import Data.List (intercalate) -import Numeric (readOct, readHex) +import Data.Maybe (mapMaybe) +import qualified Data.Map as Map +import Numeric (readHex) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS @@ -19,26 +21,31 @@ import Text.Parsec.ByteString.Lazy import Codec.Compression.Zlib (decompress) -import Debug.Trace - import PDF.Definition -parseCMap :: BSL.ByteString -> CMap -parseCMap str = case runParser (skipHeader >> - concat <$> - manyTill - (choice - [ try bfchar - , try $ concat <$> bfrange - ]) - (try $ string "endcmap")) - () "" str of - Left err -> error $ "Can not parse CMap " ++ (show err) - Right cmap -> mkUniq cmap +maxBfrangeSpan :: Int +maxBfrangeSpan = 65536 - where - mkUniq = reverse +parseCMap :: BSL.ByteString -> CMap +parseCMap str + | BSL.null str = Map.empty + | otherwise = + case runParser (skipHeader >> + concat <$> + manyTill + (choice + [ try bfchar + , try $ concat <$> bfrange + ]) + (try $ string "endcmap")) + () "" str of + Left _ -> Map.empty + Right cmap -> Map.fromList cmap +readHexSafe :: String -> Maybe Int +readHexSafe s = case readHex s of + [(n, "")] -> Just n + _ -> Nothing skipHeader :: Parser () skipHeader = do @@ -46,7 +53,7 @@ spaces return () -bfchar :: Parser CMap +bfchar :: Parser [(Int, T.Text)] bfchar = do many1 digit spaces @@ -56,10 +63,16 @@ spaces string "endbfchar" spaces - return ms - where toCmap cid ucs = ((fst.head.readHex) cid, ((:[]).chr.fst.head.readHex) ucs) + return $ concatMap maybeToList ms + where + maybeToList Nothing = [] + maybeToList (Just x) = [x] + toCmap cid ucs = + case (readHexSafe cid, readHexSafe (take 4 ucs)) of + (Just c, Just u) -> Just (c, T.singleton (chr u)) + _ -> Nothing -bfrange :: Parser [CMap] +bfrange :: Parser [[(Int, T.Text)]] bfrange = do d <- many1 digit spaces @@ -71,14 +84,24 @@ spaces string "endbfrange" spaces - return $ ms + return ms where - gethex = fst.head.readHex - getRange cid cid' = [gethex cid .. gethex cid'] - mkStrList d src = if (length src) == 1 - then [gethex $ head src .. ] - else map gethex src - toCmap range ucs = zip range (map ((:[]).chr) ucs) + gethex = readHexSafe + getRange cid cid' = + case (gethex cid, gethex cid') of + (Just a, Just b) | b >= a -> + let span = b - a + 1 + b' = if span > maxBfrangeSpan then a + maxBfrangeSpan - 1 else b + in [a .. b'] + _ -> [] + mkStrList d src = if length src == 1 + then case src of + (s:_) -> case gethex s of + Just n -> [n .. ] + Nothing -> [] + [] -> [] + else mapMaybe gethex src + toCmap range ucs = zip range (map (T.singleton . chr) ucs) hexletters :: Parser String @@ -100,4 +123,3 @@ lets <- manyTill hexletters (try $ spaces >> char ']') spaces return $ intercalate "\n" lets - diff --git a/src/PDF/ContentStream.hs b/src/PDF/ContentStream.hs --- a/src/PDF/ContentStream.hs +++ b/src/PDF/ContentStream.hs @@ -12,41 +12,47 @@ import Data.Maybe (fromMaybe) import qualified Data.Map as Map -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy.Char8 as BSLC (ByteString, pack) +import GHC.Word (Word8) +import qualified Data.ByteString as B (pack) +import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BSSC (unpack) +import qualified Data.ByteString.Lazy.Char8 as BSLC (ByteString, pack) import qualified Data.ByteString.Lazy.UTF8 as BSLU (toString) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (encodeUtf8, decodeUtf16BE) import Text.Parsec hiding (many, (<|>)) import Text.Parsec.ByteString.Lazy import Control.Applicative -import Debug.Trace - import PDF.Definition import PDF.Object import PDF.Character (pdfcharmap, extendedAscii, adobeJapanOneSixMap) +import PDF.Error (PdfError(..), PdfResult, PdfWarning(..)) type PSParser a = GenParser Char PSR a parseContentStream p st = runParser p st "" -parseStream :: PSR -> PDFStream -> PDFStream -parseStream psr pdfstream = - case parseContentStream (T.concat <$> (spaces >> many (try elems <|> skipOther))) psr pdfstream of - Left err -> error $ "Nothing to be parsed: " ++ (show err) - Right str -> BSLC.pack $ BSSC.unpack $ encodeUtf8 str +parseStream :: PSR -> PDFStream -> PdfResult (PDFStream, [PdfWarning]) +parseStream psr pdfstream = + case parseContentStream contentParser psr pdfstream of + Left err -> Left (ParseError ("content stream: " ++ show err) BS.empty) + Right (str, ws) -> Right (BSLC.pack $ BSSC.unpack $ encodeUtf8 str, reverse ws) + where + contentParser = do + str <- T.concat <$> (spaces >> many (try elems <|> skipOther)) + st <- getState + return (str, warnings st) -parseColorSpace :: PSR -> BSLC.ByteString -> [T.Text] +parseColorSpace :: PSR -> BSLC.ByteString -> PdfResult [T.Text] parseColorSpace psr pdfstream = case parseContentStream (many (choice [ try colorSpace , try $ T.concat <$> xObject , (T.empty <$ elems) ])) psr pdfstream of - Left err -> error "Nothing to be parsed" - Right str -> str + Left err -> Left (ParseError ("color space: " ++ show err) BS.empty) + Right str -> Right str -- | Parsers for Content Stream @@ -120,7 +126,7 @@ , try $ "DeviceGray" <$ (digitParam <* spaces) <* oneOf "gG" <* spaces , try $ "DeviceCMYK" <$ (many1 (digitParam <* spaces) <* oneOf "kK" <* spaces) ] - updateState (\s -> s {colorspace = gs}) + updateState (\s -> s {colorspace = T.pack gs}) return $ T.pack gs dashPattern :: PSParser T.Text @@ -144,7 +150,7 @@ st <- getState let xobjcs = xcolorspaces st -- updateState (\s -> s {colorspace = xobjcs}) - return $ map T.pack xobjcs + return xobjcs pdfopBT :: PSParser T.Text pdfopBT = do @@ -160,7 +166,7 @@ pdfopBMC :: PSParser T.Text pdfopBMC = do - n <- (++) <$> string "/" <*> manyTill anyChar (try space) + tag <- (++) <$> string "/" <*> manyTill anyChar (try space) spaces string "BMC" spaces @@ -170,12 +176,43 @@ pdfopBDC :: PSParser T.Text pdfopBDC = do - n1 <- name *> propertyList + tag <- name + prop <- propertyList spaces string "BDC" spaces - return T.empty + case tag of + "/Span" + | "/ActualText" == (fst prop) + -> do {spaces >> manyTill elems (try $ string "EMC") >> return (snd prop)} + | otherwise -> return $ T.empty + _ -> return $ T.empty + where + propertyList :: PSParser (T.Text, T.Text) + propertyList = spaces >> try dictionary + + dictionary :: PSParser (T.Text, T.Text) + dictionary = do + _ <- spaces >> string "<<" >> spaces + name <- name + entries <- T.concat <$> manyTill dictEntry (try (string ">>" >> (notFollowedBy $ string ">"))) + return (name, entries) + + dictEntry :: PSParser T.Text + dictEntry = choice [ try name + , try letters + , hexDecodeUTF16BE . T.pack <$> try hex + , T.pack <$> try (many1 digit) + ] <* spaces + + hex = string "<" >> (manyTill (oneOf "0123456789abcdefABCDEF") (try $ string ">")) + + name :: PSParser T.Text + name = T.pack <$> + ((++) <$> string "/" + <*> (manyTill anyChar (try $ lookAhead $ oneOf "><][)( \n\r/")) <* spaces) + pdfopEMC :: PSParser T.Text pdfopEMC = do spaces @@ -183,26 +220,9 @@ spaces return T.empty -propertyList :: PSParser T.Text -propertyList = spaces >> choice [try dictionary, try name] -dictionary :: PSParser T.Text -dictionary = T.concat <$> (spaces >> string "<<" >> spaces - *> manyTill dictEntry (try (string ">>" >> (notFollowedBy $ string ">")))) -dictEntry :: PSParser T.Text -dictEntry = choice [ try name - , try letters - , T.pack <$> try hex - , T.pack <$> try (many1 digit) - ] <* spaces - where - hex = string "<" >> (manyTill (oneOf "0123456789abcdefABCDEF") (try $ string ">")) -name :: PSParser T.Text -name = T.pack <$> ((++) <$> string "/" <*> (manyTill anyChar (try $ lookAhead $ oneOf "><][)( \n\r/")) <* spaces) - - pdfopTj :: PSParser T.Text pdfopTj = do spaces @@ -240,17 +260,18 @@ return $ T.concat t unknowns :: PSParser T.Text -unknowns = do +unknowns = do ps <- manyTill anyChar (try $ oneOf "\r\n") st <- getState - -- linebreak within (...) is parsed as Tj - return $ case runParser elems st "" $ BSLC.pack ((Data.List.dropWhileEnd (=='\\') ps)++")Tj") of - Right xs -> xs - Left e -> case runParser elems st "" $ BSLC.pack ("("++ps) of - Right xs -> xs - Left e -> case ps of - "" -> "" - otherwise -> T.pack $ "[[[UNKNOWN STREAM:" ++ take 100 (show ps) ++ "]]]" + case runParser elems st "" $ BSLC.pack ((Data.List.dropWhileEnd (=='\\') ps)++")Tj") of + Right xs -> return xs + Left _ -> case runParser elems st "" $ BSLC.pack ("("++ps) of + Right xs -> return xs + Left _ -> case ps of + "" -> return T.empty + _ -> do + updateState (\s -> s {warnings = UnknownOperator (take 100 ps) : warnings s}) + return T.empty skipOther :: PSParser T.Text skipOther = do @@ -273,12 +294,12 @@ letters = do char '(' st <- getState - let cmap = fromMaybe [] (lookup (curfont st) (cmaps st)) - letterParser = case lookup (curfont st) (fontmaps st) of + let cmap = Map.findWithDefault Map.empty (curfont st) (cmaps st) + letterParser = case Map.lookup (curfont st) (fontmaps st) of Just (Encoding m) -> psletter m Just (CIDmap s) -> cidletter s Just (WithCharSet s) -> try $ bytesletter cmap <|> cidletters - Just NullMap -> psletter [] + Just NullMap -> psletter Map.empty Nothing -> (T.pack) <$> (many1 $ choice [ try $ ')' <$ (string "\\)") , try $ '(' <$ (string "\\(") , try $ noneOf ")" @@ -302,19 +323,17 @@ , try $ chr <$> ((string "\\") *> octnum) , try $ noneOf ")" ]) - return $ byteStringToText cmap txt + byteStringToText cmap txt where - byteStringToText :: CMap -> String -> T.Text - byteStringToText cmap str = T.concat $ map (toUcs cmap) $ asInt16 $ map ord str + byteStringToText cmap' str = do + parts <- mapM (lookupUcs cmap') $ asInt16 $ map ord str + return $ T.concat parts asInt16 :: [Int] -> [Int] asInt16 [] = [] - asInt16 (a:[]) = [a] --error $ "Can not read string "++(show a) + asInt16 (a:[]) = [a] asInt16 (a:b:rest) = (a * 256 + b):(asInt16 rest) - -- for debug - -- myToUcs cmap x = if x == 636 then trace (show cmap) $ toUcs cmap x else toUcs cmap x - hexletters :: PSParser T.Text hexletters = do char '<' @@ -329,15 +348,26 @@ spaces return $ T.concat lets +hexDecodeUTF16BE :: T.Text -> T.Text +hexDecodeUTF16BE s = + let bytestring = B.pack ((map read . map ("0x"<>) . map T.unpack . T.chunksOf 2) s :: [Word8]) + in decodeUtf16BE bytestring + adobeOneSix :: Int -> T.Text adobeOneSix a = case Map.lookup a adobeJapanOneSixMap of Just cs -> T.pack $ BSLU.toString cs - Nothing -> T.pack $ "[" ++ (show a) ++ "]" + Nothing -> T.pack $ "[" ++ show a ++ "]" -toUcs :: CMap -> Int -> T.Text -toUcs m h = case lookup h m of - Just ucs -> T.pack ucs - Nothing -> if m == [] then adobeOneSix h else T.pack [chr h] +lookupUcs :: CMap -> Int -> PSParser T.Text +lookupUcs m h = case Map.lookup h m of + Just ucs -> return ucs + Nothing + | Map.null m -> case Map.lookup h adobeJapanOneSixMap of + Just cs -> return $ T.pack $ BSLU.toString cs + Nothing -> do + updateState (\s -> s {warnings = UnmappedCid h : warnings s}) + return $ adobeOneSix h + | otherwise -> return $ T.singleton (chr h) cidletters = choice [try hexletter, try octletter] @@ -345,22 +375,23 @@ hexletter = do st <- getState let font = curfont st - cmap = fromMaybe [] (lookup font (cmaps st)) - (hexToString cmap . readHex) <$> choice [ try $ count 4 $ oneOf "0123456789ABCDEFabcdef" - , try $ count 2 $ oneOf "0123456789ABCDEFabcdef" - , try $ (:"0") <$> (oneOf "0123456789ABCDEFabcdef") - ] - where hexToString m [(h,"")] = toUcs m h - hexToString _ _ = "????" + cmap = Map.findWithDefault Map.empty font (cmaps st) + hexDigits <- choice [ try $ count 4 $ oneOf "0123456789ABCDEFabcdef" + , try $ count 2 $ oneOf "0123456789ABCDEFabcdef" + , try $ (:"0") <$> (oneOf "0123456789ABCDEFabcdef") + ] + case readHex hexDigits of + [(h,"")] -> lookupUcs cmap h + _ -> return "????" octletter :: PSParser T.Text octletter = do st <- getState - let cmap = fromMaybe [] (lookup (curfont st) (cmaps st)) + let cmap = Map.findWithDefault Map.empty (curfont st) (cmaps st) o <- octnum - return $ toUcs cmap o + lookupUcs cmap o -psletter :: [(Char,String)] -> PSParser T.Text +psletter :: Map.Map Char T.Text -> PSParser T.Text psletter fontmap = do c <- try (char '\\' >> oneOf "\\()") <|> @@ -368,32 +399,29 @@ <|> noneOf "\\" return $ replaceWithDiff fontmap c - where replaceWithDiff m c' = case lookup c' m of + where replaceWithDiff m c' = case Map.lookup c' m of Just s -> replaceWithCharDict s Nothing -> T.pack [c'] - replaceWithCharDict s = case Map.lookup s pdfcharmap of + replaceWithCharDict s = case Map.lookup (T.unpack s) pdfcharmap of Just cs -> cs - Nothing -> if "/uni" `isPrefixOf` s + Nothing -> if "/uni" `T.isPrefixOf` s then readUni s - else T.pack s - readUni s = case readHex (drop 4 s) of + else s + readUni s = case readHex (T.unpack $ T.drop 4 s) of [(i,"")] -> T.singleton $ chr i [(i,x)] -> T.pack (chr i : " ") - _ -> T.pack s + _ -> s octToChar [(o,"")] = case Map.lookup o extendedAscii of Just c -> c Nothing -> chr o octToChar _ = '?' -cidletter :: String -> PSParser T.Text -cidletter cidmapName = do +cidletter :: T.Text -> PSParser T.Text +cidletter _ = do o1 <- octnum o2 <- octnum let d = 256 * o1 + o2 - return $ - if cidmapName == "Adobe-Japan1" - then adobeOneSix d - else error $ "Unknown cidmap" ++ cidmapName + lookupUcs Map.empty d octnum :: PSParser Int octnum = do @@ -404,7 +432,7 @@ return $ d where octToDec [(o, "")] = o - octToDec _ = error "Unable to take Character in Octet" + octToDec _ = ord '?' escapedToDec 'n' = ord '\n' escapedToDec 'r' = ord '\r' escapedToDec 't' = ord '\t' @@ -429,7 +457,7 @@ spaces st <- getState let ff = fontfactor st - updateState (\s -> s{ curfont = font + updateState (\s -> s{ curfont = T.pack font , fontfactor = t , linex = t , liney = t}) @@ -667,12 +695,31 @@ return "" digitParam :: PSParser Double -digitParam = do - sign <- many $ char '-' +digitParam = do + sign <- (char '-' >> return "-") <|> return "" num <- ((++) <$> (("0"++) <$> (string ".")) <*> many1 digit) <|> ((++) <$> (many1 digit) <*> ((++) <$> (many $ char '.') <*> many digit)) - return $ read $ sign ++ num + return $ parsePdfNumber $ sign ++ num + +normalizePdfNumber :: String -> String +normalizePdfNumber s + | null s = s + | head s == '.' = '0' : s + | length s >= 2 && head s == '-' && s !! 1 == '.' = '-' : '0' : drop 2 s + | otherwise = s + +parsePdfNumber :: String -> Double +parsePdfNumber s + | null s || s == "-" || s == "+" = 0 + | last s == '.' = + case reads (normalizePdfNumber s ++ "0") of + [(n, "")] -> n + _ -> 0 + | otherwise = + case reads (normalizePdfNumber s) of + [(n, "")] -> n + _ -> 0 hexParam :: Parser T.Text hexParam = do diff --git a/src/PDF/Definition.hs b/src/PDF/Definition.hs --- a/src/PDF/Definition.hs +++ b/src/PDF/Definition.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module PDF.Definition where import Data.ByteString (ByteString) @@ -5,59 +7,86 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import Codec.Compression.Zlib (decompress) +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Text as T +import PDF.Error (PdfWarning(..)) type PDFBS = (Int,BS.ByteString) +data XrefEntry = InFile Int + | InObjStm Int Int + deriving (Eq, Show) + +type XREF = Map Int XrefEntry + type PDFObj = (Int,[Obj]) -type PDFStream = BSL.ByteString +type PDFObjIndex = Map Int [Obj] -type PDFxref = BSL.ByteString +type PDFStream = BSL.ByteString -data Obj = PdfDict Dict -- [(Obj, Obj)] - | PdfText String +data Obj = PdfDict Dict + | PdfText T.Text | PdfStream PDFStream - | PdfNumber Double - | PdfHex String + | PdfNumber Double + | PdfHex T.Text | PdfBool Bool | PdfArray [Obj] - | PdfName String + | PdfName T.Text | ObjRef Int - | ObjOther String + | ObjOther T.Text | PdfNull - deriving (Eq) + deriving (Eq, Show) -type Dict = [(Obj,Obj)] +type Dict = Map T.Text Obj -instance Show Obj where - show o = toString 0 o - -toString depth (PdfDict d) = concat $ map dictentry d - where dictentry (PdfName n, o) = concat $ ["\n"] ++ replicate depth " " ++ [n, ": ", toString (depth+1) o] - dictentry e = error $ "Illegular dictionary entry "++show e -toString depth (PdfText t) = t ---toString depth (PdfStream s) = "\n " ++ (BSL.unpack $ decompress s) -toString depth (PdfStream s) = "\n " ++ (BSL.unpack $ s) -toString depth (PdfNumber r) = show r -toString depth (PdfHex h) = h -toString depth (PdfArray a) = intercalate ", " $ map (toString depth) a -toString depth (PdfBool b) = show b -toString depth (PdfName n) = n -toString depth (ObjRef i) = show i -toString depth (ObjOther o) = o -toString depth (PdfNull) = "" +ppObj :: Obj -> String +ppObj = ppObjAt 0 +ppDict :: Int -> Dict -> String +ppDict depth d = concat $ map dictentry (M.toList d) + where dictentry (n, o) = + concat $ ["\n"] ++ replicate depth " " ++ [T.unpack n, ": ", ppObjAt (depth+1) o] -data Encoding = CIDmap String | Encoding [(Char,String)] | WithCharSet String | NullMap +ppDictEntries :: Dict -> String +ppDictEntries d = + "[" ++ intercalate "," (map (\(k, v) -> "(" ++ T.unpack k ++ "," ++ ppObj v ++ ")") (M.toList d)) ++ "]" +ppObjAt :: Int -> Obj -> String +ppObjAt depth (PdfDict d) = ppDict depth d +ppObjAt _ (PdfText t) = T.unpack t +ppObjAt _ (PdfStream s) = "\n " ++ BSL.unpack s +ppObjAt _ (PdfNumber r) = show r +ppObjAt _ (PdfHex h) = T.unpack h +ppObjAt depth (PdfArray a) = intercalate ", " $ map (ppObjAt depth) a +ppObjAt _ (PdfBool b) = show b +ppObjAt _ (PdfName n) = T.unpack n +ppObjAt _ (ObjRef i) = show i +ppObjAt _ (ObjOther o) = T.unpack o +ppObjAt _ PdfNull = "" + + +data Encoding = CIDmap T.Text | Encoding (Map Char T.Text) | WithCharSet T.Text | NullMap + instance Show Encoding where - show (CIDmap s) = "CIDmap"++s - show (Encoding a) = "Encoding"++show a - show (WithCharSet s) = "WithCharSet"++s + show (CIDmap s) = "CIDmap" ++ T.unpack s + show (Encoding a) = "Encoding" ++ show a + show (WithCharSet s) = "WithCharSet" ++ T.unpack s show NullMap = [] -type CMap = [(Int,String)] +type CMap = Map Int T.Text +data FontInfo = FontInfo + { fiEncoding :: Encoding + , fiToUnicode :: CMap + , fiWidth :: Int -> Double + , fiWidthV :: Int -> Double + , fiWMode :: Int + , fiBytesPerCode :: Int + , fiDefaultWidth :: Double + } + data PSR = PSR { linex :: Double , liney :: Double , absolutex :: Double @@ -69,11 +98,11 @@ , top :: Double , bottom :: Double , fontfactor :: Double - , curfont :: String - , cmaps :: [(String, CMap)] - , fontmaps :: [(String, Encoding)] - , colorspace :: String - , xcolorspaces :: [String] + , curfont :: T.Text + , cmaps :: Map T.Text CMap + , fontmaps :: Map T.Text Encoding + , colorspace :: T.Text + , xcolorspaces :: [T.Text] + , warnings :: [PdfWarning] } deriving (Show) - diff --git a/src/PDF/Diff.hs b/src/PDF/Diff.hs new file mode 100644 --- /dev/null +++ b/src/PDF/Diff.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : PDF.Diff +Description : Paragraph-level text diff between two PDF documents +License : MIT + +Compare two opened documents page by page using the same paragraph layout as +'PDF.Page.pageParagraphs'. Emits 'TextChange' records (and optionally a +'PageCountMismatch' when page counts differ). + +@example +import PDF.Diff (compareDocuments) +import PDF.Layout (defaultLayoutOptions) + +changes <- compareDocuments defaultLayoutOptions docA docB +-} +module PDF.Diff + ( TextChange(..) + , compareDocuments + , diffParagraphs + ) where + +import PDF.Document (Document) +import PDF.Error (PdfResult) +import PDF.Layout (LayoutOptions) +import PDF.Page (pageCount, pageRefAt, pageParagraphs) + +import Data.Char (isSpace) +import qualified Data.Text as T + +data TextChange + = TextChange + { changePageA :: !(Maybe Int) + , changePageB :: !(Maybe Int) + , changeParaA :: !(Maybe Int) + , changeParaB :: !(Maybe Int) + , changeOld :: !T.Text + , changeNew :: !T.Text + } + | PageCountMismatch + { pagesA :: !Int + , pagesB :: !Int + } + deriving (Eq, Show) + +-- | Paragraph-level diff across two documents (aligned by 1-based page number). +compareDocuments :: LayoutOptions -> Document -> Document -> PdfResult [TextChange] +compareDocuments opts docA docB = do + nA <- pageCount docA + nB <- pageCount docB + let countChange = + if nA /= nB + then [PageCountMismatch {pagesA = nA, pagesB = nB}] + else [] + aligned <- mapM (diffPagePair opts docA docB) [1 .. min nA nB] + extraA <- mapM (onlyInA opts docA) [min nA nB + 1 .. nA] + extraB <- mapM (onlyInB opts docB) [min nA nB + 1 .. nB] + return (countChange ++ concat aligned ++ concat extraA ++ concat extraB) + +diffPagePair :: LayoutOptions -> Document -> Document -> Int -> PdfResult [TextChange] +diffPagePair opts docA docB page = do + refA <- pageRefAt docA page + refB <- pageRefAt docB page + parasA <- pageParagraphs docA refA opts + parasB <- pageParagraphs docB refB opts + return (diffParagraphsOnPage page parasA parasB) + +onlyInA :: LayoutOptions -> Document -> Int -> PdfResult [TextChange] +onlyInA opts doc page = do + ref <- pageRefAt doc page + paras <- pageParagraphs doc ref opts + return + [ TextChange + { changePageA = Just page + , changePageB = Nothing + , changeParaA = Just idx + , changeParaB = Nothing + , changeOld = txt + , changeNew = T.empty + } + | (idx, txt) <- zip [0 ..] paras + ] + +onlyInB :: LayoutOptions -> Document -> Int -> PdfResult [TextChange] +onlyInB opts doc page = do + ref <- pageRefAt doc page + paras <- pageParagraphs doc ref opts + return + [ TextChange + { changePageA = Nothing + , changePageB = Just page + , changeParaA = Nothing + , changeParaB = Just idx + , changeOld = T.empty + , changeNew = txt + } + | (idx, txt) <- zip [0 ..] paras + ] + +diffParagraphsOnPage :: Int -> [T.Text] -> [T.Text] -> [TextChange] +diffParagraphsOnPage page parasA parasB = + map attachPage (diffParagraphs parasA parasB) + where + attachPage TextChange{changeParaA = pa, changeParaB = pb, changeOld = old, changeNew = new} = + TextChange (Just page) (Just page) pa pb old new + attachPage other = other + +-- | Paragraph LCS diff without page numbers (for unit tests). +diffParagraphs :: [T.Text] -> [T.Text] -> [TextChange] +diffParagraphs parasA parasB = + mergeReplaceChanges $ go (length normA) (length normB) [] + where + normA = map normalizePara parasA + normB = map normalizePara parasB + nB = length normB + table = lcsTable normA normB + tableAt i j = table !! (i * (nB + 1) + j) + + go 0 0 acc = reverse acc + go i j acc + | i > 0 && j > 0 && normA !! (i - 1) == normB !! (j - 1) = + go (i - 1) (j - 1) acc + | j > 0 && (i == 0 || tableAt (i - 1) j <= tableAt i (j - 1)) = + go i (j - 1) + ( TextChange Nothing Nothing Nothing (Just (j - 1)) T.empty (parasB !! (j - 1)) + : acc + ) + | i > 0 = + go (i - 1) j + ( TextChange Nothing Nothing (Just (i - 1)) Nothing (parasA !! (i - 1)) T.empty + : acc + ) + | otherwise = reverse acc + +mergeReplaceChanges :: [TextChange] -> [TextChange] +mergeReplaceChanges [] = [] +mergeReplaceChanges (c : d : rest) + | isRemoval c && isAddition d = + mergedChange c d : mergeReplaceChanges rest + | isAddition c && isRemoval d = + mergedChange d c : mergeReplaceChanges rest + | otherwise = c : mergeReplaceChanges (d : rest) +mergeReplaceChanges [c] = [c] + +mergedChange :: TextChange -> TextChange -> TextChange +mergedChange TextChange{changeParaA = pa, changeOld = old} + TextChange{changeParaB = pb, changeNew = new} = + TextChange Nothing Nothing pa pb old new + +isRemoval :: TextChange -> Bool +isRemoval TextChange{changeOld = old, changeNew = new} = + not (T.null old) && T.null new +isRemoval _ = False + +isAddition :: TextChange -> Bool +isAddition TextChange{changeOld = old, changeNew = new} = + T.null old && not (T.null new) +isAddition _ = False + +normalizePara :: T.Text -> T.Text +normalizePara = collapseInternalWS . T.strip + where + collapseInternalWS t = + T.pack $ go False (T.unpack t) + go _ [] = [] + go _ ('\r' : cs) = go False cs + go seen ('\n' : cs) = if seen then go True cs else ' ' : go True cs + go seen (c : cs) + | isSpace c = if seen then go True cs else ' ' : go True cs + | otherwise = c : go False cs + +lcsTable :: Eq a => [a] -> [a] -> [Int] +lcsTable xs ys = + let m = length xs + n = length ys + row i j + | i == 0 || j == 0 = 0 + | xs !! (i - 1) == ys !! (j - 1) = + 1 + tableAt (i - 1) (j - 1) + | otherwise = max (tableAt (i - 1) j) (tableAt i (j - 1)) + tableAt i j = table !! (i * (n + 1) + j) + table = [row i j | i <- [0 .. m], j <- [0 .. n]] + in table diff --git a/src/PDF/Document.hs b/src/PDF/Document.hs new file mode 100644 --- /dev/null +++ b/src/PDF/Document.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : PDF.Document +Description : Single-read PDF document handle +License : MIT + +Open a PDF once and reuse the parsed object index for text extraction, +page APIs, diff, images, and form export. + +@example +import PDF.Document (Document, openDocument) +import PDF.Error (PdfResult) + +load :: FilePath -> IO (PdfResult Document) +load path = openDocument path Nothing +-} +module PDF.Document + ( Document(..) + , openDocument + , docRootRef + , docInfoDict + ) where + +import PDF.Definition +import PDF.DocumentStructure + ( buildIndex + , buildIndexEager + , findTrailer + , findTrailer' + , findObjFromDict + , findDict + , findDictByRef + , findRefs + , extractObjBody + , findObjs + , rawStream + , fontInfoFromDict + ) +import PDF.Encrypt (Security, securityFromEncryptDict) +import PDF.Error (PdfError(..), PdfResult) +import PDF.Object (parsePDFObj) + +import Data.List (find) +import Data.Maybe (fromMaybe) + +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Map as Map + +-- | Parsed PDF: trailer dictionary, object index, and optional encryption state. +-- Use 'openDocument' to construct; pass the same value to extraction and page APIs. +data Document = Document + { docTrailer :: Dict + , docObjs :: PDFObjIndex + , docSecurity :: Maybe Security + , docStreamCache :: Map.Map Int (PdfResult BSL.ByteString) + , docFontCache :: Map.Map Int FontInfo + } + +-- | Read a PDF file from disk. @password@ is @Nothing@ for unencrypted files, +-- or @Just@ the user password for encrypted documents. +-- +-- Returns 'PdfResult' so xref, object, and decryption failures are reported +-- without crashing the process. +-- +-- @example +-- result <- openDocument "paper.pdf" Nothing +-- case result of +-- Left err -> print err +-- Right doc -> ... +openDocument :: FilePath -> Maybe String -> IO (PdfResult Document) +openDocument f password = do + bytes <- BS.readFile f + return (openDocumentBytes bytes password) + +openDocumentBytes :: BS.ByteString -> Maybe String -> PdfResult Document +openDocumentBytes bytes password = + case findTrailer' bytes of + Right (trailer, xref) -> do + msec <- loadSecurity bytes trailer xref password + let objs = buildIndex bytes msec xref + streamCache = Map.mapWithKey (\r os -> rawStream msec r os) objs + fontCache = + Map.mapWithKey + (\r _ -> fontInfoFromDict msec objs (fromMaybe Map.empty (findDictByRef r objs))) + objs + return (Document trailer objs msec streamCache fontCache) + Left _ -> do + trailer <- findTrailer bytes + msec <- loadSecurityScan bytes trailer password + objs <- buildIndexEager bytes msec + let streamCache = Map.mapWithKey (\r os -> rawStream msec r os) objs + fontCache = + Map.mapWithKey + (\r _ -> fontInfoFromDict msec objs (fromMaybe Map.empty (findDictByRef r objs))) + objs + return (Document trailer objs msec streamCache fontCache) + +loadSecurity :: BS.ByteString -> Dict -> XREF -> Maybe String -> PdfResult (Maybe Security) +loadSecurity bytes trailer xref password = + case findObjFromDict trailer "/Encrypt" of + Nothing -> Right Nothing + Just (ObjRef ref) -> + case findEncryptDict bytes xref ref of + Just d -> + let pw = fromMaybe "" password + in case securityFromEncryptDict d trailer (Just pw) of + Just sec -> Right (Just sec) + Nothing -> Left (DecryptionError "invalid or missing password") + Nothing -> Left (DecryptionError "invalid or missing password") + _ -> Left (DecryptionError "invalid or missing password") + +loadSecurityScan :: BS.ByteString -> Dict -> Maybe String -> PdfResult (Maybe Security) +loadSecurityScan bytes trailer password = + case findObjFromDict trailer "/Encrypt" of + Nothing -> Right Nothing + Just (ObjRef ref) -> + case findEncryptDictScan bytes ref of + Just d -> + let pw = fromMaybe "" password + in case securityFromEncryptDict d trailer (Just pw) of + Just sec -> Right (Just sec) + Nothing -> Left (DecryptionError "invalid or missing password") + Nothing -> Left (DecryptionError "invalid or missing password") + _ -> Left (DecryptionError "invalid or missing password") + +findEncryptDict :: BS.ByteString -> XREF -> Int -> Maybe Dict +findEncryptDict bytes xref ref = + case Map.lookup ref xref of + Just (InFile off) -> + let body = extractObjBody bytes off + in findDict (snd (parsePDFObj Nothing (ref, body))) + _ -> findEncryptDictScan bytes ref + +findEncryptDictScan :: BS.ByteString -> Int -> Maybe Dict +findEncryptDictScan bytes ref = + case find ((== ref) . fst) (findObjs bytes) of + Just objbs -> findDict (snd (parsePDFObj Nothing objbs)) + Nothing -> Nothing + +docRootRef :: Document -> PdfResult Int +docRootRef doc = + case findRefs "/Root" (docTrailer doc) of + Just r -> Right r + Nothing -> Left (MissingKey "/Root" "trailer") + +docInfoDict :: Document -> PdfResult Dict +docInfoDict doc = + case findRefs "/Info" (docTrailer doc) of + Nothing -> Left (MissingKey "/Info" "trailer") + Just inforef -> + case findDictByRef inforef (docObjs doc) of + Just d -> Right d + Nothing -> Left (MissingObject inforef) diff --git a/src/PDF/DocumentStructure.hs b/src/PDF/DocumentStructure.hs --- a/src/PDF/DocumentStructure.hs +++ b/src/PDF/DocumentStructure.hs @@ -9,450 +9,1019 @@ -} module PDF.DocumentStructure - ( parseTrailer - , expandObjStm - , rootRef - , contentsStream - , rawStreamByRef - , findKids - , findPages - , findDict - , findDictByRef - , findDictOfType - , findObjFromDict - , findObjFromDictWithRef - , findObjsByRef - , findObjs - , findTrailer - , rawStream - ) where - -import Data.Char (chr) -import Data.List (find) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.ByteString.Builder as B -import qualified Data.Text as T -import Data.Maybe (fromMaybe) -import Numeric (readDec) - -import Data.Attoparsec.ByteString.Char8 hiding (take) -import Data.Attoparsec.Combinator -import Control.Applicative -import Codec.Compression.Zlib (decompress) - -import Debug.Trace - -import PDF.Definition -import PDF.Object -import PDF.ContentStream (parseStream, parseColorSpace) -import PDF.Cmap (parseCMap) -import qualified PDF.OpenType as OpenType -import qualified PDF.CFF as CFF -import qualified PDF.Type1 as Type1 - -spaces = skipSpace -oneOf = satisfy . inClass -noneOf = satisfy . notInClass - --- find objects - -findObjs :: BS.ByteString -> [PDFBS] -findObjs contents = case parseOnly (many1 pdfObj) contents of - Left err -> [] - Right rlt -> rlt - -findXref :: BS.ByteString -> String -findXref contents = case parseOnly (xref) contents of - Left err -> [] - Right rlt -> rlt - -findObjsByRef :: Int -> [PDFObj] -> Maybe [Obj] -findObjsByRef x pdfobjs = case find (isRefObj (Just x)) pdfobjs of - Just (_,objs) -> Just objs - Nothing -> Nothing - where - isRefObj (Just x) (y, objs) = if x==y then True else False - isRefObj _ _ = False - -findObjFromDictWithRef :: Int -> String -> [PDFObj] -> Maybe Obj -findObjFromDictWithRef ref name objs = case findDictByRef ref objs of - Just d -> findObjFromDict d name - Nothing -> Nothing - -findObjFromDict :: Dict -> String -> Maybe Obj -findObjFromDict d name = case find isName d of - Just (_, o) -> Just o - otherwise -> Nothing - where isName (PdfName n, _) = if name == n then True else False - isName _ = False - -findDictByRef :: Int -> [PDFObj] -> Maybe Dict -findDictByRef ref objs = case findObjsByRef ref objs of - Just os -> findDict os - Nothing -> Nothing - -findDictOfType :: String -> [Obj] -> Maybe Dict -findDictOfType typename objs = case findDict objs of - Just d -> if isType d then Just d else Nothing - Nothing -> Nothing - where - isType dict = (PdfName "/Type",PdfName typename) `elem` dict - -findDict :: [Obj] -> Maybe Dict -findDict objs = case find isDict objs of - Just (PdfDict d) -> Just d - otherwise -> Nothing - where - isDict :: Obj -> Bool - isDict (PdfDict d) = True - isDict _ = False - -findPages :: Dict -> Maybe Int -findPages dict = case find isPagesRef dict of - Just (_, ObjRef x) -> Just x - Nothing -> Nothing - where - isPagesRef (PdfName "/Pages", ObjRef x) = True - isPagesRef (_,_) = False - -findKids :: Dict -> Maybe [Int] -findKids dict = case find isKidsRefs dict of - Just (_, PdfArray arr) -> Just (parseRefsArray arr) - Nothing -> Nothing - where - isKidsRefs (PdfName "/Kids", PdfArray x) = True - isKidsRefs (_,_) = False - -contentsStream :: Dict -> PSR -> [PDFObj] -> PDFStream -contentsStream dict st objs = case find contents dict of - Just (PdfName "/Contents", PdfArray arr) -> getContentArray arr - Just (PdfName "/Contents", ObjRef r) -> - case findObjsByRef r objs of - Just [PdfArray arr] -> getContentArray arr - Just _ -> getContent r - Nothing -> error "No content to be shown" - Nothing -> error "No content to be shown" - where - contents (PdfName "/Contents", _) = True - contents _ = False - - getContentArray arr = parseContentStream dict st objs $ - BSL.concat $ map (rawStreamByRef objs) (parseRefsArray arr) - getContent r = parseContentStream dict st objs $ rawStreamByRef objs r - -parseContentStream :: Dict -> PSR -> [PDFObj] -> BSL.ByteString -> PDFStream -parseContentStream dict st objs s = - parseStream (st {fontmaps=fontdict, cmaps=cmap}) s - where fontdict = findFontEncoding dict objs - cmap = findCMap dict objs - -rawStreamByRef :: [PDFObj] -> Int -> BSL.ByteString -rawStreamByRef pdfobjs x = case findObjsByRef x pdfobjs of - Just objs -> rawStream objs - Nothing -> error "No object with stream to be shown" - -rawStream :: [Obj] -> BSL.ByteString -rawStream objs = case find isStream objs of - Just (PdfStream strm) -> rawStream' (fromMaybe [] $ findDict objs) strm - Nothing -> BSL.pack $ show objs - where - isStream (PdfStream s) = True - isStream _ = False - - rawStream' :: Dict -> BSL.ByteString -> BSL.ByteString - rawStream' d s = streamFilter d s - - streamFilter d = case find withFilter d of - Just (PdfName "/Filter", PdfName "/FlateDecode") - -> decompress - Just (PdfName "/Filter", PdfName f) - -> error $ "Unknown Stream Compression: " ++ f -- need fix - Just _ -> error $ "No Stream Compression Filter." - Nothing -> id - - withFilter (PdfName "/Filter", _) = True - withFilter _ = False - -contentsColorSpace :: Dict -> PSR -> [PDFObj] -> [T.Text] -contentsColorSpace dict st objs = case find contents dict of - Just (PdfName "/Contents", PdfArray arr) -> concat $ map (parseColorSpace (st {xcolorspaces=xobjcs}) . rawStreamByRef objs) (parseRefsArray arr) - Just (PdfName "/Contents", ObjRef x) -> parseColorSpace (st {xcolorspaces=xobjcs}) $ rawStreamByRef objs x - Nothing -> error "No content to be shown" - where - contents (PdfName "/Contents", _) = True - contents _ = False - xobjcs = findXObjectColorSpace dict objs - - --- find XObject - -findXObjectColorSpace d os = xobjColorSpaceMap (findXObject d os) os - -xobjColorSpaceMap dict objs = map pairwise dict - where - pairwise (PdfName n, ObjRef r) = xobjColorSpace r objs - pairwise x = "" - -findXObject dict objs = case findResourcesDict dict objs of - Just d -> case findObjFromDict d "/XObject" of - Just (PdfDict d) -> d - otherwise -> [] - Nothing -> [] - -xobjColorSpace :: Int -> [PDFObj] -> String -xobjColorSpace x objs = case findObjFromDictWithRef x "/ColorSpace" objs of - Just (PdfName cs) -> cs - otherwise -> "" - - --- find root ref from Trailer or Cross-Reference Dictionary - -parseTrailer :: BS.ByteString -> Maybe Dict -parseTrailer bs = case BS.breakEnd (== '\n') bs of - (source, eofLine) - | "%%EOF" `BS.isPrefixOf` eofLine - -> Just (parseCRDict $ BS.drop (getOffset source) bs) - | source == "" -> Nothing - | otherwise -> parseTrailer (BS.init bs) - -getOffset bs = case BS.breakEnd (== '\n') (BS.init bs) of - (_, nstr) -> case readDec $ BS.unpack nstr of - [(n,_)] -> n - _ -> error "Could not find Offset" - -parseCRDict :: BS.ByteString -> Dict -parseCRDict rlt = case parseOnly crdict rlt of - Left err -> error $ show (BS.take 100 rlt) - Right (PdfDict dict) -> dict - Right _ -> error "Could not find Cross-Reference dictionary" - where - crdict :: Parser Obj - crdict = do - spaces - (try skipCRtable <|> skipCRstream) - d <- pdfdictionary <* spaces - return d - skipCRtable = ((manyTill anyChar (try $ string "trailer")) >> spaces) - skipCRstream = (many1 digit >> spaces >> digit >> string " obj" >> spaces) - -rootRef :: BS.ByteString -> Maybe Int -rootRef bs = case parseTrailer bs of - Just dict -> findRefs isRootRef dict - Nothing -> rootRefFromCRStream bs - -rootRefFromCRStream :: BS.ByteString -> Maybe Int -rootRefFromCRStream bs = - let offset = (read . BS.unpack . head . drop 1 . reverse . BS.lines $ (trace (show bs) bs)) :: Int - crstrm = snd . head . findObjs $ BS.drop offset bs - crdict = parseCRDict crstrm - in findRefs isRootRef $ crdict - -isRootRef (PdfName "/Root", ObjRef x) = True -isRootRef (_,_) = False - -findRefs :: ((Obj,Obj) -> Bool) -> Dict -> Maybe Int -findRefs pred dict = case find pred dict of - Just (_, ObjRef x) -> Just x - Nothing -> Nothing - - --- find Info - -findTrailer bs = do - case parseTrailer bs of - Just d -> d - Nothing -> [] - -infoRef bs = case parseTrailer bs of - Just dict -> findRefs isInfoRef dict - Nothing -> error "No ref for info" - -isInfoRef (PdfName "/Info", ObjRef x) = True -isInfoRef (_,_) = False - - --- expand PDF 1.5 Object Stream - -expandObjStm :: [PDFObj] -> [PDFObj] -expandObjStm os = concat $ map objStm os - -objStm :: PDFObj -> [PDFObj] -objStm (n, obj) = case findDictOfType "/ObjStm" obj of - Nothing -> [(n,obj)] - Just _ -> pdfObjStm n $ BSL.toStrict $ rawStream obj - -refOffset :: Parser ([(Int, Int)], String) -refOffset = spaces *> ((,) - <$> many1 ((\r o -> (read r :: Int, read o :: Int)) - <$> (many1 digit <* spaces) - <*> (many1 digit <* spaces)) - <*> many1 anyChar) - -pdfObjStm n s = - let (location, objstr) = case parseOnly refOffset s of - Right val -> val - Left err -> error $ "Failed to parse Object Stream: " - in map (\(r,o) -> (r, parseDict $ BS.pack $ drop o objstr)) location - where parseDict s' = case parseOnly pdfdictionary s' of - Right obj -> [obj] - Left _ -> case parseOnly pdfarray s' of - Right obj -> [obj] - Left _ -> case parseOnly pdfletters s' of - Right obj -> [obj] - Left err -> error $ (show err) ++ ":\n Failed to parse obj around; \n" - ++ (show $ BS.take 100 s') - - --- make fontmap from page's /Resources (see 3.7.2 of PDF Ref.) - -findFontEncoding d os = findEncoding (fontObjs d os) os - -findEncoding :: Dict -> [PDFObj] -> [(String, Encoding)] -findEncoding dict objs = map pairwise dict - where - pairwise (PdfName n, ObjRef r) = (n, encoding r objs) - pairwise x = ("", NullMap) - -fontObjs :: Dict -> [PDFObj] -> Dict -fontObjs dict objs = case findResourcesDict dict objs of - Just d -> case findObjFromDict d "/Font" of - Just (PdfDict d') -> d' - Just (ObjRef x) -> case findDictByRef x objs of - Just d' -> d' - otherwise -> error "cannot find /Font dictionary" - otherwise -> trace (show d) $ [] - Nothing -> [] - -findResourcesDict :: Dict -> [PDFObj] -> Maybe Dict -findResourcesDict dict objs = case find resources dict of - Just (_, ObjRef x) -> findDictByRef x objs - Just (_, PdfDict d) -> Just d - otherwise -> error (show dict) - where - resources (PdfName "/Resources", _) = True - resources _ = False - - -encoding :: Int -> [PDFObj] -> Encoding -encoding x objs = case subtype of - Just (PdfName "/Type0") -> case encoding of - Just (PdfName "/Identity-H") -> head $ cidSysInfo descendantFonts - -- TODO" when /Encoding is stream of CMap - Just (PdfName s) -> error $ "Unknown Encoding " ++ (show s) ++ " for a Type0 font. Check " ++ show x - _ -> error $ "Something wrong with a Type0 font. Check " ++ (show x) - Just (PdfName "/Type1") -> case encoding of - Just (ObjRef r) -> case findObjFromDictWithRef r "/Differences" objs of - Just (PdfArray arr) -> charDiff arr - _ -> error "No /Differences" - Just (PdfDict d) -> case findObjFromDict d "/Differences" of - Just (PdfArray arr) -> charDiff arr - _ -> error "No /Differences" - Just (PdfName "/MacRomanEncoding") -> NullMap - Just (PdfName "/MacExpertEncoding") -> NullMap - Just (PdfName "/WinAnsiEncoding") -> NullMap - -- TODO: FontFile (Type 1), FontFile2 (TrueType), FontFile3 (Other than Type1C) - _ -> case findObjFromDict (fontDescriptor' x) "/FontFile3" of - Just (ObjRef fontfile) -> - CFF.encoding $ BSL.toStrict $ rawStreamByRef objs fontfile - _ -> case findObjFromDict (fontDescriptor' x) "/FontFile" of - Just (ObjRef fontfile) -> - Type1.encoding $ BSL.toStrict $ rawStreamByRef objs fontfile - _ -> NullMap - -- TODO - Just (PdfName "/Type2") -> NullMap - Just (PdfName "/Type3") -> NullMap - _ -> NullMap - - where - subtype = get "/Subtype" - encoding = get "/Encoding" - toUnicode = get "/ToUnicode" - - get s = findObjFromDictWithRef x s objs - - -- Should be an array (or ref to an array) containing refs - descendantFonts :: [Obj] - descendantFonts = case findObjFromDictWithRef x "/DescendantFonts" objs of - Just (PdfArray dfrs) -> dfrs - Just (ObjRef r) -> case findObjsByRef r objs of - Just [(PdfArray dfrs)] -> dfrs - _ -> error $ "Can not find /DescendantFonts entries in " ++ show r - _ -> error $ "Can not find /DescendantFonts itself in " ++ show x - - cidSysInfo :: [Obj] -> [Encoding] - cidSysInfo [] = [] - cidSysInfo ((ObjRef r):rs) = (cidSysInfo' r):(cidSysInfo rs) - cidSysInfo' dfr = case findObjFromDictWithRef dfr "/CIDSystemInfo" objs of - Just (PdfDict dict) -> getCIDSystemInfo dict - Just (ObjRef r) -> case findDictByRef r objs of - Just dict -> getCIDSystemInfo dict - _ -> error $ "Can not find /CIDSystemInfo entries in" ++ show r - _ -> error $ "Can not find /CidSystemInfo itself " ++ show dfr - - fontDescriptor :: [Obj] -> [Dict] - fontDescriptor [] = [] - fontDescriptor ((ObjRef r):rs) = (fontDescriptor' r):(fontDescriptor rs) - fontDescriptor' :: Int -> Dict - fontDescriptor' fdr = case findObjFromDictWithRef fdr "/FontDescriptor" objs of - Just (ObjRef r) -> case findDictByRef r objs of - Just dict -> dict - _ -> error $ "No /FontDescriptor entries in " ++ show r - _ -> error $ "Can not find /FontDescriptor itself in " ++ show fdr - - getCIDSystemInfo d = - let registry = case findObjFromDict d "/Registry" of - Just (PdfText r) -> r - otherwise -> error "Can not find /Registry" - ordering = case findObjFromDict d "/Ordering" of - Just (PdfText o) -> o - othserwise -> error "Can not find /Ordering" - supplement = case findObjFromDict d "/Supplement" of - Just (PdfNumber s) -> s - otherwise -> error "Can not find /Supprement" - cmap = registry ++ "-" ++ ordering -- ex. "Adobe-Japan1" - in if cmap == "Adobe-Japan1" - then CIDmap cmap - else WithCharSet "" - - -charDiff :: [Obj] -> Encoding -charDiff objs = Encoding $ charmap objs 0 - where charmap (PdfNumber x : PdfName n : xs) i = - if i < truncate x then - (chr $ truncate x, n) : (charmap xs $ incr x) - else - (chr $ i, n) : (charmap xs $ i+1) - charmap (PdfName n : xs) i = (chr i, n) : (charmap xs $ i+1) - charmap [] i = [] - incr x = (truncate x) + 1 - - -findCMap :: Dict -> [PDFObj] -> [(String, CMap)] -findCMap d objs = map pairwise (fontObjs d objs) - where - pairwise (PdfName n, ObjRef r) = (n, toUnicode r objs) - pairwise x = ("", []) - -toUnicode :: Int -> [PDFObj] -> CMap -toUnicode x objs = - case findObjFromDictWithRef x "/ToUnicode" objs of - Just (ObjRef ref) -> - parseCMap $ rawStreamByRef objs ref - otherwise -> noToUnicode x objs - -noToUnicode x objs = - case findObjFromDictWithRef x "/DescendantFonts" objs of - Just (ObjRef ref) -> - case findObjsByRef ref objs of - Just [(PdfArray ((ObjRef subref):_))] -> - case findObjFromDictWithRef subref "/FontDescriptor" objs of - Just (ObjRef desc) -> - case findObjFromDictWithRef desc "/FontFile2" objs of - Just (ObjRef fontfile) -> - OpenType.cmap $ BSL.toStrict $ rawStreamByRef objs fontfile - otherwise -> [] - otherwise -> [] - otherwise -> [] - otherwise -> [] + ( buildIndex + , buildIndexEager + , expandObjStm + , rootRef + , contentsStream + , rawStreamByRef + , findKids + , findPages + , findDict + , findDictByRef + , findDictOfType + , findObjFromDict + , findObjFromDictWithRef + , findRefs + , findObjsByRef + , findObjs + , findObjs' + , findTrailer + , findTrailer' + , indexPDFObjs + , extractObjBody + , rawStream + , fontInfo + , fontInfoFromDict + , parseCIDWidths + , simpleWidthAt + , findResourcesDict + , decodeStreamBytes + , streamFilterNames + ) where + +import Data.Char (chr, isDigit, ord) +import Data.List (find, foldl', isSuffixOf, nub) +import Data.Bits ((.&.), shiftR) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.ByteString.Builder as B +import qualified Data.Text as T +import Data.Maybe (fromMaybe) +import Numeric (readDec) + +import Data.Attoparsec.ByteString.Char8 hiding (take, isDigit) +import Data.Attoparsec.ByteString.Char8 as P (take, takeWhile, takeWhile1) +import Data.Attoparsec.Combinator +import Control.Applicative +import Control.Monad (replicateM, foldM) +import Codec.Compression.Zlib (decompress) +import qualified Data.Map as M +import Data.Map (Map) + +import PDF.Definition +import PDF.Object +import PDF.Error (PdfError(..), PdfResult, PdfWarning(..)) +import PDF.Encrypt (Security, decryptStream) +import PDF.ContentStream (parseStream, parseColorSpace) +import PDF.Cmap (parseCMap) +import qualified PDF.OpenType as OpenType +import qualified PDF.CFF as CFF +import qualified PDF.Type1 as Type1 + +spaces = skipSpace +oneOf = satisfy . inClass +noneOf = satisfy . notInClass + +-- find objects + +findObjs :: BS.ByteString -> [PDFBS] +findObjs = collectPDFObjs + +findObjs' :: BS.ByteString -> PdfResult [PDFBS] +findObjs' contents = case findTrailer' contents of + Right (_, xref) -> + Right + [ (n, extractObjBody contents off) + | (n, InFile off) <- M.toAscList xref + ] + Left xrefErr -> case findObjs contents of + [] -> Left xrefErr + objs -> Right objs + +extractObjBody :: BS.ByteString -> Int -> BS.ByteString +extractObjBody contents offset = + case sliceObjectAt (BS.drop offset contents) of + Just body -> body + Nothing -> + case BS.breakSubstring "endobj" (BS.drop offset contents) of + (before, _) -> + let (_, body) = BS.breakSubstring " obj" before + in BS.dropWhile isPdfSpace body + +isPdfSpace :: Char -> Bool +isPdfSpace w = w `elem` ['\0', '\t', '\n', '\f', '\r', ' '] + +findObjsByRef :: Int -> PDFObjIndex -> Maybe [Obj] +findObjsByRef = M.lookup + +indexPDFObjs :: [PDFObj] -> PDFObjIndex +indexPDFObjs = M.fromList + +buildIndex :: BS.ByteString -> Maybe Security -> XREF -> PDFObjIndex +buildIndex bytes msec xref = objs + where + objs = M.mapWithKey resolve xref + containerCache = + M.fromList + [ (cnum, objStmEntries cnum) + | cnum <- nub [c | InObjStm c _ <- M.elems xref] + ] + resolve objNum (InFile off) = + let body = extractObjBody bytes off + in snd (parsePDFObj msec (objNum, body)) + resolve objNum (InObjStm cnum idx) = + case M.lookup cnum containerCache of + Just entries -> + case lookup objNum entries of + Just o -> o + Nothing -> + case drop idx entries of + ((_, o) : _) -> o + _ -> [PdfNull] + Nothing -> [PdfNull] + objStmEntries cnum = + case rawStream msec cnum (M.findWithDefault [PdfNull] cnum objs) of + Right streamBytes -> + case pdfObjStm cnum (BSL.toStrict streamBytes) of + Right entries -> entries + Left _ -> [] + Left _ -> [] + +buildIndexEager :: BS.ByteString -> Maybe Security -> PdfResult PDFObjIndex +buildIndexEager bytes msec = do + rawObjs <- case findObjs bytes of + [] -> Left (BrokenXref "no objects found without xref") + objs -> Right objs + let parsed = map (parsePDFObj msec) rawObjs + expanded <- expandObjStm msec parsed + return (indexPDFObjs expanded) + +findObjFromDictWithRef :: Int -> T.Text -> PDFObjIndex -> Maybe Obj +findObjFromDictWithRef ref name objs = case findDictByRef ref objs of + Just d -> findObjFromDict d name + Nothing -> Nothing + +findObjFromDict :: Dict -> T.Text -> Maybe Obj +findObjFromDict d name = M.lookup name d + +findDictByRef :: Int -> PDFObjIndex -> Maybe Dict +findDictByRef ref objs = case findObjsByRef ref objs of + Just os -> findDict os + Nothing -> Nothing + +findDictOfType :: T.Text -> [Obj] -> Maybe Dict +findDictOfType typename objs = case findDict objs of + Just d -> if isType d then Just d else Nothing + Nothing -> Nothing + where + isType dict = M.lookup "/Type" dict == Just (PdfName typename) + +findDict :: [Obj] -> Maybe Dict +findDict objs = case find isDict objs of + Just (PdfDict d) -> Just d + otherwise -> Nothing + where + isDict :: Obj -> Bool + isDict (PdfDict d) = True + isDict _ = False + +findPages :: Dict -> Maybe Int +findPages dict = case M.lookup "/Pages" dict of + Just (ObjRef x) -> Just x + _ -> Nothing + +findKids :: Dict -> Maybe [Int] +findKids dict = case M.lookup "/Kids" dict of + Just (PdfArray arr) -> Just (parseRefsArray arr) + _ -> Nothing + +contentsStream :: Dict -> PSR -> Maybe Security -> PDFObjIndex -> PdfResult (PDFStream, [PdfWarning]) +contentsStream dict st sec objs = case M.lookup "/Contents" dict of + Just (PdfArray arr) -> getContentArray arr + Just (ObjRef r) -> + case findObjsByRef r objs of + Just [PdfArray arr] -> getContentArray arr + Just _ -> getContent r + Nothing -> Left (MissingKey "/Contents" (show r)) + Nothing -> Left (MissingKey "/Contents" "page") + where + getContentArray arr = parseContentStream dict st sec objs $ + BSL.concat [s | ref <- parseRefsArray arr + , Right s <- [rawStreamByRef sec objs ref]] + getContent r = do + s <- rawStreamByRef sec objs r + parseContentStream dict st sec objs s + +parseContentStream :: Dict -> PSR -> Maybe Security -> PDFObjIndex -> BSL.ByteString -> PdfResult (PDFStream, [PdfWarning]) +parseContentStream dict st sec objs s = + parseStream (st {fontmaps=fontdict, cmaps=cmap}) s + where fontdict = findFontEncoding dict sec objs + cmap = findCMap dict sec objs + +rawStreamByRef :: Maybe Security -> PDFObjIndex -> Int -> PdfResult BSL.ByteString +rawStreamByRef sec pdfobjs x = case findObjsByRef x pdfobjs of + Just objs -> rawStream sec x objs + Nothing -> Left (ParseError "No object with stream to be shown" BS.empty) + +rawStream :: Maybe Security -> Int -> [Obj] -> PdfResult BSL.ByteString +rawStream sec objNum objs = case find isStream objs of + Just (PdfStream strm) -> rawStream' sec objNum (fromMaybe M.empty $ findDict objs) strm + Nothing -> Left (ParseError "No object with stream to be shown" + (BS.take 80 $ BS.pack $ show objs)) + where + isStream (PdfStream s) = True + isStream _ = False + + rawStream' :: Maybe Security -> Int -> Dict -> BSL.ByteString -> PdfResult BSL.ByteString + rawStream' sec' objNum' d s = do + decoded <- decodeStreamBytes d $ BSL.fromStrict $ + decryptStream sec' objNum' 0 $ BSL.toStrict s + return $ BSL.fromStrict decoded + +supportedStreamFilters :: [String] +supportedStreamFilters = + [ "/FlateDecode", "/DCTDecode", "/ASCII85Decode" ] + +decodeStreamBytes :: Dict -> BSL.ByteString -> PdfResult BS.ByteString +decodeStreamBytes d s = do + filters <- streamFilterNames d + filtered <- applyStreamFilters filters s + applyPredictor d filtered + +streamFilterNames :: Dict -> PdfResult [T.Text] +streamFilterNames d = case M.lookup "/Filter" d of + Nothing -> Right [] + Just (PdfName n) -> Right [n] + Just (PdfArray arr) -> + Right [ n | PdfName n <- arr ] + Just _ -> + Left (UnsupportedFeature "invalid /Filter entry (expected name or array of names)") + +applyStreamFilters :: [T.Text] -> BSL.ByteString -> PdfResult BS.ByteString +applyStreamFilters [] s = Right (BSL.toStrict s) +applyStreamFilters (f : fs) s = do + step <- decodeOneStreamFilter f s + applyStreamFilters fs (BSL.fromStrict step) + +decodeOneStreamFilter :: T.Text -> BSL.ByteString -> PdfResult BS.ByteString +decodeOneStreamFilter "/FlateDecode" s = + Right $ BSL.toStrict $ decompress s +decodeOneStreamFilter "/DCTDecode" s = + Right $ BSL.toStrict s +decodeOneStreamFilter "/ASCII85Decode" s = + decodeASCII85 (BSL.toStrict s) +decodeOneStreamFilter f _ = + Left $ + UnsupportedFeature + ( "unsupported stream filter " + ++ T.unpack f + ++ " (supported: " + ++ unwords supportedStreamFilters + ++ ")" + ) + +-- | PDF ASCII85Decode (base-85, 'z' = four zero bytes, '~>' EOD). +decodeASCII85 :: BS.ByteString -> PdfResult BS.ByteString +decodeASCII85 bs = + Right $ BS.pack $ go (Prelude.filter isAscii85Data (BS.unpack bs)) [] + where + isAscii85Data c = + let o = ord c + in (o >= 33 && o <= 117) || c == 'z' || c == 'Z' + go [] acc = reverse acc + go ('z' : rest) acc = go rest ('\0' : '\0' : '\0' : '\0' : acc) + go ('Z' : rest) acc = go rest ('\0' : '\0' : '\0' : '\0' : acc) + go cs acc = + let grp = Prelude.take 5 cs + rest = drop 5 cs + pad = replicate (5 - Prelude.length grp) 'u' + vals = map (\c -> ord c - 33) (grp ++ pad) + n = foldl' (\a x -> a * 85 + x) 0 vals + bytes = + [ (n `shiftR` 24) .&. 0xff + , (n `shiftR` 16) .&. 0xff + , (n `shiftR` 8) .&. 0xff + , n .&. 0xff + ] + out = map chr (Prelude.take (max 0 (Prelude.length grp - 1)) (reverse bytes)) + in if null grp then reverse acc else go rest (out ++ acc) + +applyPredictor :: Dict -> BS.ByteString -> PdfResult BS.ByteString +applyPredictor d bs = case findObjFromDict d "/DecodeParms" of + Just (PdfDict parms) -> + case findObjFromDict parms "/Predictor" of + Just (PdfNumber p) | truncate p >= 12 -> + case findObjFromDict parms "/Columns" of + Just (PdfNumber c) -> decodePNGPredictors bs (truncate c) + _ -> Right bs + _ -> Right bs + _ -> Right bs + +decodePNGPredictors :: BS.ByteString -> Int -> PdfResult BS.ByteString +decodePNGPredictors bs columns = go BS.empty bs + where + go _ rest | BS.null rest = Right BS.empty + go prev rest = do + let filt = BS.head rest + enc = BS.take columns (BS.drop 1 rest) + rest' = BS.drop (1 + columns) rest + prevRow = if BS.null prev then BS.replicate columns (chr 0) else prev + row <- pngFilter filt enc prevRow + more <- go row rest' + return $ BS.append row more + +pngFilter :: Char -> BS.ByteString -> BS.ByteString -> PdfResult BS.ByteString +pngFilter filt row prev + | ord filt == 0 = Right row + | ord filt == 1 = Right $ pngSub row + | ord filt == 2 = Right $ pngUp row prev + | otherwise = + Left (UnsupportedFeature ("unsupported PNG predictor " ++ show (ord filt))) + +pngUp :: BS.ByteString -> BS.ByteString -> BS.ByteString +pngUp row prev = BS.pack $ zipWith addByte (BS.unpack row) (BS.unpack prev) + where addByte a b = chr ((ord a + ord b) `mod` 256) + +pngSub :: BS.ByteString -> BS.ByteString +pngSub row = + BS.pack $ snd $ foldl' (\(prev, out) x -> + let n = (ord x + prev) `mod` 256 in (n, out ++ [chr n])) (0, []) (BS.unpack row) + +contentsColorSpace :: Dict -> PSR -> Maybe Security -> PDFObjIndex -> PdfResult [T.Text] +contentsColorSpace dict st sec objs = case M.lookup "/Contents" dict of + Just (PdfArray arr) -> + Right $ concat [cs | ref <- parseRefsArray arr + , Right cs <- [parseColorSpaceEntry ref]] + Just (ObjRef x) -> + parseColorSpaceEntry x + Nothing -> Left (MissingKey "/Contents" "page") + where + xobjcs = findXObjectColorSpace dict objs + parseColorSpaceEntry ref = do + s <- rawStreamByRef sec objs ref + parseColorSpace (st {xcolorspaces=xobjcs}) s + + +-- find XObject + +findXObjectColorSpace d os = xobjColorSpaceMap (findXObject d os) os + +xobjColorSpaceMap dict objs = + [ xobjColorSpace r objs | (_, ObjRef r) <- M.toList dict ] + +findXObject dict objs = case findResourcesDict dict objs of + Just d -> case findObjFromDict d "/XObject" of + Just (PdfDict d) -> d + otherwise -> M.empty + Nothing -> M.empty + +xobjColorSpace :: Int -> PDFObjIndex -> T.Text +xobjColorSpace x objs = case findObjFromDictWithRef x "/ColorSpace" objs of + Just (PdfName cs) -> cs + otherwise -> T.empty + + +-- find root ref from Trailer Dictionary + +readDec' :: BS.ByteString -> PdfResult Int +readDec' bs = case readDec $ BS.unpack bs of + [(n,_)] -> Right n + _ -> Left (ParseError "invalid decimal" (BS.take 80 bs)) + +isPdfEofLine :: BS.ByteString -> Bool +isPdfEofLine line = + case BS.dropWhile isSpaceChar line of + rest | "%%EOF" `BS.isPrefixOf` rest -> + BS.all isSpaceChar (BS.drop 5 rest) + _ -> False + +getStartxrefOffset :: BS.ByteString -> PdfResult Int +getStartxrefOffset source = + let trimmed = BS.dropWhileEnd isSpaceChar source + numLine = case BS.breakEnd (== '\n') trimmed of + (_, n) | not (BS.null n) -> BS.dropWhile isSpaceChar n + _ -> trimmed + in readDec' $ BS.takeWhile (\c -> c >= '0' && c <= '9') numLine + +isSpaceChar :: Char -> Bool +isSpaceChar c = c `elem` (" \t\r\n" :: String) + +mergeXRefStm :: BS.ByteString -> Dict -> XREF -> PdfResult XREF +mergeXRefStm all dict xref = case findObjFromDict dict "/XRefStm" of + Just (PdfNumber n) -> + case findTrailerDictXREFStream $ BS.drop (truncate n) all of + Right (_, stm) -> Right $ M.union xref stm + Left err -> Left err + _ -> Right xref + +findTrailer :: BS.ByteString -> PdfResult Dict +findTrailer bs = case BS.breakEnd (== '\n') bs of + (source, eofLine) + | isPdfEofLine eofLine -> do + offset <- getStartxrefOffset source + (dict, _) <- findTrailerDictXREF $ BS.drop offset bs + return dict + | source == "" -> Left (BrokenXref "no %%EOF or startxref found") + | otherwise -> findTrailer (BS.init bs) + +findTrailer' :: BS.ByteString -> PdfResult (Dict, XREF) +findTrailer' bs = case BS.breakEnd (== '\n') bs of + (source, eofLine) + | isPdfEofLine eofLine -> do + offset <- getStartxrefOffset source + (dict, xref) <- findTrailerDictXREF $ BS.drop offset bs + xref' <- mergeXRefStm bs dict xref + case M.lookup "/Prev" dict of + Just (PdfNumber x) -> xrefs (truncate x) bs (dict, xref') + _ -> Right (dict, xref') + | source == "" -> Left (BrokenXref "no %%EOF or startxref found") + | otherwise -> findTrailer' (BS.init bs) + where + xrefs n all (dict, sofar) = do + (dict', xref) <- findTrailerDictXREF $ BS.drop n all + xref' <- mergeXRefStm all dict' xref + case M.lookup "/Prev" dict' of + Just (PdfNumber x) -> + xrefs (truncate x) all (dict, M.union sofar xref') + _ -> Right (dict, M.union sofar xref') + +findTrailerDictXREF :: BS.ByteString -> PdfResult (Dict, XREF) +findTrailerDictXREF xrefTrailer = + let trimmed = BS.dropWhile isPdfSpace xrefTrailer + in case BS.take 4 trimmed of + "xref" -> findTrailerDictXREFTable xrefTrailer + _ -> findTrailerDictXREFStream xrefTrailer + +findTrailerDictXREFTable :: BS.ByteString -> PdfResult (Dict, XREF) +findTrailerDictXREFTable xrefTrailer = case BS.breakSubstring "trailer" xrefTrailer of + (xref, trailer) | BS.null trailer -> + Left (BrokenXref ("no trailer keyword: " ++ show (BS.take 80 xrefTrailer))) + (xref, trailer) -> do + dict <- case parseOnly (pdfdictionary <* spaces) (BS.drop 7 trailer) of + Left err -> Left (ParseError ("trailer dictionary: " ++ show err) (BS.take 80 trailer)) + Right (PdfDict d) -> Right d + Right _ -> Left (ParseError "expected trailer dictionary" (BS.take 80 trailer)) + xrefMap <- parseXref xref + return (dict, xrefMap) + +findTrailerDictXREFStream :: BS.ByteString -> PdfResult (Dict, XREF) +findTrailerDictXREFStream blob = case parseOnly xrefStreamObject blob of + Left err -> + Left (BrokenXref ("xref stream: " ++ show err ++ ": " ++ show (BS.take 80 blob))) + Right (dict, s) -> do + xrefMap <- xrefStreamToMap dict s + return (dict, xrefMap) + +parseXrefBlob :: BS.ByteString -> PdfResult XREF +parseXrefBlob bs = + let trimmed = BS.dropWhile isPdfSpace bs + in case BS.take 4 trimmed of + "xref" -> parseXref bs + _ -> parseXrefStream bs + +parseXrefStream :: BS.ByteString -> PdfResult XREF +parseXrefStream bs = case parseOnly xrefStreamObject bs of + Left err -> + Left (BrokenXref ("xref stream: " ++ show err ++ ": " ++ show (BS.take 80 bs))) + Right (dict, s) -> xrefStreamToMap dict s + +xrefStreamObject :: Parser (Dict, BSL.ByteString) +xrefStreamObject = do + spaces + _ <- many1 digit + spaces + _ <- many1 digit + string " obj" + spaces + dictObj <- pdfdictionary + d <- case dictObj of + PdfDict d' -> return d' + _ -> fail "expected dictionary in xref stream object" + spaces + s <- readStreamByLength d + spaces + optional (string "endobj") + return (d, s) + +readStreamByLength :: Dict -> Parser BSL.ByteString +readStreamByLength dict = do + string "stream" + _ <- string "\r\n" <|> string "\n" <|> string "\r" + len <- case findObjFromDict dict "/Length" of + Just (PdfNumber n) -> return (truncate n) + _ -> fail "stream without /Length" + bs <- P.take len + optional (try $ string "\r\n" <|> string "\n" <|> string "\r") + return $ BSL.fromStrict bs + +xrefStreamToMap :: Dict -> BSL.ByteString -> PdfResult XREF +xrefStreamToMap dict s = do + ws <- wFields dict + sections <- indexSections dict + raw <- decodeStreamBytes dict s + entries <- xrefStreamEntries ws sections raw + return $ M.fromList + [ (n, entry) + | (n, typ, f2, f3) <- entries + , Just entry <- [xrefEntry typ f2 f3] + ] + where + xrefEntry 1 off _ = Just (InFile off) + xrefEntry 2 cnum idx = Just (InObjStm cnum idx) + xrefEntry 0 _ _ = Nothing + xrefEntry _ _ _ = Nothing + +wFields :: Dict -> PdfResult (Int, Int, Int) +wFields d = case findObjFromDict d "/W" of + Just (PdfArray [PdfNumber a, PdfNumber b, PdfNumber c]) -> + Right (truncate a, truncate b, truncate c) + _ -> Left (MissingKey "/W" "xref stream") + +indexSections :: Dict -> PdfResult [(Int, Int)] +indexSections d = case findObjFromDict d "/Index" of + Just (PdfArray arr) -> indexPairs arr + Nothing -> case findObjFromDict d "/Size" of + Just (PdfNumber s) -> Right [(0, truncate s)] + _ -> Left (MissingKey "/Size" "xref stream") + where + indexPairs (PdfNumber a : PdfNumber b : xs) = + ((truncate a, truncate b) :) <$> indexPairs xs + indexPairs [] = Right [] + indexPairs _ = Left (BrokenXref "malformed /Index in xref stream") + +xrefStreamEntries :: (Int, Int, Int) -> [(Int, Int)] -> BS.ByteString -> PdfResult [(Int, Int, Int, Int)] +xrefStreamEntries widths sections raw = + fst <$> foldM (parseSection widths) ([], raw) sections + where + parseSection (w0, w1, w2) (acc, bs) (start, count) = do + (ents, rest) <- parseN (w0, w1, w2) start count bs + return (acc ++ ents, rest) + parseN (w0, w1, w2) start count bs = + foldM (\(es, b) objNum -> do + (typ, b1) <- readField w0 b + (f2, b2) <- readField w1 b1 + (f3, b3) <- readField w2 b2 + return ((objNum, typ, f2, f3) : es, b3)) + ([], bs) [start .. start + count - 1] + +readField :: Int -> BS.ByteString -> PdfResult (Int, BS.ByteString) +readField 0 bs = Right (0, bs) +readField w bs + | BS.length bs < w = + Left (BrokenXref ("xref stream field truncated: need " + ++ show w ++ " bytes, have " ++ show (BS.length bs))) + | otherwise = Right (bytesToInt (BS.take w bs), BS.drop w bs) + +bytesToInt :: BS.ByteString -> Int +bytesToInt = BS.foldl' (\acc w -> acc * 256 + ord w) 0 + +parseXref :: BS.ByteString -> PdfResult XREF +parseXref xref = case parseOnly xrefParser xref of + Left err -> + Left (BrokenXref ("xref table: " ++ show err ++ ": " ++ show (BS.take 80 xref))) + Right xs -> do + entries <- mapM concatSubsections xs + return $ M.fromList $ map dropFN $ filter (\(_,_,inUse) -> inUse) $ concat entries + + where + xrefParser = do + string "xref" >> spaces + es <- (:) <$> subsections <*> many (try subsections) + return es + subsections = do + begin <- takeWhile1 isDigit <* spaces + num <- takeWhile1 isDigit <* spaces + count <- parseDec num + es <- replicateM count entries + beginNum <- parseDec begin + return (beginNum, count, es) + entries = do + offset <- P.take 10 <* spaces + _gennum <- P.take 5 <* spaces + status <- P.take 1 <* spaces + _ <- optional (string "\r\n" <|> string "\n" <|> string "\r") + off <- parseDec offset + inUse <- forn status + return (off, inUse) + parseDec bs = case readDec $ BS.unpack bs of + [(n,_)] -> return n + _ -> fail ("invalid decimal: " ++ show (BS.take 80 bs)) + forn "f" = return False + forn "n" = return True + forn s = fail $ "xref entry status neither f nor n: " ++ show s + + concatSubsections (objn, 0, []) = Right [] + concatSubsections (objn, 1, e:[]) = Right [(objn, fst e, snd e)] + concatSubsections (objn, 1, e:_) = + Left (BrokenXref ("xref subsection count mismatch: " ++ show e)) + concatSubsections (objn, i, e:es) = do + rest <- concatSubsections (objn+1, i-1, es) + return ((objn, fst e, snd e) : rest) + concatSubsections (_, _, e) = + Left (BrokenXref ("xref subsection malformed: " ++ show e)) + + dropFN (n, offset, fn) = (n, InFile offset) + +rootRef :: BS.ByteString -> PdfResult (Maybe Int) +rootRef bs = case findTrailer bs of + Right dict -> Right $ findRefs "/Root" dict + Left _ -> rootRefFromCRStream bs + +rootRefFromCRStream :: BS.ByteString -> PdfResult (Maybe Int) +rootRefFromCRStream bs = do + let ls = BS.lines bs + case reverse ls of + (_: numLine:_) -> do + offset <- readDec' (BS.takeWhile (\c -> c >= '0' && c <= '9') numLine) + objs <- findObjs' (BS.drop offset bs) + case objs of + ((_, crstrm):_) -> do + (crdict, _) <- findTrailerDictXREF crstrm + return $ findRefs "/Root" crdict + [] -> Right Nothing + _ -> Left (BrokenXref "cannot locate cross-reference stream offset") + +findRefs :: T.Text -> Dict -> Maybe Int +findRefs key dict = case M.lookup key dict of + Just (ObjRef x) -> Just x + _ -> Nothing + + +-- find Info + +infoRef :: BS.ByteString -> PdfResult Int +infoRef bs = case findTrailer bs of + Right dict -> case findRefs "/Info" dict of + Just r -> Right r + Nothing -> Left (ParseError "No ref for info" BS.empty) + Left err -> Left err + +-- expand PDF 1.5 Object Stream + +expandObjStm :: Maybe Security -> [PDFObj] -> PdfResult [PDFObj] +expandObjStm sec os = concat <$> traverse (objStm sec) os + +objStm :: Maybe Security -> PDFObj -> PdfResult [PDFObj] +objStm sec (n, obj) = case findDictOfType "/ObjStm" obj of + Nothing -> Right [(n,obj)] + Just _ -> do + streamBytes <- rawStream sec n obj + pdfObjStm n (BSL.toStrict streamBytes) + +refOffset :: Parser ([(Int, Int)], String) +refOffset = spaces *> ((,) + <$> many1 refPair + <*> many1 anyChar) + where + refPair = do + rStr <- many1 digit <* spaces + oStr <- many1 digit <* spaces + case (readDec rStr, readDec oStr) of + ([(r, "")], [(o, "")]) -> return (r, o) + _ -> fail "invalid object stream reference" + +pdfObjStm n s = + case parseOnly refOffset s of + Right (location, objstr) -> + mapM (\(r,o) -> (,) r <$> parseDict (BS.pack $ drop o objstr)) location + Left err -> + Left (ParseError ("Failed to parse Object Stream: " ++ show err) (BS.take 80 s)) + where parseDict s' = case parseOnly pdfdictionary s' of + Right obj -> Right [obj] + Left _ -> case parseOnly pdfarray s' of + Right obj -> Right [obj] + Left _ -> case parseOnly pdfletters s' of + Right obj -> Right [obj] + Left err -> + Left (ParseError ((show err) ++ ": Failed to parse obj around") + (BS.take 100 s')) + + +-- make fontmap from page's /Resources (see 3.7.2 of PDF Ref.) + +findFontEncoding d sec os = findEncoding (fontObjs d os) sec os + +findEncoding :: Dict -> Maybe Security -> PDFObjIndex -> Map T.Text Encoding +findEncoding dict sec objs = M.fromListWith (flip const) $ + [ (n, encoding sec r objs) | (n, ObjRef r) <- M.toList dict ] + +fontObjs :: Dict -> PDFObjIndex -> Dict +fontObjs dict objs = case findResourcesDict dict objs of + Just d -> case findObjFromDict d "/Font" of + Just (PdfDict d') -> d' + Just (ObjRef x) -> case findDictByRef x objs of + Just d' -> d' + _ -> M.empty + _ -> M.empty + Nothing -> M.empty + +findResourcesDict :: Dict -> PDFObjIndex -> Maybe Dict +findResourcesDict dict objs = case M.lookup "/Resources" dict of + Just (ObjRef x) -> findDictByRef x objs + Just (PdfDict d) -> Just d + _ -> Nothing + + +encoding :: Maybe Security -> Int -> PDFObjIndex -> Encoding +encoding sec x objs = + case findDictByRef x objs of + Just d -> encodingFromDict sec objs d + Nothing -> NullMap + +encodingFromDict :: Maybe Security -> PDFObjIndex -> Dict -> Encoding +encodingFromDict sec objs d = case subtype of + Just (PdfName "/Type0") -> case encField of + Just (PdfName "/Identity-H") -> case cidSysInfo descendantFonts of + (e:_) -> e + [] -> NullMap + Just (PdfName _) -> NullMap + _ -> NullMap + Just (PdfName "/Type1") -> case encField of + Just (ObjRef r) -> case findObjFromDictWithRef r "/Differences" objs of + Just (PdfArray arr) -> charDiff arr + _ -> NullMap + Just (PdfDict ed) -> case findObjFromDict ed "/Differences" of + Just (PdfArray arr) -> charDiff arr + _ -> NullMap + Just (PdfName "/MacRomanEncoding") -> NullMap + Just (PdfName "/MacExpertEncoding") -> NullMap + Just (PdfName "/WinAnsiEncoding") -> NullMap + Just (PdfName "/ZapfDingbats") -> WithCharSet "ZapfDingbats" + Just (PdfName "/Symbol") -> WithCharSet "Symbol" + _ -> case findObjFromDict (fontDescriptorFromDict d objs) "/FontFile3" of + Just (ObjRef fontfile) -> + case rawStreamByRef sec objs fontfile of + Right bs -> CFF.encoding $ BSL.toStrict bs + Left _ -> NullMap + _ -> case findObjFromDict (fontDescriptorFromDict d objs) "/FontFile" of + Just (ObjRef fontfile) -> + case rawStreamByRef sec objs fontfile of + Right bs -> Type1.encoding $ BSL.toStrict bs + Left _ -> NullMap + _ -> NullMap + Just (PdfName "/Type2") -> NullMap + Just (PdfName "/Type3") -> NullMap + _ -> NullMap + + where + subtype = M.lookup "/Subtype" d + encField = M.lookup "/Encoding" d + + descendantFonts :: [Obj] + descendantFonts = descendantFontObjsFromDict d objs + + cidSysInfo :: [Obj] -> [Encoding] + cidSysInfo [] = [] + cidSysInfo ((ObjRef r):rs) = cidSysInfo' r : cidSysInfo rs + cidSysInfo' dfr = case findObjFromDictWithRef dfr "/CIDSystemInfo" objs of + Just (PdfDict dict) -> getCIDSystemInfo dict + Just (ObjRef r) -> case findDictByRef r objs of + Just dict -> getCIDSystemInfo dict + _ -> WithCharSet T.empty + _ -> WithCharSet T.empty + + getCIDSystemInfo cidDict = + let registry = case findObjFromDict cidDict "/Registry" of + Just (PdfText r) -> r + _ -> T.empty + ordering = case findObjFromDict cidDict "/Ordering" of + Just (PdfText o) -> o + _ -> T.empty + cmap = registry `T.append` "-" `T.append` ordering + in if cmap == "Adobe-Japan1" + then CIDmap cmap + else WithCharSet T.empty + + +charDiff :: [Obj] -> Encoding +charDiff objs = Encoding $ M.fromListWith (flip const) $ charmap objs 0 + where charmap (PdfNumber x : PdfName n : xs) i = + if i < truncate x then + (chr $ truncate x, n) : (charmap xs $ incr x) + else + (chr $ i, n) : (charmap xs $ i+1) + charmap (PdfName n : xs) i = (chr i, n) : (charmap xs $ i+1) + charmap (_:xs) i = charmap xs i + charmap [] _ = [] + incr x = (truncate x) + 1 + + +findCMap :: Dict -> Maybe Security -> PDFObjIndex -> Map T.Text CMap +findCMap d sec objs = M.fromListWith (flip const) $ + [ (n, toUnicode sec r objs) | (n, ObjRef r) <- M.toList (fontObjs d objs) ] + +toUnicode :: Maybe Security -> Int -> PDFObjIndex -> CMap +toUnicode sec x objs = + case findDictByRef x objs of + Just d -> toUnicodeFromDict sec objs d + Nothing -> M.empty + +toUnicodeFromDict :: Maybe Security -> PDFObjIndex -> Dict -> CMap +toUnicodeFromDict sec objs d = + case findObjFromDict d "/ToUnicode" of + Just (ObjRef ref) -> + case rawStreamByRef sec objs ref of + Right s | BSL.null s -> noToUnicodeFromDict sec objs d + | otherwise -> parseCMap s + _ -> noToUnicodeFromDict sec objs d + _ -> noToUnicodeFromDict sec objs d + +noToUnicode :: Maybe Security -> Int -> PDFObjIndex -> CMap +noToUnicode sec x objs = + case findDictByRef x objs of + Just d -> noToUnicodeFromDict sec objs d + Nothing -> M.empty + +noToUnicodeFromDict :: Maybe Security -> PDFObjIndex -> Dict -> CMap +noToUnicodeFromDict sec objs d = + case firstDescendantFontDict d objs of + Nothing -> M.empty + Just cidDict -> + let fd = fontDescriptorFromDict cidDict objs + in case findObjFromDict fd "/FontFile2" of + Just (ObjRef fontfile) -> + case rawStreamByRef sec objs fontfile of + Right bs -> OpenType.cmap $ BSL.toStrict bs + Left _ -> M.empty + _ -> M.empty + + +fontInfo :: Maybe Security -> Int -> PDFObjIndex -> FontInfo +fontInfo sec x objs = + fontInfoFromDict sec objs (fromMaybe M.empty $ findDictByRef x objs) + +fontInfoFromDict :: Maybe Security -> PDFObjIndex -> Dict -> FontInfo +fontInfoFromDict sec objs d = + case M.lookup "/Subtype" d of + Just (PdfName "/Type0") -> type0FontInfoDict sec objs d + _ -> simpleFontInfoDict sec objs d + +simpleFontInfoDict :: Maybe Security -> PDFObjIndex -> Dict -> FontInfo +simpleFontInfoDict sec objs d = + let enc = encodingFromDict sec objs d + tuc = toUnicodeFromDict sec objs d + fd = fontDescriptorFromDict d objs + defaultW = case findObjFromDict fd "/MissingWidth" of + Just (PdfNumber w) -> w + _ -> 0 + firstChar = case findObjFromDict d "/FirstChar" of + Just (PdfNumber n) -> truncate n + _ -> 0 + widths = case findObjFromDict d "/Widths" of + Just wobj -> resolveObjArray wobj objs + _ -> [] + widthFn code = simpleWidthAt firstChar widths defaultW code + in FontInfo + { fiEncoding = enc + , fiToUnicode = tuc + , fiWidth = widthFn + , fiWidthV = const defaultVerticalW1 + , fiWMode = 0 + , fiBytesPerCode = 1 + , fiDefaultWidth = defaultW + } + +type0FontInfoDict :: Maybe Security -> PDFObjIndex -> Dict -> FontInfo +type0FontInfoDict sec objs d = + let enc = encodingFromDict sec objs d + tuc = toUnicodeFromDict sec objs d + cidDict = firstDescendantFontDict d objs + defaultW = case cidDict >>= \cd -> findObjFromDict cd "/DW" of + Just (PdfNumber w) -> w + _ -> 1000 + widthMap = case cidDict >>= \cd -> findObjFromDict cd "/W" of + Just wobj -> parseCIDWidths (resolveObjArray wobj objs) + _ -> M.empty + (_, w1Default) = dw2Defaults cidDict + widthVMap = case cidDict >>= \cd -> findObjFromDict cd "/W2" of + Just wobj -> parseCIDVerticalWidths (resolveObjArray wobj objs) + _ -> M.empty + wmode = wmodeFromEncoding (findObjFromDict d "/Encoding") + widthFn cid = M.findWithDefault defaultW cid widthMap + widthVFn cid = M.findWithDefault w1Default cid widthVMap + in FontInfo + { fiEncoding = enc + , fiToUnicode = tuc + , fiWidth = widthFn + , fiWidthV = widthVFn + , fiWMode = wmode + , fiBytesPerCode = 2 + , fiDefaultWidth = defaultW + } + +defaultVerticalW1 :: Double +defaultVerticalW1 = -1000 + +fontDescriptorFor :: Int -> PDFObjIndex -> Dict +fontDescriptorFor fdr objs = case findDictByRef fdr objs of + Just d -> fontDescriptorFromDict d objs + Nothing -> M.empty + +fontDescriptorFromDict :: Dict -> PDFObjIndex -> Dict +fontDescriptorFromDict d _objs = case findObjFromDict d "/FontDescriptor" of + Just (ObjRef r) -> fromMaybe M.empty $ findDictByRef r _objs + Just (PdfDict fd) -> fd + _ -> M.empty + +resolveObjArray :: Obj -> PDFObjIndex -> [Obj] +resolveObjArray obj objs = case obj of + ObjRef r -> case findObjsByRef r objs of + Just [PdfArray arr] -> arr + Just os -> maybe [] id (findFirstArray os) + Nothing -> [] + PdfArray arr -> arr + _ -> [] + +findFirstArray :: [Obj] -> Maybe [Obj] +findFirstArray os = case find isArrayObj os of + Just (PdfArray arr) -> Just arr + _ -> Nothing + where + isArrayObj (PdfArray _) = True + isArrayObj _ = False + +firstDescendantFont :: Int -> PDFObjIndex -> Maybe Dict +firstDescendantFont fontRef objs = + case findDictByRef fontRef objs of + Just d -> firstDescendantFontDict d objs + Nothing -> Nothing + +firstDescendantFontDict :: Dict -> PDFObjIndex -> Maybe Dict +firstDescendantFontDict d objs = + case descendantFontObjsFromDict d objs of + (df:_) -> cidFontDict df objs + _ -> Nothing + +descendantFontObjs :: Int -> PDFObjIndex -> [Obj] +descendantFontObjs fontRef objs = + case findDictByRef fontRef objs of + Just d -> descendantFontObjsFromDict d objs + Nothing -> [] + +descendantFontObjsFromDict :: Dict -> PDFObjIndex -> [Obj] +descendantFontObjsFromDict d objs = + case findObjFromDict d "/DescendantFonts" of + Just (PdfArray dfrs) -> dfrs + Just (ObjRef r) -> case findObjsByRef r objs of + Just (PdfArray dfrs : _) -> dfrs + Just os | isDescendantFontObj os -> [ObjRef r] + Just os -> fromMaybe [] (findFirstArray os) + Nothing -> [] + _ -> [] + where + isDescendantFontObj os = case findDict os of + Just cd -> case M.lookup "/Subtype" cd of + Just (PdfName "/CIDFontType0") -> True + Just (PdfName "/CIDFontType2") -> True + _ -> False + Nothing -> False + +cidFontDict :: Obj -> PDFObjIndex -> Maybe Dict +cidFontDict df objs = case df of + ObjRef r -> findDictByRef r objs + PdfDict d -> Just d + _ -> Nothing + +dw2Defaults :: Maybe Dict -> (Double, Double) +dw2Defaults Nothing = (880, defaultVerticalW1) +dw2Defaults (Just d) = case findObjFromDict d "/DW2" of + Just (PdfArray [PdfNumber vy, PdfNumber w1]) -> (vy, w1) + _ -> (880, defaultVerticalW1) + +wmodeFromEncoding :: Maybe Obj -> Int +wmodeFromEncoding (Just (PdfName n)) | "-V" `T.isSuffixOf` n = 1 +wmodeFromEncoding _ = 0 + +simpleWidthAt :: Int -> [Obj] -> Double -> Int -> Double +simpleWidthAt firstChar widths defaultWidth code = + let idx = code - firstChar + in if idx >= 0 && idx < length widths + then case widths !! idx of + PdfNumber w -> w + _ -> defaultWidth + else defaultWidth + +parseCIDWidths :: [Obj] -> Map Int Double +parseCIDWidths = foldCIDMetrics widthFromObj M.empty + +parseCIDVerticalWidths :: [Obj] -> Map Int Double +parseCIDVerticalWidths = foldCIDMetrics verticalW1FromObj M.empty + +foldCIDMetrics :: (Obj -> Maybe Double) -> Map Int Double -> [Obj] -> Map Int Double +foldCIDMetrics metricFn = go + where + go m [] = m + go m (PdfNumber c : PdfArray ws : rest) = + let m' = foldl' insertAt m (zip [0..] ws) + insertAt acc (i, w) = case metricFn w of + Just n -> M.insert (truncate c + i) n acc + Nothing -> acc + in go m' rest + go m (PdfNumber cFirst : PdfNumber cLast : w : rest) = + case metricFn w of + Just n -> + let m' = foldl' (\acc cid -> M.insert cid n acc) m [truncate cFirst .. truncate cLast] + in go m' rest + Nothing -> go m rest + go m (_:rest) = go m rest + +widthFromObj :: Obj -> Maybe Double +widthFromObj (PdfNumber w) = Just w +widthFromObj _ = Nothing + +verticalW1FromObj :: Obj -> Maybe Double +verticalW1FromObj (PdfArray [PdfNumber _vx, PdfNumber vy]) = Just vy +verticalW1FromObj (PdfNumber w) = Just w +verticalW1FromObj _ = Nothing diff --git a/src/PDF/Encrypt.hs b/src/PDF/Encrypt.hs new file mode 100644 --- /dev/null +++ b/src/PDF/Encrypt.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module PDF.Encrypt + ( Security + , securityFromEncryptDict + , decryptString + , decryptStream + ) where + +import PDF.Definition + +import qualified Data.Text as T +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Bits (shiftL, shiftR, xor, (.&.)) +import Data.List (foldl') +import qualified Data.Map as M +import Control.Applicative ((<|>)) +import Data.Word (Word8, Word32) +import Numeric (readHex) + +import Crypto.Hash (hash, MD5(..), Digest) +import Crypto.Cipher.AES (AES128) +import Crypto.Cipher.Types (BlockCipher, cipherInit, ecbDecrypt) +import Crypto.Error (onCryptoFailure) +import Data.ByteArray (convert) + +padString :: BS.ByteString +padString = BS.pack + [ 0x28, 0xBF, 0x4E, 0x5E, 0x4E, 0x75, 0x8A, 0x41 + , 0x64, 0x00, 0x4E, 0x56, 0xFF, 0xFA, 0x01, 0x08 + , 0x2E, 0x2E, 0x00, 0xB6, 0xD0, 0x68, 0x3E, 0x80 + , 0x2F, 0x0C, 0xA9, 0xFE, 0x64, 0x53, 0x69, 0x7A + ] + +data Security = Security + { secRevision :: Int + , secVersion :: Int + , secKey :: BS.ByteString + , secKeyLength :: Int + , secAES :: Bool + } deriving Show + +securityFromEncryptDict :: Dict -> Dict -> Maybe String -> Maybe Security +securityFromEncryptDict encDict trailer password = do + r <- dictInt encDict "/R" + v <- dictInt encDict "/V" + o <- dictBytes encDict "/O" + u <- dictBytes encDict "/U" + p <- dictInt encDict "/P" + fileId <- dictFirstId trailer + let pw = maybe BS.empty BSC.pack password + aes = v >= 4 || usesAES encDict + metaEnc = encryptMetadata encDict + keyLen = case dictInt encDict "/Length" of + Just n -> max 5 (n `div` 8) + Nothing -> if r >= 3 || v >= 2 then 16 else 5 + key <- authenticateFileKey pw o u p fileId r v aes metaEnc keyLen + return $ Security r v key keyLen aes + +-- | Try owner password first (Algorithm 7), then user password (Algorithm 6). +authenticateFileKey :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Int -> BS.ByteString -> Int -> Int -> Bool -> Bool -> Int -> Maybe BS.ByteString +authenticateFileKey pw o u p fileId r v aes metaEnc keyLen = + ownerPasswordKey pw o u p fileId r aes metaEnc keyLen + <|> userPasswordKey pw o u p fileId r aes metaEnc keyLen + +userPasswordKey :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Int -> BS.ByteString -> Int -> Bool -> Bool -> Int -> Maybe BS.ByteString +userPasswordKey pw o u p fileId r aes metaEnc keyLen = + let key = fileKeyFromPassword pw o p fileId r aes metaEnc keyLen + in if verifyUserPassword r fileId key u then Just key else Nothing + +ownerPasswordKey :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Int -> BS.ByteString -> Int -> Bool -> Bool -> Int -> Maybe BS.ByteString +ownerPasswordKey ownerPw o u p fileId r aes metaEnc keyLen = + let oKey = computeOwnerValueKey ownerPw r keyLen + userPw = decryptOToUserPassword oKey r o + in userPasswordKey userPw o u p fileId r aes metaEnc keyLen + +fileKeyFromPassword :: BS.ByteString -> BS.ByteString -> Int -> BS.ByteString -> Int -> Bool -> Bool -> Int -> BS.ByteString +fileKeyFromPassword pw o p fileId r aes metaEnc keyLen = + if r >= 4 || aes + then computeFileKeyAES pw o p fileId r metaEnc + else computeFileKey pw o p fileId r keyLen metaEnc + +padPassword :: BS.ByteString -> BS.ByteString +padPassword pw = BS.take 32 $ pw `BS.append` padString + +-- Algorithm 3 (a–d): RC4 key from owner password for decrypting /O. +computeOwnerValueKey :: BS.ByteString -> Int -> Int -> BS.ByteString +computeOwnerValueKey ownerPassword r keyLen = + let hashed = iterate md5 (md5 (padPassword ownerPassword)) !! (if r >= 3 then 50 else 0) + in BS.take keyLen hashed + +-- Algorithm 7 (b): recover padded user password from /O. +decryptOToUserPassword :: BS.ByteString -> Int -> BS.ByteString -> BS.ByteString +decryptOToUserPassword oKey r o + | r <= 2 = rc4Decrypt oKey o + | otherwise = foldl' (\ct m -> rc4Decrypt (xorKey oKey m) ct) o [19,18..0] + +usesAES :: Dict -> Bool +usesAES d = case dictLookup d "/CF" of + Just (PdfDict cf) -> case dictLookup cf "/StdCF" of + Just (PdfDict std) -> case dictLookup std "/CFM" of + Just (PdfName "/AESV2") -> True + Just (PdfName "/AESV3") -> True + _ -> False + _ -> False + _ -> False + +encryptMetadata :: Dict -> Bool +encryptMetadata d = case dictLookup d "/EncryptMetadata" of + Just (PdfBool False) -> False + _ -> True + +dictLookup :: Dict -> T.Text -> Maybe Obj +dictLookup d name = M.lookup name d + +dictInt :: Dict -> T.Text -> Maybe Int +dictInt d name = case dictLookup d name of + Just (PdfNumber n) -> Just (truncate n) + _ -> Nothing + +dictBytes :: Dict -> T.Text -> Maybe BS.ByteString +dictBytes d name = case dictLookup d name of + Just (PdfText s) -> Just (BSC.pack (T.unpack s)) + Just (PdfHex h) -> hexToBytes h + _ -> Nothing + +dictFirstId :: Dict -> Maybe BS.ByteString +dictFirstId d = case dictLookup d "/ID" of + Just (PdfArray (entry:_)) -> idEntryBytes entry + _ -> Nothing + +idEntryBytes :: Obj -> Maybe BS.ByteString +idEntryBytes (PdfHex h) = hexToBytes h +idEntryBytes (PdfText s) = hexToBytes s <|> Just (BSC.pack (T.unpack s)) +idEntryBytes _ = Nothing + +hexToBytes :: T.Text -> Maybe BS.ByteString +hexToBytes h + | T.null h = Just BS.empty + | otherwise = Just $ BS.pack $ map (fromIntegral . fst . head . readHex) (pairs (T.unpack h)) + where + pairs [] = [] + pairs s = take 2 s : pairs (drop 2 s) + +md5 :: BS.ByteString -> BS.ByteString +md5 bs = convert (hash bs :: Digest MD5) + +computeFileKey :: BS.ByteString -> BS.ByteString -> Int -> BS.ByteString -> Int -> Int -> Bool -> BS.ByteString +computeFileKey password o p fileId r keyLen metaEnc = + let padded = BS.take 32 $ password `BS.append` padString + suffix = if r >= 4 && not metaEnc then BS.pack [0xFF, 0xFF, 0xFF, 0xFF] else BS.empty + base = padded `BS.append` o `BS.append` int32LE p `BS.append` fileId `BS.append` suffix + hashed = iterate (\h -> md5 (BS.take keyLen h)) (md5 base) !! (if r >= 3 then 50 else 0) + in BS.take keyLen hashed + +computeFileKeyAES :: BS.ByteString -> BS.ByteString -> Int -> BS.ByteString -> Int -> Bool -> BS.ByteString +computeFileKeyAES password o p fileId r metaEnc = + let padded = BS.take 32 $ password `BS.append` padString + suffix = if r >= 4 && not metaEnc then BS.pack [0xFF, 0xFF, 0xFF, 0xFF] else BS.empty + base = padded `BS.append` o `BS.append` int32LE p `BS.append` fileId `BS.append` suffix + hashed = (!! 50) $ iterate (\h -> md5 (BS.take 16 h)) (md5 base) + in BS.take 16 hashed + +int32LE :: Int -> BS.ByteString +int32LE n = + let w = fromIntegral n :: Word32 + in BS.pack + [ fromIntegral (w .&. 0xff) + , fromIntegral ((w `shiftR` 8) .&. 0xff) + , fromIntegral ((w `shiftR` 16) .&. 0xff) + , fromIntegral ((w `shiftR` 24) .&. 0xff) + ] + +verifyUserPassword :: Int -> BS.ByteString -> BS.ByteString -> BS.ByteString -> Bool +verifyUserPassword r fileId key u = + let computed = computeU r fileId key + in if r >= 3 + then BS.take 16 computed == BS.take 16 u + else BS.take 32 computed == BS.take 32 u + +computeU :: Int -> BS.ByteString -> BS.ByteString -> BS.ByteString +computeU r fileId key + | r <= 2 = rc4Decrypt key padString + | otherwise = + let hashed = md5 (padString `BS.append` fileId) + encrypted = rc4Decrypt key hashed + finished = foldl' (\ct i -> rc4Decrypt (xorKey key i) ct) encrypted [1..19] + in BS.append (BS.take 16 finished) (BS.replicate 16 0) + +xorKey :: BS.ByteString -> Int -> BS.ByteString +xorKey key i = BS.pack $ map (xor (fromIntegral i)) (BS.unpack key) + +saltAES :: BS.ByteString +saltAES = BSC.pack "sAlT" + +objectKey :: Security -> Int -> Int -> BS.ByteString +objectKey sec objNum genNum = + let n = secKeyLength sec + ext = BS.take n (secKey sec) + `BS.append` int24LE objNum + `BS.append` int16LE genNum + in if secAES sec + then BS.take (min (n + 5) 16) (md5 (ext `BS.append` saltAES)) + else BS.take (min (n + 5) 16) (md5 ext) + +int24LE :: Int -> BS.ByteString +int24LE n = + let w = fromIntegral n :: Word32 + in BS.pack + [ fromIntegral (w .&. 0xff) + , fromIntegral ((w `shiftR` 8) .&. 0xff) + , fromIntegral ((w `shiftR` 16) .&. 0xff) + ] + +int16LE :: Int -> BS.ByteString +int16LE n = + let w = fromIntegral n :: Word32 + in BS.pack + [ fromIntegral (w .&. 0xff) + , fromIntegral ((w `shiftR` 8) .&. 0xff) + ] + +rc4Decrypt :: BS.ByteString -> BS.ByteString -> BS.ByteString +rc4Decrypt key ciphertext = + let ks = rc4KeyStream key (BS.length ciphertext) + in BS.pack $ zipWith xor (BS.unpack ciphertext) ks + +rc4DecryptRev3 :: Int -> BS.ByteString -> BS.ByteString -> BS.ByteString +rc4DecryptRev3 keyLen key ciphertext = + foldl' (\ct m -> rc4Decrypt (BS.take keyLen (md5 (key `BS.append` BS.pack [fromIntegral m]))) ct) + ciphertext + [19,18..0] + +rc4KeyStream :: BS.ByteString -> Int -> [Word8] +rc4KeyStream key nbytes = + let keyInts = map fromIntegral (BS.unpack key) :: [Int] + state = ksaInit keyInts + in map fromIntegral $ take nbytes $ prga state + where + ksaInit k' = + let len = length k' + step (st, j) i = + let j' = (j + st !! i + k' !! (i `mod` len)) `mod` 256 + st' = swap st i j' + in (st', j') + in fst $ foldl' step ([0..255], 0) [0..255] + prga st = reverse $ go st 0 0 [] + where go sbox i j out + | length out >= nbytes = out + | otherwise = + let i' = (i + 1) `mod` 256 + j' = (j + sbox !! i') `mod` 256 + s' = swap sbox i' j' + byte = s' !! ((s' !! i' + s' !! j') `mod` 256) + in go s' i' j' (byte:out) + swap s i j = + [ if x == i then s !! j else if x == j then s !! i else v + | (x, v) <- zip [0..] s ] + +decryptString :: Maybe Security -> Int -> Int -> BS.ByteString -> BS.ByteString +decryptString Nothing _ _ bs = bs +decryptString (Just sec) objNum genNum bs = + let ok = objectKey sec objNum genNum + in case () of + _ | secAES sec -> stripPkcs7 $ aesDecrypt ok bs + _ -> rc4Decrypt ok bs + +decryptStream :: Maybe Security -> Int -> Int -> BS.ByteString -> BS.ByteString +decryptStream Nothing _ _ bs = bs +decryptStream (Just sec) objNum genNum bs = + let ok = objectKey sec objNum genNum + in case () of + _ | secAES sec -> stripPkcs7 $ aesDecrypt ok bs + _ -> rc4Decrypt ok bs + +stripPkcs7 :: BS.ByteString -> BS.ByteString +stripPkcs7 bs + | BS.null bs = bs + | otherwise = + let pad = fromIntegral (BS.last bs) + len = BS.length bs + in if pad >= 1 && pad <= 16 && len >= pad + && BS.all (== BS.last bs) (BS.drop (len - pad) bs) + then BS.take (len - pad) bs + else bs + +aesDecrypt :: BS.ByteString -> BS.ByteString -> BS.ByteString +aesDecrypt _ bs | BS.length bs < 16 = bs +aesDecrypt key bs = + onCryptoFailure (const bs) id $ + cipherInit key >>= \cipher -> + let iv = BS.take 16 bs + body = BS.drop 16 bs + in return $ cbcDecrypt iv cipher body + +cbcDecrypt :: BS.ByteString -> AES128 -> BS.ByteString -> BS.ByteString +cbcDecrypt _ _ bs | BS.null bs = BS.empty +cbcDecrypt prev cipher bs = + let (block, rest) = BS.splitAt 16 bs + plain = ecbDecrypt cipher block + out = BS.pack $ zipWith xor (BS.unpack plain) (BS.unpack prev) + in if BS.length block < 16 + then BS.empty + else out `BS.append` cbcDecrypt block cipher rest diff --git a/src/PDF/Error.hs b/src/PDF/Error.hs new file mode 100644 --- /dev/null +++ b/src/PDF/Error.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : PDF.Error +Description : Error and warning types for hpdft +License : MIT +Maintainer : k16.shikano@gmail.com + +Total-function error model for the 0.3 API. Parsing and extraction +functions return 'PdfResult' instead of calling 'error', so that a +broken PDF yields a diagnosis (and possibly partial output) rather +than a crash. + +Migration plan (tracked per module): + +* Phase A1: xref\/trailer\/object loading ('PDF.DocumentStructure', 'PDF.Object') +* Phase A2: content streams and fonts ('PDF.ContentStream', 'PDF.Cmap', 'PDF.CFF', ...) +* Phase A3: IO layer and CLI ('PDF.PDFIO', @hpdft.hs@) + +@example +import PDF.Document (openDocument) +import PDF.Error (PdfError(..), PdfResult) + +handle :: IO (PdfResult Text) -> IO () +handle io = do + result <- io + case result of + Left (MissingObject n) -> putStrLn $ "object " ++ show n ++ " missing" + Left err -> print err + Right txt -> putStr txt +-} + +module PDF.Error + ( PdfError(..) + , PdfResult + , PdfWarning(..) + , renderPdfWarning + , note + ) where + +import qualified Data.ByteString.Char8 as BS + +-- | Structured errors. Constructors carry enough context to locate +-- the problem in the file without a debugger. +data PdfError + = ParseError String BS.ByteString + -- ^ Parser failure: message and a short excerpt of the input. + | BrokenXref String + -- ^ Cross-reference table\/stream could not be interpreted. + | MissingObject Int + -- ^ An object referenced as @n 0 R@ is not present. + | MissingKey String String + -- ^ Required dictionary key is absent: key name and context. + | UnsupportedFeature String + -- ^ Valid PDF that hpdft cannot handle yet (filter, encoding, ...). + | DecryptionError String + -- ^ Bad password, unsupported handler, or malformed \/Encrypt. + | FontError Int String + -- ^ Font-related failure: object number and description. + deriving (Show, Eq) + +-- | Result type for hpdft parsing and extraction. @Left@ carries a 'PdfError'; +-- @Right@ carries success. Compose with do-notation or '>>='. +type PdfResult a = Either PdfError a + +-- | Non-fatal diagnoses. Extraction continues; the caller may log these. +data PdfWarning + = UnknownOperator String + -- ^ Content-stream operator hpdft does not interpret. + | MissingToUnicode Int + -- ^ Font without usable \/ToUnicode; output may be garbled. + | SubstitutedEncoding Int String + -- ^ Fallback encoding used for a font. + | UnmappedCid Int + -- ^ CID not found in Adobe-Japan1-6; bracket placeholder emitted. + deriving (Show, Eq) + +renderPdfWarning :: PdfWarning -> String +renderPdfWarning (UnknownOperator op) = "unknown content-stream operator: " ++ op +renderPdfWarning (MissingToUnicode n) = + "font object " ++ show n ++ " has no usable /ToUnicode map" +renderPdfWarning (SubstitutedEncoding n enc) = + "font object " ++ show n ++ ": using fallback encoding " ++ enc +renderPdfWarning (UnmappedCid cid) = + "unmapped CID " ++ show cid ++ " (Adobe-Japan1-6)" + +-- | Annotate a 'Maybe' with an error. +note :: PdfError -> Maybe a -> PdfResult a +note e Nothing = Left e +note _ (Just a) = Right a diff --git a/src/PDF/FormExtract.hs b/src/PDF/FormExtract.hs new file mode 100644 --- /dev/null +++ b/src/PDF/FormExtract.hs @@ -0,0 +1,442 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : PDF.FormExtract +Description : Form XObject extraction to standalone PDF files (0.4.5) +License : MIT + +Extracts a named Form XObject from a page (including nested resources) +and writes a minimal single-page PDF that draws the form as vector content. + +@example +import PDF.FormExtract (pageFormNames, extractFormPdf) + +names <- pageFormNames doc 1 +pdfBytes <- extractFormPdf doc 1 "Fm42" +-} +module PDF.FormExtract + ( pageFormNames + , extractFormPdf + , extractFormToFile + ) where + +import PDF.Definition +import PDF.Document (Document(..)) +import PDF.DocumentStructure + ( findDict + , findDictByRef + , findObjsByRef + , findResourcesDict + ) +import PDF.Error (PdfError(..), PdfResult) +import PDF.Page (pageRefAt) + +import Data.Char (chr, isAscii, isHexDigit, ord) +import Data.List (find, sort, sortOn, nub) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import Text.Printf (printf) + +import Data.Text.Encoding (encodeUtf16BE) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T + +pdfHeader :: BS.ByteString +pdfHeader = BSC.pack "%PDF-1.5\n%\xc2\xb5\xc2\xb6\n" + +-- | Top-level Form XObject names on a page (page /Resources /XObject only, inherited). +-- Nested forms inside a Form are not listed. +pageFormNames :: Document -> Int -> PdfResult [T.Text] +pageFormNames doc pageNum = do + pref <- pageRefAt doc pageNum + xobj <- pageXObjectDict doc pref + let objs = docObjs doc + return $ sort $ map stripNameSlash $ filter (isFormName objs xobj) (M.keys xobj) + +extractFormPdf :: Document -> Int -> T.Text -> PdfResult BS.ByteString +extractFormPdf doc pageNum name = do + pref <- pageRefAt doc pageNum + formRef <- findFormRef doc pref name + formDict <- formDictAt doc formRef + bbox <- formBBox formDict + matrix <- formMatrixArray formDict + let formKey = formNameKey name + index = docObjs doc + copiedRefs <- transitiveClosure formRef index + let renum = renumberMap copiedRefs + formNewRef = renum M.! formRef + pageContent = pageDrawStream formKey matrix + wrapper = + [ (1, catalogBody) + , (2, pagesBody) + , (3, pageBody bbox formKey formNewRef) + , (4, contentStreamBody pageContent) + ] + copied = + [ (renum M.! oldRef, serializeCopiedObject oldRef index renum) + | oldRef <- copiedRefs + ] + allObjs = wrapper ++ copied + (body, offsets) = buildBody allObjs + xrefPos = BS.length body + maxObj = maximum (map fst allObjs) + size = maxObj + 1 + return $ + body + <> xrefTable offsets size + <> trailerPart size xrefPos + +extractFormToFile :: Document -> Int -> T.Text -> FilePath -> IO (PdfResult FilePath) +extractFormToFile doc pageNum name outDir = + createDirectoryIfMissing True outDir >> go + where + go = case extractFormPdf doc pageNum name of + Left err -> return (Left err) + Right bytes -> do + let path = outDir (T.unpack (stripNameSlash name) ++ ".pdf") + BS.writeFile path bytes + return (Right path) + +-- | Page resources with inheritance (same walk as 'PDF.Interpret.pageResourcesInherited'). +pageResourcesInherited :: Dict -> PDFObjIndex -> Maybe Dict +pageResourcesInherited dict objs = + case findResourcesDict dict objs of + Just r -> Just r + Nothing -> + case M.lookup "/Parent" dict of + Just (ObjRef pref) -> + case findDictByRef pref objs of + Just parent -> pageResourcesInherited parent objs + Nothing -> Nothing + _ -> Nothing + +pageXObjectDict :: Document -> Int -> PdfResult (M.Map T.Text Obj) +pageXObjectDict doc pageRef = do + pageDict <- case findObjsByRef pageRef (docObjs doc) of + Just os -> case findDictOfTypePage os of + Just d -> Right d + Nothing -> Left (MissingKey "/Type" ("page " ++ show pageRef)) + Nothing -> Left (MissingObject pageRef) + case pageResourcesInherited pageDict (docObjs doc) of + Nothing -> Right M.empty + Just res -> xobjectEntries res (docObjs doc) + +findDictOfTypePage :: [Obj] -> Maybe Dict +findDictOfTypePage os = findDict os + +xobjectEntries :: Dict -> PDFObjIndex -> PdfResult (M.Map T.Text Obj) +xobjectEntries res objs = case M.lookup "/XObject" res of + Nothing -> Right M.empty + Just (PdfDict xd) -> Right xd + Just (ObjRef r) -> + case findDictByRef r objs of + Just xd -> Right xd + Nothing -> Left (MissingObject r) + Just _ -> Left (UnsupportedFeature "invalid /XObject entry on page") + +isFormName :: PDFObjIndex -> M.Map T.Text Obj -> T.Text -> Bool +isFormName objs xobj name = + case M.lookup name xobj of + Just (ObjRef r) -> isFormObject objs r + _ -> False + +findFormRef :: Document -> Int -> T.Text -> PdfResult Int +findFormRef doc pageRef name = do + xobj <- pageXObjectDict doc pageRef + let key = formNameKey name + case M.lookup key xobj of + Nothing -> + Left (MissingKey (T.unpack key) ("page " ++ show pageRef ++ " XObject dictionary")) + Just (ObjRef r) -> + if isFormObject (docObjs doc) r + then Right r + else Left (UnsupportedFeature (T.unpack key ++ " is not a Form XObject")) + Just _ -> + Left (UnsupportedFeature (T.unpack key ++ " is not an indirect Form XObject")) + +isFormObject :: PDFObjIndex -> Int -> Bool +isFormObject objs ref = + case findDictByRef ref objs of + Just d -> M.lookup "/Subtype" d == Just (PdfName "/Form") + Nothing -> False + +formDictAt :: Document -> Int -> PdfResult Dict +formDictAt doc ref = + case findDictByRef ref (docObjs doc) of + Just d -> Right d + Nothing -> Left (MissingObject ref) + +formBBox :: Dict -> PdfResult [Double] +formBBox d = case M.lookup "/BBox" d of + Just (PdfArray nums) -> parseBBox nums + Nothing -> Left (MissingKey "/BBox" "Form XObject") + Just _ -> Left (UnsupportedFeature "Form /BBox must be an array of four numbers") + +parseBBox :: [Obj] -> PdfResult [Double] +parseBBox nums = + case map asNumber nums of + [Just a, Just b, Just c, Just d'] -> Right [a, b, c, d'] + _ -> Left (UnsupportedFeature "Form /BBox must be four numbers") + +asNumber :: Obj -> Maybe Double +asNumber (PdfNumber n) = Just n +asNumber _ = Nothing + +formMatrixArray :: Dict -> PdfResult (Maybe [Double]) +formMatrixArray d = case M.lookup "/Matrix" d of + Nothing -> Right Nothing + Just (PdfArray nums) -> + case map asNumber nums of + [Just a, Just b, Just c, Just d', Just e, Just f] -> Right (Just [a, b, c, d', e, f]) + _ -> Left (UnsupportedFeature "Form /Matrix must be six numbers") + Just _ -> Left (UnsupportedFeature "Form /Matrix must be an array") + +formNameKey :: T.Text -> T.Text +formNameKey n = + if "/" `T.isPrefixOf` n then n else "/" `T.append` n + +stripNameSlash :: T.Text -> T.Text +stripNameSlash n = + if "/" `T.isPrefixOf` n then T.drop 1 n else n + +transitiveClosure :: Int -> PDFObjIndex -> PdfResult [Int] +transitiveClosure start objs = go [start] S.empty [] + where + go [] _ acc = Right (reverse acc) + go (r : rs) seen acc + | r `S.member` seen = go rs seen acc + | otherwise = + case findObjsByRef r objs of + Nothing -> Left (MissingObject r) + Just os -> + let refs = nub (collectObjRefs os) + unseen = filter (not . (`S.member` seen)) refs + in go (rs ++ unseen) (S.insert r seen) (r : acc) + +collectObjRefs :: [Obj] -> [Int] +collectObjRefs = concatMap refsInObj + +refsInObj :: Obj -> [Int] +refsInObj (PdfDict d) = concatMap refsInObj (M.elems d) +refsInObj (PdfArray a) = concatMap refsInObj a +refsInObj (ObjRef r) = [r] +refsInObj _ = [] + +renumberMap :: [Int] -> M.Map Int Int +renumberMap copied = M.fromList (zip copied [5 ..]) + +rewriteObj :: M.Map Int Int -> Obj -> Obj +rewriteObj mp = go + where + go (PdfDict d) = PdfDict (M.map go d) + go (PdfArray a) = PdfArray (map go a) + go r@(ObjRef old) = maybe r ObjRef (M.lookup old mp) + go o = o + +catalogBody :: BS.ByteString +catalogBody = BSC.pack "<< /Type /Catalog /Pages 2 0 R >>" + +pagesBody :: BS.ByteString +pagesBody = BSC.pack "<< /Type /Pages /Kids [3 0 R] /Count 1 >>" + +pageBody :: [Double] -> T.Text -> Int -> BS.ByteString +pageBody bbox formKey formNewRef = + BSC.pack $ + unwords + [ "<< /Type /Page /Parent 2 0 R" + , "/MediaBox [" ++ showBBox bbox ++ "]" + , "/Resources << /XObject <<" + , BSC.unpack (serializeName formKey) + , show formNewRef ++ " 0 R >> >>" + , "/Contents 4 0 R >>" + ] + +showBBox :: [Double] -> String +showBBox = unwords . map showPdfNumber + +pageDrawStream :: T.Text -> Maybe [Double] -> BS.ByteString +pageDrawStream formKey mmat = + let cmOp = + case mmat of + Nothing -> "1 0 0 1 0 0 cm" + Just [a, b, c, d, e, f] + | isIdentity [a, b, c, d, e, f] -> "1 0 0 1 0 0 cm" + | otherwise -> + unwords (map showPdfNumber [a, b, c, d, e, f]) ++ " cm" + _ -> "1 0 0 1 0 0 cm" + ops = + BSC.concat + [ "q\n" + , BSC.pack cmOp + , "\n" + , serializeName formKey + , " Do\nQ\n" + ] + in ops + +isIdentity :: [Double] -> Bool +isIdentity [a, b, c, d, e, f] = + near a 1 && near b 0 && near c 0 && near d 1 && near e 0 && near f 0 +isIdentity _ = False + +near :: Double -> Double -> Bool +near x y = abs (x - y) < 1e-9 + +contentStreamBody :: BS.ByteString -> BS.ByteString +contentStreamBody streamBytes = + BSC.concat + [ "<< /Length " + , BSC.pack (show (BS.length streamBytes)) + , " >>\nstream\n" + , streamBytes + , "\nendstream" + ] + +serializeCopiedObject :: Int -> PDFObjIndex -> M.Map Int Int -> BS.ByteString +serializeCopiedObject ref objs renum = + case findObjsByRef ref objs of + Nothing -> "null" + Just os -> + case findDict os of + Just d -> + case findStream os of + Nothing -> + BSC.concat ["<<", serializeDict (rewriteObj renum <$> d), " >>"] + Just stream -> + serializeStreamObject (rewriteObj renum <$> d) stream + Nothing -> + case os of + [single] -> serializeObj (rewriteObj renum single) + _ -> "null" + +findStream :: [Obj] -> Maybe BSL.ByteString +findStream os = case find isStream os of + Just (PdfStream s) -> Just s + _ -> Nothing + where + isStream (PdfStream _) = True + isStream _ = False + +serializeStreamObject :: Dict -> BSL.ByteString -> BS.ByteString +serializeStreamObject d stream = + let raw = BSL.toStrict stream + -- PdfStream in the index holds file bytes (still filter-encoded). + -- Re-compressing would double-apply FlateDecode and break content streams. + finalDict = + M.insert "/Length" (PdfNumber (fromIntegral (BS.length raw))) (stripLength d) + in BSC.concat + [ "<<" + , serializeDict finalDict + , " >>\nstream\n" + , raw + , "\nendstream" + ] +stripLength = M.filterWithKey (\k _ -> k /= "/Length") . M.delete "/Length" + +serializeDict :: Dict -> BS.ByteString +serializeDict d = + BSC.concat [serializeDictEntry k v | (k, v) <- M.toAscList d] + +serializeDictEntry :: T.Text -> Obj -> BS.ByteString +serializeDictEntry k v = + BSC.concat [" ", serializeName k, " ", serializeObj v] + +serializeObj :: Obj -> BS.ByteString +serializeObj (PdfDict d) = BSC.concat ["<<", serializeDict d, " >>"] +serializeObj (PdfArray a) = + BSC.concat ["[", BSC.intercalate " " (map serializeObj a), "]"] +serializeObj (PdfName n) = serializeName n +serializeObj (PdfText t) = serializeText t +serializeObj (PdfHex h) = serializeHex h +serializeObj (PdfNumber n) = BSC.pack (showPdfNumber n) +serializeObj (PdfBool True) = "true" +serializeObj (PdfBool False) = "false" +serializeObj (ObjRef r) = BSC.pack (show r ++ " 0 R") +serializeObj PdfNull = "null" +serializeObj (ObjOther o) = BSC.pack (T.unpack o) + +serializeName :: T.Text -> BS.ByteString +serializeName n = BSC.pack (T.unpack n) + +serializeText :: T.Text -> BS.ByteString +serializeText t + | T.all isAscii t = + let esc c = + case c of + '\\' -> "\\" + '(' -> "\\(" + ')' -> "\\)" + _ -> [c] + in BSC.concat ["(", BSC.pack (concatMap esc (T.unpack t)), ")"] + | otherwise = + BSC.concat + [ "<" + , bytesToHex (BS.pack [0xfe, 0xff] <> encodeUtf16BE t) + , ">" + ] + +-- | Re-encode 'PdfHex' from parsed objects (hex digits or raw byte chars). +serializeHex :: T.Text -> BS.ByteString +serializeHex h + | T.all (\c -> isHexDigit c) h = BSC.concat ["<", BSC.pack (T.unpack h), ">"] + | otherwise = + BSC.concat ["<", bytesToHex (textRawBytes h), ">"] + +textRawBytes :: T.Text -> BS.ByteString +textRawBytes = BS.pack . map (fromIntegral . ord) . T.unpack + +bytesToHex :: BS.ByteString -> BS.ByteString +bytesToHex = + BSC.pack . concatMap byteHex . BS.unpack + where + byteHex w = + let hi = w `div` 16 + lo = w `mod` 16 + in [hexChar hi, hexChar lo] + +hexChar :: Integral a => a -> Char +hexChar n + | n < 10 = chr (fromIntegral n + ord '0') + | otherwise = chr (fromIntegral n - 10 + ord 'A') + +showPdfNumber :: Double -> String +showPdfNumber n + | n == fromIntegral (truncate n :: Integer) = show (truncate n :: Integer) + | otherwise = show n + +obj :: Int -> BS.ByteString -> BS.ByteString +obj n body = BSC.concat [BSC.pack (show n), " 0 obj\n", body, "\nendobj\n"] + +buildBody :: [(Int, BS.ByteString)] -> (BS.ByteString, [(Int, Int)]) +buildBody objects = go pdfHeader [] (sortOn fst objects) + where + go acc offs [] = (acc, reverse offs) + go acc offs ((n, b) : rest) = + go (acc <> obj n b) ((n, BS.length acc) : offs) rest + +xrefEntry :: Int -> BS.ByteString +xrefEntry off = BSC.pack (printf "%010d 00000 n \n" off) + +xrefTable :: [(Int, Int)] -> Int -> BS.ByteString +xrefTable offsets size = + BSC.concat $ + [ "xref\n" + , BSC.pack ("0 " ++ show size ++ "\n") + , "0000000000 65535 f \n" + ] + ++ map (xrefEntry . snd) (sortOn fst offsets) + +trailerPart :: Int -> Int -> BS.ByteString +trailerPart size xrefPos = + BSC.concat + [ "trailer\n<< /Size " + , BSC.pack (show size) + , " /Root 1 0 R >>\nstartxref\n" + , BSC.pack (show xrefPos) + , "\n%%EOF\n" + ] diff --git a/src/PDF/Image.hs b/src/PDF/Image.hs new file mode 100644 --- /dev/null +++ b/src/PDF/Image.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : PDF.Image +Description : Image XObject extraction from PDF pages (0.4.3) +License : MIT + +Extracts '/Image' XObjects referenced on a page (including nested Form +XObjects). Inline images are not supported in 0.4.3. + +@example +import PDF.Image (extractPageImages) + +images <- extractPageImages doc 1 +-- each PageImage carries format, bytes, and placement bbox +-} +module PDF.Image + ( ImageFormat(..) + , PageImage(..) + , extractPageImages + , extractPageImagesToDir + , classifyImageBytes + , encodePngRgb + , encodePngGray + ) where + +import PDF.Definition (Dict, Obj(..), PDFObjIndex) +import PDF.Document (Document(..)) +import PDF.DocumentStructure + ( findDict + , findDictByRef + , findObjsByRef + , rawStreamByRef + , streamFilterNames + ) +import PDF.Error (PdfError(..), PdfResult) +import PDF.Interpret (Rect(..), interpretPageImageHits) +import PDF.Page (pageRefAt) + +import Codec.Compression.Zlib (compressWith, defaultCompressParams) + +import Data.Bits (shiftL, shiftR, xor, (.&.)) +import Data.Char (ord) +import Data.Word (Word32, Word8) + +import Control.Exception (SomeException, catch) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Map as M +import qualified Data.Text as T + +data ImageFormat = ImageJPEG | ImagePNG | ImageRaw + deriving (Eq, Show) + +data PageImage = PageImage + { piIndex :: Int + , piPage :: Int + , piBBox :: Rect + , piFormat :: ImageFormat + , piBytes :: BS.ByteString + } deriving (Eq, Show) + +-- | Extract image XObjects from a 1-based page number. +extractPageImages :: Document -> Int -> PdfResult [PageImage] +extractPageImages doc pageNum = do + pref <- pageRefAt doc pageNum + hits <- interpretPageImageHits doc pref + mapM (loadHit doc pageNum) (zip [1 ..] hits) + +extractPageImagesToDir :: Document -> Int -> FilePath -> IO (PdfResult [FilePath]) +extractPageImagesToDir doc pageNum outDir = + createDirectoryIfMissing True outDir >> go + where + go = case extractPageImages doc pageNum of + Left err -> return (Left err) + Right images -> fmap Right (mapM (writePageImage outDir) images) + +loadHit :: Document -> Int -> (Int, (Int, Rect)) -> PdfResult PageImage +loadHit doc pageNum (idx, (ref, bbox)) = do + (fmt, bytes) <- loadImageBytes doc ref + return PageImage + { piIndex = idx + , piPage = pageNum + , piBBox = bbox + , piFormat = fmt + , piBytes = bytes + } + +loadImageBytes :: Document -> Int -> PdfResult (ImageFormat, BS.ByteString) +loadImageBytes doc ref = do + os <- case findObjsByRef ref (docObjs doc) of + Just x -> Right x + Nothing -> Left (MissingObject ref) + d <- case findDict os of + Just x -> Right x + Nothing -> Left (MissingKey "/Type" ("image object " ++ show ref)) + stream <- case M.lookup ref (docStreamCache doc) of + Just r -> r + Nothing -> rawStreamByRef (docSecurity doc) (docObjs doc) ref + classifyImageBytes (docObjs doc) d (BSL.toStrict stream) + +classifyImageBytes + :: PDFObjIndex -> Dict -> BS.ByteString -> PdfResult (ImageFormat, BS.ByteString) +classifyImageBytes objs d bs = do + filters <- streamFilterNames d + if "/DCTDecode" `elem` map T.unpack filters || isJpeg bs + then return (ImageJPEG, bs) + else do + w <- dictPositiveInt d "/Width" + h <- dictPositiveInt d "/Height" + bpc <- dictPositiveInt d "/BitsPerComponent" + comps <- colorSpaceComponents objs d + case (comps, bpc, BS.length bs) of + (Just 3, 8, n) | n == w * h * 3 -> + encodePngRgb w h bs >>= \png -> return (ImagePNG, png) + (Just 1, 8, n) | n == w * h -> + encodePngGray w h bs >>= \png -> return (ImagePNG, png) + _ -> return (ImageRaw, bs) + +isJpeg :: BS.ByteString -> Bool +isJpeg bs = + BS.length bs >= 3 + && BS.index bs 0 == 0xff + && BS.index bs 1 == 0xd8 + && BS.index bs 2 == 0xff + +dictPositiveInt :: Dict -> T.Text -> PdfResult Int +dictPositiveInt d key = case M.lookup key d of + Just (PdfNumber n) -> + let i = truncate n + in if i > 0 then Right i else Left (UnsupportedFeature ("invalid " ++ T.unpack key)) + _ -> Left (MissingKey (T.unpack key) "image XObject") + +colorSpaceComponents :: PDFObjIndex -> Dict -> PdfResult (Maybe Int) +colorSpaceComponents objs d = case M.lookup "/ColorSpace" d of + Nothing -> Right Nothing + Just (PdfName "/DeviceRGB") -> Right (Just 3) + Just (PdfName "/DeviceGray") -> Right (Just 1) + Just (ObjRef r) -> + case findDictByRef r objs of + Just csDict -> colorSpaceComponents objs csDict + Nothing -> Right Nothing + Just (PdfArray (PdfName "/DeviceRGB" : _)) -> Right (Just 3) + Just (PdfArray (PdfName "/DeviceGray" : _)) -> Right (Just 1) + Just (PdfArray (ObjRef r : _)) -> + case findDictByRef r objs of + Just csDict -> colorSpaceComponents objs csDict + Nothing -> Right Nothing + _ -> Right Nothing + +writePageImage :: FilePath -> PageImage -> IO FilePath +writePageImage outDir img = do + let base = outDir pageImageBasename img + (path, sidecar) = case piFormat img of + ImageJPEG -> (base ++ ".jpg", Nothing) + ImagePNG -> (base ++ ".png", Nothing) + ImageRaw -> (base ++ ".raw", Just (base ++ ".json")) + writeBinary path (piBytes img) + case sidecar of + Nothing -> return () + Just sc -> writeBinary sc (rawSidecar img) + return path + +pageImageBasename :: PageImage -> String +pageImageBasename PageImage{piPage = pg, piIndex = idx} = + "page" ++ show pg ++ "-" ++ pad3 idx + +pad3 :: Int -> String +pad3 n = + let s = show n + in replicate (max 0 (3 - length s)) '0' ++ s + +writeBinary :: FilePath -> BS.ByteString -> IO () +writeBinary path bs = + BS.writeFile path bs `catch` handleWriteErr + where + handleWriteErr :: SomeException -> IO () + handleWriteErr e = + ioError (userError ("cannot write file: " ++ path ++ ": " ++ show e)) + +rawSidecar :: PageImage -> BS.ByteString +rawSidecar PageImage{piPage = pg, piIndex = idx, piBBox = bbox, piBytes = bs} = + BSC.pack json + where + json :: String + json = + "{\"page\":" ++ show pg + ++ ",\"index\":" ++ show idx + ++ ",\"format\":\"raw\"" + ++ ",\"length\":" ++ show (BS.length bs) + ++ ",\"bbox\":[" ++ show (rectX0 bbox) ++ "," ++ show (rectY0 bbox) + ++ "," ++ show (rectX1 bbox) ++ "," ++ show (rectY1 bbox) ++ "]}" + +-- | Minimal PNG encoder (filter 0 scanlines, zlib IDAT). No new dependencies. +encodePngRgb :: Int -> Int -> BS.ByteString -> PdfResult BS.ByteString +encodePngRgb w h pixels = encodePng 8 2 w h (pngScanlines w 3 pixels) + +encodePngGray :: Int -> Int -> BS.ByteString -> PdfResult BS.ByteString +encodePngGray w h pixels = encodePng 8 0 w h (pngScanlines w 1 pixels) + +encodePng :: Word8 -> Word8 -> Int -> Int -> BS.ByteString -> PdfResult BS.ByteString +encodePng bitDepth colorType w h scanData = do + let ihdr = + word32BE (fromIntegral w) + <> word32BE (fromIntegral h) + <> BS.pack [bitDepth, colorType, 0, 0, 0] + idat = BSL.toStrict (compressWith defaultCompressParams (BSL.fromStrict scanData)) + return $ + pngSignature + <> pngChunk "IHDR" ihdr + <> pngChunk "IDAT" idat + <> pngChunk "IEND" BS.empty + +pngSignature :: BS.ByteString +pngSignature = BS.pack [137, 80, 78, 71, 13, 10, 26, 10] + +pngScanlines :: Int -> Int -> BS.ByteString -> BS.ByteString +pngScanlines w comps pixels = + BS.concat + [ BS.cons 0 (BS.take (w * comps) (BS.drop (row * w * comps) pixels)) + | row <- [0 .. rows - 1] + ] + where + rows = BS.length pixels `div` (w * comps) + +pngChunk :: String -> BS.ByteString -> BS.ByteString +pngChunk tag payload = + let tagBs = BS.pack (map (fromIntegral . ord) tag) + len = word32BE (fromIntegral (BS.length payload)) + body = tagBs <> payload + crc = word32BE (crc32 body) + in len <> body <> crc + +word32BE :: Word32 -> BS.ByteString +word32BE w = + BS.pack + [ fromIntegral ((w `shiftR` 24) .&. 0xff) + , fromIntegral ((w `shiftR` 16) .&. 0xff) + , fromIntegral ((w `shiftR` 8) .&. 0xff) + , fromIntegral (w .&. 0xff) + ] + +crc32 :: BS.ByteString -> Word32 +crc32 bs = finish $ BS.foldl' step 0xffffffff bs + where + step crc b = + (crc `shiftR` 8) + `xor` (crcTable !! fromIntegral ((crc `xor` fromIntegral b) .&. 0xff)) + finish crc = crc `xor` 0xffffffff + +crcTable :: [Word32] +crcTable = + [ foldl + (\c _ -> + if c .&. 1 /= 0 + then xor 0xedb88320 (c `shiftR` 1) + else c `shiftR` 1 + ) + (fromIntegral n) + [0 .. 7 :: Int] + | n <- [0 .. 255] + ] diff --git a/src/PDF/Interpret.hs b/src/PDF/Interpret.hs new file mode 100644 --- /dev/null +++ b/src/PDF/Interpret.hs @@ -0,0 +1,1086 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Content-stream interpreter for glyph geometry. +-- Form XObjects inherit the enclosing marked-content stack (MCID space is per stream in the spec). +module PDF.Interpret + ( Glyph(..) + , Rect(..) + , PageItem(..) + , interpretPage + , interpretPageItems + , interpretPageImageHits + , interpretContent + , interpretContentItems + , interpretContentWithFonts + , interpretContentWithFontsItems + ) where + +import PDF.Definition +import PDF.Document (Document(..)) +import PDF.DocumentStructure + ( findDictByRef + , findDictOfType + , findObjFromDict + , findObjsByRef + , findResourcesDict + , fontInfo + , fontInfoFromDict + , rawStream + , rawStreamByRef + ) +import PDF.Matrix +import PDF.Character (pdfcharmap, adobeJapanOneSixMap) +import PDF.Encrypt (Security) +import PDF.Error (PdfError(..), PdfResult) +import PDF.Object (parseRefsArray) + +import Data.Char (chr, isDigit, ord) +import Data.List (find, foldl', isPrefixOf) +import Data.Maybe (fromMaybe, isJust) +import Data.Word (Word8) +import qualified Numeric as Num + +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC +import qualified Data.ByteString.Lazy.UTF8 as BSLU +import qualified Data.Map as M +import qualified Data.Text as T + +data Glyph = Glyph + { glyphText :: T.Text + , glyphX :: Double + , glyphY :: Double + , glyphWidth :: Double + , glyphSize :: Double + , glyphFont :: T.Text + , glyphWMode :: Int + , glyphMCID :: Maybe Int + } deriving (Eq, Show) + +data MCEntry = MCEntry + { mcTag :: T.Text + , mcMCID :: Maybe Int + } deriving (Eq, Show) + +data Rect = Rect + { rectX0 :: Double + , rectY0 :: Double + , rectX1 :: Double + , rectY1 :: Double + } deriving (Eq, Show) + +data PageItem = ItemGlyph Glyph | ItemGraphic Rect deriving (Eq, Show) + +data GState = GState + { ctm :: Matrix + , gsFontRes :: Maybe T.Text + , gsFont :: Maybe FontInfo + , gsFontSize :: Double + , gsCharSp :: Double + , gsWordSp :: Double + , gsHScale :: Double + , gsLeading :: Double + , gsRise :: Double + , gsRender :: Int + } + +data TState = TState + { tmMat :: Matrix + , tlmMat :: Matrix + } + +data IState = IState + { gsCur :: GState + , gsStack :: [GState] + , tsCur :: Maybe TState + , itemsRev :: [PageItem] + , imagesRev :: [(Int, Rect)] + , collectImages :: Bool + , pathAcc :: [(Double, Double)] + , depth :: Int + , isSec :: Maybe Security + , isObjs :: PDFObjIndex + , isStreamCache :: M.Map Int (PdfResult BSL.ByteString) + , isFontCache :: M.Map Int FontInfo + , isRes :: Dict + , fontOverrides :: M.Map T.Text FontInfo + , operandStack :: [Obj] + , mcStack :: [MCEntry] + } + +initialGState :: GState +initialGState = GState + { ctm = identity + , gsFontRes = Nothing + , gsFont = Nothing + , gsFontSize = 0 + , gsCharSp = 0 + , gsWordSp = 0 + , gsHScale = 1 + , gsLeading = 0 + , gsRise = 0 + , gsRender = 0 + } + +initialIState + :: Maybe Security + -> PDFObjIndex + -> M.Map Int (PdfResult BSL.ByteString) + -> M.Map Int FontInfo + -> Dict + -> IState +initialIState sec objs streamCache fontCache res = IState + { gsCur = initialGState + , gsStack = [] + , tsCur = Nothing + , itemsRev = [] + , imagesRev = [] + , collectImages = False + , pathAcc = [] + , depth = 0 + , isSec = sec + , isObjs = objs + , isStreamCache = streamCache + , isFontCache = fontCache + , isRes = res + , fontOverrides = M.empty + , operandStack = [] + , mcStack = [] + } + +buildCaches + :: Maybe Security + -> PDFObjIndex + -> (M.Map Int (PdfResult BSL.ByteString), M.Map Int FontInfo) +buildCaches sec objs = + ( M.mapWithKey (\r os -> rawStream sec r os) objs + , M.mapWithKey + (\r _ -> fontInfoFromDict sec objs (fromMaybe M.empty (findDictByRef r objs))) + objs + ) + +lookupStreamCache + :: Maybe Security + -> PDFObjIndex + -> M.Map Int (PdfResult BSL.ByteString) + -> Int + -> PdfResult BSL.ByteString +lookupStreamCache sec objs cache ref = + case M.lookup ref cache of + Just r -> r + Nothing -> rawStreamByRef sec objs ref + +maxFormDepth :: Int +maxFormDepth = 12 + +interpretContent :: Maybe Security -> PDFObjIndex -> Dict -> BSL.ByteString -> [Glyph] +interpretContent sec objs res bytes = + interpretContentWithFonts sec objs res M.empty bytes + +interpretContentItems :: Maybe Security -> PDFObjIndex -> Dict -> BSL.ByteString -> [PageItem] +interpretContentItems sec objs res bytes = + interpretContentWithFontsItems sec objs res M.empty bytes + +interpretContentWithFonts :: Maybe Security -> PDFObjIndex -> Dict -> M.Map T.Text FontInfo -> BSL.ByteString -> [Glyph] +interpretContentWithFonts sec objs res fonts bytes = + [g | ItemGlyph g <- interpretContentWithFontsItems sec objs res fonts bytes] + +interpretContentWithFontsItems :: Maybe Security -> PDFObjIndex -> Dict -> M.Map T.Text FontInfo -> BSL.ByteString -> [PageItem] +interpretContentWithFontsItems sec objs res fonts bytes = + let (streamCache, fontCache) = buildCaches sec objs + st0 = initialIState sec objs streamCache fontCache res + st1 = st0 {fontOverrides = fonts} + in reverse (itemsRev (runStream st1 bytes)) + +interpretPage :: Document -> Int -> PdfResult [Glyph] +interpretPage doc pageRef = do + items <- interpretPageItems doc pageRef + return [g | ItemGlyph g <- items] + +interpretPageItems :: Document -> Int -> PdfResult [PageItem] +interpretPageItems doc pageRef = do + (_, content, res) <- pageInterpretInputs doc pageRef + let st0 = initialIState + (docSecurity doc) + (docObjs doc) + (docStreamCache doc) + (docFontCache doc) + res + return $ reverse (itemsRev (runStream st0 content)) + +interpretPageImageHits :: Document -> Int -> PdfResult [(Int, Rect)] +interpretPageImageHits doc pageRef = do + (_, content, res) <- pageInterpretInputs doc pageRef + let st0 = + (initialIState + (docSecurity doc) + (docObjs doc) + (docStreamCache doc) + (docFontCache doc) + res) + {collectImages = True} + return $ reverse (imagesRev (runStream st0 content)) + +pageInterpretInputs :: Document -> Int -> PdfResult (Dict, BSL.ByteString, Dict) +pageInterpretInputs doc pageRef = do + pageDict <- case findObjsByRef pageRef (docObjs doc) of + Just os -> case findDictOfType "/Page" os of + Just d -> Right d + Nothing -> Left (MissingKey "/Type" ("page " ++ show pageRef)) + Nothing -> Left (MissingObject pageRef) + res <- case pageResourcesInherited pageDict (docObjs doc) of + Just r -> Right r + Nothing -> Right M.empty + content <- pageContentsBytes (docSecurity doc) (docObjs doc) (docStreamCache doc) pageDict + return (pageDict, content, res) + +pageResourcesInherited :: Dict -> PDFObjIndex -> Maybe Dict +pageResourcesInherited dict objs = + case findResourcesDict dict objs of + Just r -> Just r + Nothing -> case M.lookup "/Parent" dict of + Just (ObjRef pref) -> + case findDictByRef pref objs of + Just parent -> pageResourcesInherited parent objs + Nothing -> Nothing + _ -> Nothing + +pageContentsBytes + :: Maybe Security + -> PDFObjIndex + -> M.Map Int (PdfResult BSL.ByteString) + -> Dict + -> PdfResult BSL.ByteString +pageContentsBytes sec objs streamCache dict = case M.lookup "/Contents" dict of + Nothing -> Left (MissingKey "/Contents" "page") + Just (PdfArray arr) -> concatContentRefs (parseRefsArray arr) + Just (ObjRef r) -> + case findObjsByRef r objs of + Just [PdfArray arr] -> concatContentRefs (parseRefsArray arr) + Just _ -> singleStream r + Nothing -> Left (MissingObject r) + where + concatContentRefs refs = do + parts <- mapM singleStream refs + return $ BSL.intercalate (BSLC.pack "\n") parts + singleStream ref = lookupStreamCache sec objs streamCache ref + +data Token = TokOperand Obj | TokOperator String + +runStream :: IState -> BSL.ByteString -> IState +runStream st bs = loop st (skipWs bs) + where + loop s input + | BSL.null input = s + | otherwise = case readToken input of + Just (TokOperand o, rest) -> + loop (s {operandStack = o : operandStack s}) (skipWs rest) + Just (TokOperator "BI", rest) -> + loop (emitInlineImageSt s) (skipInlineImage (skipWs rest)) + Just (TokOperator op, rest) -> + loop (dispatchOp op s) (skipWs rest) + Nothing -> + loop s (BSL.tail input) + +dispatchOp :: String -> IState -> IState +dispatchOp op st = + let st' = execOp op st + in st' {operandStack = []} + +execOp :: String -> IState -> IState +execOp "q" st = pushGStateSt st +execOp "Q" st = popGStateSt st +execOp "cm" st = + case popNums 6 st of + Just ([f, e, d, c, b, a], st') -> + modifyGStateSt (\gs -> gs {ctm = multiply (mkMatrix a b c d e f) (ctm gs)}) st' + _ -> st +execOp "BT" st = st {tsCur = Just (TState identity identity)} +execOp "ET" st = st {tsCur = Nothing} +execOp "Tf" st = + case operandStack st of + PdfNumber size : PdfName font : _ -> + resolveFontSt font size st + _ -> st +execOp "Tc" st = setGSDoubleSt (\v gs -> gs {gsCharSp = v}) st +execOp "Tw" st = setGSDoubleSt (\v gs -> gs {gsWordSp = v}) st +execOp "Tz" st = + case popNums 1 st of + Just ([v], st') -> modifyGStateSt (\gs -> gs {gsHScale = v / 100}) st' + _ -> st +execOp "TL" st = setGSDoubleSt (\v gs -> gs {gsLeading = v}) st +execOp "Ts" st = setGSDoubleSt (\v gs -> gs {gsRise = v}) st +execOp "Tr" st = + case popNums 1 st of + Just ([v], st') -> modifyGStateSt (\gs -> gs {gsRender = truncate v}) st' + _ -> st +execOp "Td" st = + case popNums 2 st of + Just ([ty, tx], st') -> textTdSt tx ty st' + _ -> st +execOp "TD" st = + case popNums 2 st of + Just ([ty, tx], st') -> + let st'' = modifyGStateSt (\gs -> gs {gsLeading = -ty}) st' + in textTdSt tx ty st'' + _ -> st +execOp "Tm" st = + case popNums 6 st of + Just ([f, e, d, c, b, a], st') -> textSetMatrixSt (mkMatrix a b c d e f) st' + _ -> st +execOp "T*" st = withTextMatrixSt textLeadingNewlineSt st +execOp "Tj" st = + case operandStack st of + o : _ -> maybe st (`showBytesSt` st) (objBytes o) + _ -> st +execOp "TJ" st = + case operandStack st of + o : _ -> maybe st (`showTJSt` st) (tjElems o) + _ -> st +execOp "'" st = + case operandStack st of + o : _ -> + withTextMatrixSt + (\s -> maybe (textLeadingNewlineSt s) (`showBytesSt` (textLeadingNewlineSt s)) (objBytes o)) + st + _ -> withTextMatrixSt textLeadingNewlineSt st +execOp "\"" st = + case operandStack st of + o : PdfNumber ac : PdfNumber aw : _ -> + let st' = modifyGStateSt (\gs -> gs {gsWordSp = aw, gsCharSp = ac}) st + in withTextMatrixSt + (\s -> maybe (textLeadingNewlineSt s) (`showBytesSt` (textLeadingNewlineSt s)) (objBytes o)) + st' + _ -> st +execOp "Do" st = + case operandStack st of + PdfName name : _ -> invokeXObjectSt name st + _ -> st +execOp "m" st = + case popNums 2 st of + Just ([y, x], st') -> st' {pathAcc = [devicePoint st' x y]} + _ -> st +execOp "l" st = + case popNums 2 st of + Just ([y, x], st') -> appendPathPoint st' x y + _ -> st +execOp "c" st = + case popNums 6 st of + Just ([y3, x3, y2, x2, y1, x1], st') -> + prependPathPoints st' + [ devicePoint st' x1 y1 + , devicePoint st' x2 y2 + , devicePoint st' x3 y3 + ] + _ -> st +execOp "v" st = + case popNums 4 st of + Just ([y3, x3, y2, x2], st') -> + prependPathPoints st' + [devicePoint st' x2 y2, devicePoint st' x3 y3] + _ -> st +execOp "y" st = + case popNums 4 st of + Just ([y3, x3, y1, x1], st') -> + prependPathPoints st' + [devicePoint st' x1 y1, devicePoint st' x3 y3] + _ -> st +execOp "re" st = + case popNums 4 st of + Just ([h, w, y, x], st') -> + prependPathPoints st' + [ devicePoint st' x y + , devicePoint st' (x + w) y + , devicePoint st' x (y + h) + , devicePoint st' (x + w) (y + h) + ] + _ -> st +execOp "h" st = st +execOp "n" st = st {pathAcc = []} +execOp "S" st = paintPathSt st +execOp "s" st = paintPathSt st +execOp "f" st = paintPathSt st +execOp "F" st = paintPathSt st +execOp "f*" st = paintPathSt st +execOp "B" st = paintPathSt st +execOp "B*" st = paintPathSt st +execOp "b" st = paintPathSt st +execOp "b*" st = paintPathSt st +execOp "W" st = st +execOp "W*" st = st +execOp "BDC" st = + case operandStack st of + props : PdfName tag : _ -> + let mcid = mcidFromProps props (isRes st) (isObjs st) + in pushMCEntry tag mcid st + _ -> st +execOp "BMC" st = + case operandStack st of + PdfName tag : _ -> pushMCEntry tag Nothing st + _ -> st +execOp "EMC" st = + case mcStack st of + _ : rest -> st {mcStack = rest} + [] -> st +execOp _ st = st + +pushMCEntry :: T.Text -> Maybe Int -> IState -> IState +pushMCEntry tag mcid st = + st {mcStack = MCEntry tag mcid : mcStack st} + +currentMCID :: IState -> Maybe Int +currentMCID st = enclosingMCID (mcStack st) + +enclosingMCID :: [MCEntry] -> Maybe Int +enclosingMCID [] = Nothing +enclosingMCID (e : es) = + case mcMCID e of + Just n -> Just n + Nothing -> enclosingMCID es + +mcidFromProps :: Obj -> Dict -> PDFObjIndex -> Maybe Int +mcidFromProps props res objs = + case resolvePropsDict props res objs of + Just d -> mcidFromDict d + Nothing -> Nothing + +resolvePropsDict :: Obj -> Dict -> PDFObjIndex -> Maybe Dict +resolvePropsDict (PdfDict d) _ _ = Just d +resolvePropsDict (PdfName n) res objs = + case findObjFromDict res "/Properties" of + Just (PdfDict pd) -> case M.lookup n pd of + Just (PdfDict d) -> Just d + Just (ObjRef r) -> + case findDictByRef r objs of + Just d -> Just d + Nothing -> Nothing + _ -> Nothing + Just (ObjRef r) -> + case findDictByRef r objs of + Just pd -> case M.lookup n pd of + Just (PdfDict d) -> Just d + Just (ObjRef r') -> + case findDictByRef r' objs of + Just d -> Just d + Nothing -> Nothing + _ -> Nothing + Nothing -> Nothing + _ -> Nothing +resolvePropsDict _ _ _ = Nothing + +mcidFromDict :: Dict -> Maybe Int +mcidFromDict d = case M.lookup "/MCID" d of + Just (PdfNumber n) -> Just (truncate n) + _ -> Nothing + +devicePoint :: IState -> Double -> Double -> (Double, Double) +devicePoint st x y = apply (ctm (gsCur st)) (x, y) + +appendPathPoint :: IState -> Double -> Double -> IState +appendPathPoint st x y = st {pathAcc = devicePoint st x y : pathAcc st} + +prependPathPoints :: IState -> [(Double, Double)] -> IState +prependPathPoints st pts = st {pathAcc = foldl (flip (:)) (pathAcc st) pts} + +pointsBbox :: [(Double, Double)] -> Rect +pointsBbox pts = + let xs = map fst pts + ys = map snd pts + in Rect (minimum xs) (minimum ys) (maximum xs) (maximum ys) + +paintPathSt :: IState -> IState +paintPathSt st = + case pathAcc st of + [] -> st + pts -> st {itemsRev = ItemGraphic (pointsBbox (reverse pts)) : itemsRev st, pathAcc = []} + +emitGraphicSt :: Rect -> IState -> IState +emitGraphicSt r st = st {itemsRev = ItemGraphic r : itemsRev st} + +ctmUnitSquare :: Matrix -> Rect +ctmUnitSquare m = pointsBbox [apply m (0,0), apply m (1,0), apply m (0,1), apply m (1,1)] + +emitInlineImageSt :: IState -> IState +emitInlineImageSt st = + emitGraphicSt (ctmUnitSquare (ctm (gsCur st))) st {operandStack = []} + +setGSDoubleSt :: (Double -> GState -> GState) -> IState -> IState +setGSDoubleSt f st = + case popNums 1 st of + Just ([v], st') -> modifyGStateSt (f v) st' + _ -> st + +popNums :: Int -> IState -> Maybe ([Double], IState) +popNums n st = go n (operandStack st) [] + where + go 0 stack acc = Just (reverse acc, st {operandStack = stack}) + go k (PdfNumber x : rest) acc = go (k - 1) rest (x : acc) + go _ _ _ = Nothing + +pushGStateSt :: IState -> IState +pushGStateSt st = st {gsStack = gsCur st : gsStack st} + +popGStateSt :: IState -> IState +popGStateSt st = + case gsStack st of + (g : gs) -> st {gsCur = g, gsStack = gs} + [] -> st + +modifyGStateSt :: (GState -> GState) -> IState -> IState +modifyGStateSt f st = st {gsCur = f (gsCur st)} + +resolveFontSt :: T.Text -> Double -> IState -> IState +resolveFontSt fontName size st = + let fi = lookupFont (isRes st) fontName st + in modifyGStateSt + (\gs -> gs {gsFontRes = Just fontName, gsFont = fi, gsFontSize = size}) + st + +lookupFont res fontName st = + case M.lookup fontName (fontOverrides st) of + Just fi -> Just fi + Nothing -> lookupFontResource (isFontCache st) (isSec st) (isObjs st) res fontName + +lookupFontResource + :: M.Map Int FontInfo + -> Maybe Security + -> PDFObjIndex + -> Dict + -> T.Text + -> Maybe FontInfo +lookupFontResource fontCache sec objs res fontName = + case findObjFromDict res "/Font" of + Just (PdfDict fd) -> fontFromDict fontCache sec objs fd fontName + Just (ObjRef r) -> + case findDictByRef r objs of + Just fd -> fontFromDict fontCache sec objs fd fontName + Nothing -> Nothing + _ -> Nothing + +fontFromDict + :: M.Map Int FontInfo + -> Maybe Security + -> PDFObjIndex + -> Dict + -> T.Text + -> Maybe FontInfo +fontFromDict fontCache sec objs fd name = + case M.lookup name fd of + Just (ObjRef r) -> + Just (repairCidFontInfo name (M.findWithDefault (fontInfo sec r objs) r fontCache)) + Just (PdfDict d) -> Just (repairCidFontInfo name (fontInfoFromDict sec objs d)) + _ -> Nothing + +repairCidFontInfo :: T.Text -> FontInfo -> FontInfo +repairCidFontInfo name fi + | not (isCidFontName name) = fi + | fiBytesPerCode fi == 2, CIDmap{} <- fiEncoding fi = fi + | fiBytesPerCode fi == 2, Encoding{} <- fiEncoding fi = fi + | otherwise = defaultAdobeJapanFontInfo fi + +isCidFontName :: T.Text -> Bool +isCidFontName name = + any (`T.isPrefixOf` name) ["/C0_", "/C1_", "/C2_", "/C3_"] + +defaultAdobeJapanFontInfo :: FontInfo -> FontInfo +defaultAdobeJapanFontInfo fi = + let dw = if fiDefaultWidth fi == 0 then 1000 else fiDefaultWidth fi + widthFn cid = let w = fiWidth fi cid in if w == 0 then dw else w + in fi + { fiEncoding = CIDmap "Adobe-Japan1" + , fiBytesPerCode = 2 + , fiDefaultWidth = dw + , fiWidth = widthFn + , fiWidthV = \cid -> let w = fiWidthV fi cid in if w == 0 then defaultVerticalW1 else w + } + +textTdSt :: Double -> Double -> IState -> IState +textTdSt tx ty st = + case tsCur st of + Nothing -> st + Just ts -> + let tlm' = multiply (translate tx ty) (tlmMat ts) + in st {tsCur = Just (TState {tmMat = tlm', tlmMat = tlm'})} + +textSetMatrixSt :: Matrix -> IState -> IState +textSetMatrixSt m st = st {tsCur = Just (TState {tmMat = m, tlmMat = m})} + +textLeadingNewlineSt :: IState -> IState +textLeadingNewlineSt st = + let leading = -(gsLeading (gsCur st)) + in textTdSt 0 leading st + +withTextMatrixSt :: (IState -> IState) -> IState -> IState +withTextMatrixSt f st = if isJust (tsCur st) then f st else st + +data TJElem = TJString [Int] | TJAdjust Double + +showTJSt :: [TJElem] -> IState -> IState +showTJSt elems st = foldl' go st elems + where + go s (TJString bs) = showBytesSt bs s + go s (TJAdjust k) = tjKernSt k s + +tjKernSt :: Double -> IState -> IState +tjKernSt k st = + case tsCur st of + Nothing -> st + Just ts -> + let gs = gsCur st + fi = gsFont gs + wmode = maybe 0 fiWMode fi + disp = -k / 1000 * gsFontSize gs * gsHScale gs + tm' = if wmode == 1 + then multiply (translate 0 disp) (tmMat ts) + else multiply (translate disp 0) (tmMat ts) + in st {tsCur = Just ts {tmMat = tm'}} + +showBytesSt :: [Int] -> IState -> IState +showBytesSt bytes st = + case (tsCur st, gsFont (gsCur st), gsFontRes (gsCur st)) of + (Nothing, _, _) -> st + (_, Nothing, _) -> st + (_, _, Nothing) -> st + (Just ts, Just fi, Just fname) -> + let gs = gsCur st + codes = bytesToCodes fi bytes + originTrm = textRenderingMatrix gs ts + (ox, oy) = apply originTrm (0, 0) + segSize = deviceFontSize originTrm + (text, endTm) = foldl' (glyphStep gs fi) (T.empty, tmMat ts) codes + endTrm = textRenderingMatrix gs (ts {tmMat = endTm}) + (ex, ey) = apply endTrm (0, 0) + width = dist ox oy ex ey + glyph = Glyph + { glyphText = text + , glyphX = ox + , glyphY = oy + , glyphWidth = width + , glyphSize = segSize + , glyphFont = fname + , glyphWMode = fiWMode fi + , glyphMCID = currentMCID st + } + in st {itemsRev = ItemGlyph glyph : itemsRev st, tsCur = Just ts {tmMat = endTm}} + _ -> st + +glyphStep :: GState -> FontInfo -> (T.Text, Matrix) -> Int -> (T.Text, Matrix) +glyphStep gs fi (txt, tm) code = + let u = codeToUnicode fi code + (tx, ty) = codeAdvance gs fi code + tm' = multiply (translate tx ty) tm + in (txt `T.append` u, tm') + +bytesToCodes :: FontInfo -> [Int] -> [Int] +bytesToCodes fi bytes = + if fiBytesPerCode fi == 2 + then pairs bytes + else bytes + where + pairs [] = [] + pairs [_] = [] + pairs (a:b:rest) = (a * 256 + b) : pairs rest + +codeToUnicode :: FontInfo -> Int -> T.Text +codeToUnicode fi code = + case M.lookup code (fiToUnicode fi) of + Just s -> s + Nothing -> + case fiEncoding fi of + NullMap | fiBytesPerCode fi == 2 -> + encodingUnicode (CIDmap "Adobe-Japan1") code + enc -> encodingUnicode enc code + +encodingUnicode :: Encoding -> Int -> T.Text +encodingUnicode (Encoding enc) code = + case M.lookup (chr code) enc of + Just glyph -> + case bulletUnicode glyph of + Just u -> u + Nothing -> + case M.lookup (T.unpack glyph) pdfcharmap of + Just u -> u + Nothing -> if "/uni" `T.isPrefixOf` glyph + then readUniGlyph glyph + else glyph + Nothing -> T.singleton (safeChr code) +encodingUnicode (CIDmap "Adobe-Japan1") code = + case M.lookup code adobeJapanOneSixMap of + Just bs -> T.pack (BSLU.toString bs) + Nothing -> T.singleton (safeChr code) +encodingUnicode (CIDmap _) code = T.singleton (safeChr code) +encodingUnicode (WithCharSet "ZapfDingbats") code = + fromMaybe (T.singleton (safeChr code)) (dingbatCodeUnicode code) +encodingUnicode (WithCharSet _) code = T.singleton (safeChr code) +encodingUnicode NullMap code = T.singleton (safeChr code) + +bulletUnicode :: T.Text -> Maybe T.Text +bulletUnicode glyph + | glyph `elem` ["/bullet", "/circle", "/disc", "/filledbox"] = Just "\x2022" + | otherwise = Nothing + +dingbatCodeUnicode :: Int -> Maybe T.Text +dingbatCodeUnicode code + | code `elem` [108, 110, 114, 183] = Just "\x2022" + | otherwise = Nothing + +readUniGlyph :: T.Text -> T.Text +readUniGlyph s = + case Num.readHex (T.unpack $ T.drop 4 s) of + [(i, "")] -> T.singleton (chr i) + _ -> s + +safeChr :: Int -> Char +safeChr n + | n >= 0 && n <= 0x10FFFF = chr n + | otherwise = '\xfffd' + +fontWidthUnits :: FontInfo -> Int -> Double +fontWidthUnits fi code = + let w = fiWidth fi code + in if w == 0 then fiDefaultWidth fi else w + +fontWidthVUnits :: FontInfo -> Int -> Double +fontWidthVUnits fi code = + let w = fiWidthV fi code + in if w == 0 then defaultVerticalW1 else w + +defaultVerticalW1 :: Double +defaultVerticalW1 = -1000 + +codeAdvance :: GState -> FontInfo -> Int -> (Double, Double) +codeAdvance gs fi code = + let tfs = gsFontSize gs + tc = gsCharSp gs + tw = gsWordSp gs + th = gsHScale gs + w0 = fontWidthUnits fi code / 1000 + in if fiWMode fi == 1 + then (0, (fontWidthVUnits fi code / 1000) * tfs + tc + tw) + else let space = if fiBytesPerCode fi == 1 && code == 32 then tw else 0 + in ((w0 * tfs + tc + space) * th, 0) + +textRenderingMatrix :: GState -> TState -> Matrix +textRenderingMatrix gs ts = + let tfs = gsFontSize gs + th = gsHScale gs + tr = gsRise gs + textMat = mkMatrix (tfs * th) 0 0 tfs 0 tr + in multiply (multiply textMat (tmMat ts)) (ctm gs) + +deviceFontSize :: Matrix -> Double +deviceFontSize trm = + let (vx, vy) = applyVec trm (0, 1) + in sqrt (vx * vx + vy * vy) + +dist :: Double -> Double -> Double -> Double -> Double +dist x1 y1 x2 y2 = + sqrt ((x2 - x1) * (x2 - x1) + (y2 - y1) * (y2 - y1)) + +invokeXObjectSt :: T.Text -> IState -> IState +invokeXObjectSt name st = + case findObjFromDict (isRes st) "/XObject" of + Just (PdfDict xd) -> case M.lookup name xd of + Just (ObjRef r) -> runXObjectSt r st + _ -> st + Just (ObjRef xr) -> + case findDictByRef xr (isObjs st) of + Just xd -> case M.lookup name xd of + Just (ObjRef r) -> runXObjectSt r st + _ -> st + Nothing -> st + _ -> st + +runXObjectSt :: Int -> IState -> IState +runXObjectSt ref st0 + | depth st0 >= maxFormDepth = st0 + | otherwise = + case findObjsByRef ref (isObjs st0) of + Just os -> case findDict os of + Just d -> case M.lookup "/Subtype" d of + Just (PdfName "/Form") -> + case lookupStreamCache (isSec st0) (isObjs st0) (isStreamCache st0) ref of + Right stream -> + let formMat = formMatrix d + formRes = fromMaybe (isRes st0) (findResourcesDict d (isObjs st0)) + stPush = pushGStateSt st0 + stMat = modifyGStateSt (\gs -> gs {ctm = multiply formMat (ctm gs)}) stPush + stRun = stMat {isRes = formRes, depth = depth st0 + 1, operandStack = []} + stDone = runStream stRun stream + stPop = popGStateSt st0 + in stPop + { itemsRev = itemsRev stDone + , imagesRev = imagesRev stDone + , depth = depth st0 + , isRes = isRes st0 + } + Left _ -> st0 + Just (PdfName "/Image") -> + let bbox = ctmUnitSquare (ctm (gsCur st0)) + st1 = + if collectImages st0 + then st0 {imagesRev = (ref, bbox) : imagesRev st0} + else st0 + in emitGraphicSt bbox st1 + _ -> st0 + Nothing -> st0 + Nothing -> st0 + +formMatrix :: Dict -> Matrix +formMatrix d = case M.lookup "/Matrix" d of + Just (PdfArray [PdfNumber a, PdfNumber b, PdfNumber c, PdfNumber d', PdfNumber e, PdfNumber f]) -> + mkMatrix a b c d' e f + _ -> identity + +objBytes :: Obj -> Maybe [Int] +objBytes (PdfText s) = Just (map ord (T.unpack s)) +objBytes (PdfHex h) = Just (hexPairs (T.unpack h)) +objBytes _ = Nothing + +tjElems :: Obj -> Maybe [TJElem] +tjElems (PdfArray objs) = mapM elemObj objs + where + elemObj (PdfNumber n) = Just (TJAdjust n) + elemObj o = TJString <$> objBytes o +tjElems _ = Nothing + +hexPairs :: String -> [Int] +hexPairs [] = [] +hexPairs [x] = + case Num.readHex [x, '0'] of + [(n, "")] -> [n] + _ -> [] +hexPairs (a:b:rest) = + case Num.readHex [a, b] of + [(n, "")] -> n : hexPairs rest + _ -> hexPairs rest + +w2c :: Word8 -> Char +w2c = chr . fromIntegral + +isWs8 :: Word8 -> Bool +isWs8 w = w2c w `elem` (" \t\r\n\f" :: String) + +delimChar8 :: Word8 -> Bool +delimChar8 w = w2c w `elem` ("[]()<>/{" :: String) + +nameEnd8 :: Word8 -> Bool +nameEnd8 w = isWs8 w || delimChar8 w + +hexDigit8 :: Word8 -> Bool +hexDigit8 w = w2c w `elem` ("0123456789abcdefABCDEF" :: String) + +keywordEnd8 :: BSL.ByteString -> Bool +keywordEnd8 bs = case BSL.uncons bs of + Nothing -> True + Just (w, _) -> isWs8 w || w == 37 || delimChar8 w + +skipWs :: BSL.ByteString -> BSL.ByteString +skipWs bs = case BSL.uncons bs of + Nothing -> bs + Just (w, rest) + | isWs8 w -> skipWs rest + | w == 37 -> skipWs (BSL.dropWhile (\w' -> w2c w' `notElem` ("\r\n" :: String)) rest) + | otherwise -> bs + +readToken :: BSL.ByteString -> Maybe (Token, BSL.ByteString) +readToken bs = + let bs' = skipWs bs + in if BSL.null bs' + then Nothing + else case BSL.uncons bs' of + Nothing -> Nothing + Just (w, _) -> + case w of + 91 -> readArray bs' + 60 -> if BSL.take 2 bs' == BSLC.pack "<<" then readDict bs' else readHexString bs' + 40 -> readLiteral bs' + 47 -> readName bs' + 45 -> readNumber bs' + 43 -> readNumber bs' + 46 -> readNumber bs' + 39 -> Just (TokOperator "'", BSL.tail bs') + 34 -> Just (TokOperator "\"", BSL.tail bs') + 116 -> readKeyword bs' "true" PdfBool True + 102 -> readKeyword bs' "false" PdfBool False + 110 -> readKeyword bs' "null" (const PdfNull) () + d | isDigit (w2c d) -> readNumber bs' + _ -> readOperator bs' + +readKeyword :: BSL.ByteString -> String -> (a -> Obj) -> a -> Maybe (Token, BSL.ByteString) +readKeyword bs kw mk val = + let k = BSLC.pack kw + n = fromIntegral (length kw) + in if BSL.take n bs == k && keywordEnd8 (BSL.drop n bs) + then Just (TokOperand (mk val), BSL.drop n bs) + else readOperator bs + +readNumber :: BSL.ByteString -> Maybe (Token, BSL.ByteString) +readNumber bs = + let (numBs, rest) = spanNum8 bs + in if BSL.null numBs + then Nothing + else Just (TokOperand (PdfNumber (parsePdfNumber (map w2c (BSL.unpack numBs)))), rest) + +spanNum8 :: BSL.ByteString -> (BSL.ByteString, BSL.ByteString) +spanNum8 bs = + let (signed, rest) = case BSL.uncons bs of + Just (45, r) -> (BSL.cons 45 BSL.empty, r) + Just (43, r) -> (BSL.empty, r) + _ -> (BSL.empty, bs) + (intp, rest') = BSL.span isDigit8 (if BSL.null signed then bs else rest) + start = if BSL.null signed then BSL.empty else signed + (frac, rest'') = case BSL.uncons rest' of + Just (46, r) -> + let (ds, r') = BSL.span isDigit8 r + in if BSL.null ds && BSL.null intp + then (BSL.empty, bs) + else (BSL.cons 46 ds, r') + _ -> (BSL.empty, rest') + num = start <> intp <> frac + in if BSL.null num && not (BSL.take 1 frac == BSLC.pack ".") + then (BSL.empty, bs) + else (num, if BSL.null frac then rest' else rest'') + +isDigit8 :: Word8 -> Bool +isDigit8 w = w >= 48 && w <= 57 + +isOpChar8 :: Word8 -> Bool +isOpChar8 w = + let c = w2c w + in (c >= 'A' && c <= 'Z') + || (c >= 'a' && c <= 'z') + || (c >= '0' && c <= '9') + || c == '*' + +normalizePdfNumber :: String -> String +normalizePdfNumber s + | null s = s + | head s == '.' = '0' : s + | length s >= 2 && head s == '-' && s !! 1 == '.' = '-' : '0' : drop 2 s + | otherwise = s + +parsePdfNumber :: String -> Double +parsePdfNumber s + | null s || s == "-" || s == "+" = 0 + | last s == '.' = + case reads (normalizePdfNumber s ++ "0") of + [(n, "")] -> n + _ -> 0 + | otherwise = + case reads (normalizePdfNumber s) of + [(n, "")] -> n + _ -> 0 + +readName :: BSL.ByteString -> Maybe (Token, BSL.ByteString) +readName bs = + let body = BSL.dropWhile (not . nameEnd8) (BSL.tail bs) + len = BSL.length bs - BSL.length body + in if len > 1 + then Just (TokOperand (PdfName (T.pack (map w2c (BSL.unpack (BSL.take len bs))))), body) + else Nothing + +readLiteral :: BSL.ByteString -> Maybe (Token, BSL.ByteString) +readLiteral bs = + case parseLiteral (map w2c (BSL.unpack (BSL.tail bs))) 1 [] of + Nothing -> Nothing + Just (bytes, rest) -> Just (TokOperand (PdfText (T.pack (map chr bytes))), BSLC.pack rest) + +parseLiteral :: String -> Int -> [Int] -> Maybe ([Int], String) +parseLiteral [] _ _ = Nothing +parseLiteral s@(')' : rest) 1 acc = Just (reverse acc, rest) +parseLiteral ('\\' : ')' : rest) depth acc = parseLiteral rest depth (ord ')' : acc) +parseLiteral ('\\' : '(' : rest) depth acc = parseLiteral rest depth (ord '(' : acc) +parseLiteral ('\\' : 'n' : rest) depth acc = parseLiteral rest depth (ord '\n' : acc) +parseLiteral ('\\' : 'r' : rest) depth acc = parseLiteral rest depth (ord '\r' : acc) +parseLiteral ('\\' : 't' : rest) depth acc = parseLiteral rest depth (ord '\t' : acc) +parseLiteral ('\\' : 'b' : rest) depth acc = parseLiteral rest depth (ord '\b' : acc) +parseLiteral ('\\' : 'f' : rest) depth acc = parseLiteral rest depth (ord '\f' : acc) +parseLiteral ('\\' : '\\' : rest) depth acc = parseLiteral rest depth (ord '\\' : acc) +parseLiteral ('\\' : d : rest) depth acc + | d `elem` ("01234567" :: String) = + let (oct, rest') = span (`elem` ("01234567" :: String)) (d : rest) + oct3 = take 3 oct + val = case Num.readOct oct3 of + [(n, "")] -> n + _ -> ord '?' + in parseLiteral rest' depth (val : acc) +parseLiteral ('\\' : _ : rest) depth acc = parseLiteral rest depth (ord '?' : acc) +parseLiteral ('(' : rest) depth acc = parseLiteral rest (depth + 1) acc +parseLiteral (c : rest) depth acc = parseLiteral rest depth (ord c : acc) + +readHexString :: BSL.ByteString -> Maybe (Token, BSL.ByteString) +readHexString bs = + let hex = BSL.takeWhile hexDigit8 (BSL.tail bs) + rest = BSL.drop (1 + BSL.length hex) bs + in case BSL.uncons rest of + Just (62, r) -> Just (TokOperand (PdfHex (T.pack (map w2c (BSL.unpack hex)))), r) + _ -> Nothing + +readArray :: BSL.ByteString -> Maybe (Token, BSL.ByteString) +readArray bs = parseArrayElems (BSL.tail bs) [] + +parseArrayElems :: BSL.ByteString -> [Obj] -> Maybe (Token, BSL.ByteString) +parseArrayElems bs acc = + let bs' = skipWs bs + in case BSL.uncons bs' of + Just (93, rest) -> Just (TokOperand (PdfArray (reverse acc)), rest) + _ -> case readToken bs' of + Just (TokOperand o, rest) -> parseArrayElems rest (o : acc) + _ -> Nothing + +readDict :: BSL.ByteString -> Maybe (Token, BSL.ByteString) +readDict bs = parseDictPairs (BSL.drop 2 bs) M.empty + +parseDictPairs :: BSL.ByteString -> Dict -> Maybe (Token, BSL.ByteString) +parseDictPairs bs acc = + let bs' = skipWs bs + in case BSL.take 2 bs' of + k | k == BSLC.pack ">>" -> + Just (TokOperand (PdfDict acc), BSL.drop 2 bs') + _ -> case readToken bs' of + Just (TokOperand (PdfName key), rest1) -> + case readToken (skipWs rest1) of + Just (TokOperand val, rest2) -> parseDictPairs rest2 (M.insert key val acc) + _ -> Nothing + _ -> Nothing + +readOperator :: BSL.ByteString -> Maybe (Token, BSL.ByteString) +readOperator bs = + let (opBs, rest) = BSL.span isOpChar8 bs + in if BSL.null opBs + then Nothing + else Just (TokOperator (map w2c (BSL.unpack opBs)), rest) + +skipInlineImage :: BSL.ByteString -> BSL.ByteString +skipInlineImage bs = + let afterID = skipToWsKeyword bs "ID" + in skipToWsKeyword afterID "EI" + +skipToWsKeyword :: BSL.ByteString -> String -> BSL.ByteString +skipToWsKeyword bs kw = + let n = fromIntegral (length kw) + lim = max 0 (BSL.length bs - n) + kwBs = BSLC.pack kw + in case findMatch n kwBs 0 lim of + Nothing -> BSL.empty + Just i -> + let after = BSL.drop (i + 1 + n) bs + in skipWs after + where + findMatch n kwBs i lim + | i > lim = Nothing + | otherwise = + let w = BSL.index bs i + in if isWs8 w && BSL.take n (BSL.drop (i + 1) bs) == kwBs + then Just i + else findMatch n kwBs (i + 1) lim + +findDict :: [Obj] -> Maybe Dict +findDict objs = case find isDict objs of + Just (PdfDict d) -> Just d + _ -> Nothing + where + isDict (PdfDict _) = True + isDict _ = False diff --git a/src/PDF/Layout.hs b/src/PDF/Layout.hs new file mode 100644 --- /dev/null +++ b/src/PDF/Layout.hs @@ -0,0 +1,1293 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : PDF.Layout +Description : Line and paragraph reconstruction from interpreted page items +License : MIT + +Turns 'PDF.Interpret' glyph runs into lines and paragraphs. Most callers use +'PDF.Text' or 'PDF.Page' instead of calling these functions directly. + +@example +import PDF.Layout (LayoutOptions(..), defaultLayoutOptions) + +opts :: LayoutOptions +opts = defaultLayoutOptions { optRuby = True, optFootnotes = False } +-} +module PDF.Layout + ( Rect(..) + , PageItem(..) + , Line(..) + , LayoutOptions(..) + , defaultLayoutOptions + , needsAozoraBar + , aozoraRuby + , layoutParagraphs + , layoutParagraphsWith + , layoutPageText + , layoutPageTextWith + , layoutDocument + , layoutDocumentWith + , layoutDocumentFromPageLines + , pageLinesRaw + , stripHeadersFooters + , linesFromGlyphs + , sortLinesByReadingOrder + , joinParaLines + , intraLineSpace + , joinGlyphsRun + , pageItemLines + , pageItemParagraphGroups + , forcePageLines + ) where + +import Control.DeepSeq (force) + +import PDF.Interpret (Glyph(..), Rect(..), PageItem(..)) + +import Data.Char (isDigit, isSpace, ord) +import Data.List (foldl', maximumBy, partition, sort, sortBy) +import Data.Maybe (listToMaybe, mapMaybe) +import Data.Ord (Down(..), comparing) +import qualified Data.DList as DL +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T + +-- Footnote bodies continuing onto the following page are not merged. +-- | Layout options shared by geometry extraction, page APIs, and diff. +data LayoutOptions = LayoutOptions + { optFootnotes :: Bool + -- ^ Inline footnote bodies as @\@ tags in paragraph text. + , optRuby :: Bool + -- ^ Embed ruby in Aozora bunko notation (@《…》@, @｜@ for mixed-script bases). + } deriving (Eq, Show) + +-- | Default layout: no footnote tags, no ruby. +defaultLayoutOptions :: LayoutOptions +defaultLayoutOptions = LayoutOptions {optFootnotes = False, optRuby = False} + +layoutPageText :: [PageItem] -> T.Text +layoutPageText = layoutPageTextWith defaultLayoutOptions + +layoutPageTextWith :: LayoutOptions -> [PageItem] -> T.Text +layoutPageTextWith opts items = formatParagraphs (layoutParagraphsWith opts items) + +layoutDocument :: [[PageItem]] -> T.Text +layoutDocument = layoutDocumentWith defaultLayoutOptions + +layoutDocumentWith :: LayoutOptions -> [[PageItem]] -> T.Text +layoutDocumentWith opts pages = + layoutDocumentFromPageLines opts (map pageLinesRaw pages) + +layoutDocumentFromPageLines :: LayoutOptions -> [PageLines] -> T.Text +layoutDocumentFromPageLines opts layouts = + formatParagraphs (documentParagraphsFromPageLines opts layouts) + +formatParagraphs :: [T.Text] -> T.Text +formatParagraphs ps = + if null ps + then "\n" + else T.intercalate "\n\n" ps `T.append` "\n" + +layoutParagraphs :: [PageItem] -> [T.Text] +layoutParagraphs = layoutParagraphsWith defaultLayoutOptions + +layoutParagraphsWith :: LayoutOptions -> [PageItem] -> [T.Text] +layoutParagraphsWith opts items = + case applyFootnotes opts (applyRuby opts (pageLinesRaw items)) of + PageFallback ps -> ps + PageNormal wmode graphics bounds ls -> + map joinParaLines (groupParagraphs wmode graphics bounds ls) + +pageItemLines :: LayoutOptions -> [PageItem] -> [Line] +pageItemLines opts items = + case applyFootnotes opts (applyRuby opts (pageLinesRaw items)) of + PageFallback _ -> [] + PageNormal _ _ _ ls -> ls + +pageItemParagraphGroups :: LayoutOptions -> [PageItem] -> [[Line]] +pageItemParagraphGroups opts items = + case applyFootnotes opts (applyRuby opts (pageLinesRaw items)) of + PageFallback ps -> replicate (length ps) [] + PageNormal wmode graphics bounds ls -> + groupParagraphs wmode graphics bounds ls + +documentParagraphs :: LayoutOptions -> [[PageItem]] -> [T.Text] +documentParagraphs opts pages = + documentParagraphsFromPageLines opts (map pageLinesRaw pages) + +documentParagraphsFromPageLines :: LayoutOptions -> [PageLines] -> [T.Text] +documentParagraphsFromPageLines opts layouts = + let n = length layouts + stripped = applyHeaderFooterStrip n layouts + final = map (applyFootnotes opts . applyRuby opts) stripped + in finalizeDoc $ foldl' processPage (DL.empty, []) final + where + continuePage done pageGroups = + case reverse pageGroups of + [] -> (done, []) + lastG : restRev -> + ( done <> DL.fromList (map joinParaLines (reverse restRev)) + , lastG + ) + + processPage (done, pending) (PageFallback ps) = + ( done <> DL.fromList (finalize pending ++ map T.strip ps) + , [] + ) + + processPage (done, pending) (PageNormal wmode graphics bounds ls) = + let pageGroups = groupParagraphs wmode graphics bounds ls + pageMinInline = + if null ls + then 0 + else minimum (map lineInlineStart ls) + in case (pending, pageGroups) of + ([], _) -> continuePage done pageGroups + (ps, []) -> (done, ps) + (ps, g : gs) -> + case g of + firstLine : _ -> + let paraSoFar = joinParaLines ps + lastLine = case reverse ps of + l : _ -> l + [] -> firstLine + in if pageBoundaryBreak paraSoFar firstLine pageMinInline lastLine firstLine + then continuePage (done `DL.snoc` paraSoFar) (g : gs) + else case reverse gs of + [] -> (done, ps ++ g) + lastG : restRev -> + ( done <> + ( DL.fromList + ( joinParaLines (ps ++ g) + : map joinParaLines (reverse restRev) + ) + ) + , lastG + ) + [] -> (done, ps) + + finalizeDoc (done, pending) = DL.toList done ++ finalize pending + + finalize [] = [] + finalize ps = [joinParaLines ps] + +applyHeaderFooterStrip :: Int -> [PageLines] -> [PageLines] +applyHeaderFooterStrip n layouts = + let normalPairs = [(i, ls) | (i, PageNormal _ _ _ ls) <- zip [0 ..] layouts] + strippedNormals = stripHeadersFooters n (map snd normalPairs) + strippedMap = M.fromList (zip (map fst normalPairs) strippedNormals) + in [ case layout of + PageFallback ps -> PageFallback ps + PageNormal w g b ls -> + PageNormal w g b (M.findWithDefault ls i strippedMap) + | (i, layout) <- zip [0 ..] layouts + ] + +data PageLines + = PageFallback [T.Text] + | PageNormal Int [Rect] (Double, Double) [Line] + deriving (Show) + +-- | Force layout fields used after interpretation (text, coords, markers). +-- Source 'Glyph' values may retain unevaluated 'FontInfo' functions; 'PageLines' +-- does not reference them. +forcePageLines :: PageLines -> () +forcePageLines (PageFallback ps) = + foldr (\t () -> force t `seq` ()) () ps +forcePageLines (PageNormal wmode graphics bounds ls) = + wmode `seq` + foldr forceRect () graphics `seq` + bounds `seq` + foldr forceLine () ls `seq` + () + +forceRect :: Rect -> () -> () +forceRect r () = + rectX0 r `seq` rectY0 r `seq` rectX1 r `seq` rectY1 r `seq` () + +forceLine :: Line -> () -> () +forceLine l () = + lineBaseline l `seq` + lineInlineStart l `seq` + lineInlineEnd l `seq` + lineSize l `seq` + lineFirstInline l `seq` + lineWMode l `seq` + force (lineText l) `seq` + foldr (\(i, t) () -> i `seq` force t `seq` ()) () (lineMarkers l) `seq` + lineLastSuper l `seq` + () + +applyFootnotes :: LayoutOptions -> PageLines -> PageLines +applyFootnotes opts page = + case page of + PageNormal 0 graphics bounds ls + | optFootnotes opts -> + PageNormal 0 graphics bounds (inlineFootnotes graphics ls) + _ -> page + +applyRuby :: LayoutOptions -> PageLines -> PageLines +applyRuby opts page = + case page of + PageNormal wmode _ bounds ls -> + PageNormal wmode [] bounds (mergeInterleavedRubyLines wmode (optRuby opts) ls) + _ -> page + +-- Aozora bunko ruby: fullwidth 《》 and optional ｜ before mixed-script bases. +aozoraRuby :: T.Text -> T.Text -> T.Text +aozoraRuby base ruby = + let prefix = if needsAozoraBar base then "\65372" else T.empty -- ｜ + in base `T.append` prefix `T.append` "\12298" `T.append` ruby `T.append` "\12299" -- 《》 + +needsAozoraBar :: T.Text -> Bool +needsAozoraBar t = + let cats = S.fromList (mapMaybe scriptCategory (T.unpack t)) + in S.size cats >= 2 + +data ScriptCat = CatHiragana | CatKatakana | CatCJK | CatLatin | CatOther + deriving (Eq, Ord, Show) + +scriptCategory :: Char -> Maybe ScriptCat +scriptCategory c = + let cp = ord c + in if cp >= 0x3041 && cp <= 0x309F + then Just CatHiragana + else if cp >= 0x30A1 && cp <= 0x30FF + then Just CatKatakana + else if (cp >= 0x4E00 && cp <= 0x9FFF) + || (cp >= 0x3400 && cp <= 0x4DBF) + || (cp >= 0xF900 && cp <= 0xFAFF) + then Just CatCJK + else if (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') + then Just CatLatin + else if isSpace c + then Nothing + else Just CatOther + +pairRubyLines :: Int -> (Double, Double) -> [Line] -> [Line] +pairRubyLines wmode _ = mergeInterleavedRubyLines wmode True + +isRubyLine :: Int -> Double -> [Line] -> Line -> Bool +isRubyLine wmode bodySize ls l = + lineSize l <= 0.85 * bodySize + && not (T.null (T.strip (lineText l))) + && any (rubyAlignsWithParent wmode l) (filter isBodyLine ls) + where + isBodyLine b = lineSize b > 0.85 * bodySize + +bodyMedianSize :: [Line] -> Double +bodyMedianSize ls = + let sizes = map lineSize ls + med = medianOf sizes + bodySizes = [lineSize l | l <- ls, lineSize l > 0.85 * med] + in if null bodySizes then med else medianOf bodySizes + +baselineClose :: Double -> Line -> Line -> Bool +baselineClose bodySize a b = + abs (lineBaseline a - lineBaseline b) <= 0.4 * bodySize + +shortBodyLine :: Line -> Bool +shortBodyLine l = T.length (T.strip (lineText l)) <= 2 + +firstCharText :: T.Text -> T.Text +firstCharText t = + case T.uncons (T.strip t) of + Nothing -> T.empty + Just (c, _) -> T.singleton c + +clusterBaseText :: [(Line, Line)] -> T.Text +clusterBaseText pairs = + let bs = map fst pairs + in T.concat + [ if length bs == 1 + then T.strip (lineText b) + else if i == length bs - 1 && not (shortBodyLine b) + then firstCharText (lineText b) + else T.strip (lineText b) + | (i, b) <- zip [0 ..] bs + ] + +clusterSuffixText :: [(Line, Line)] -> T.Text +clusterSuffixText pairs = + case reverse (map fst pairs) of + b : _ | not (shortBodyLine b) -> + let t = T.strip (lineText b) + in if T.null t then T.empty else T.drop 1 t + _ -> T.empty + +clusterRubyText :: [(Line, Line)] -> T.Text +clusterRubyText = T.concat . map (T.strip . lineText . snd) + +clusterContinuation :: Line -> Line -> Bool +clusterContinuation prev cur = + baselineClose (lineSize cur) prev cur + && lineInlineStart cur - lineInlineEnd prev <= 2 * lineSize cur + +removeRubyLine :: Line -> [Line] -> [Line] +removeRubyLine r = filter (not . sameRubyLine r) + +sameRubyLine :: Line -> Line -> Bool +sameRubyLine a b = + lineBaseline a == lineBaseline b + && lineInlineStart a == lineInlineStart b + && lineText a == lineText b + +findRubyForBody :: Int -> [Line] -> Line -> Maybe Line +findRubyForBody wmode rubyLs body = + case [ r + | r <- rubyLs + , rubyAlignsWithParent wmode r body + ] of + [] -> Nothing + rs -> Just (maximumBy (comparing (\r -> rubyOverlapFrac wmode r body)) rs) + +mergeInterleavedRubyLines :: Int -> Bool -> [Line] -> [Line] +mergeInterleavedRubyLines wmode includeRuby ls + | null ls = ls + | otherwise = + let bodySize = bodyMedianSize ls + (rubyLs, bodyLs) = partition (isRubyLine wmode bodySize ls) ls + in if null rubyLs + then ls + else mergeBodyBands wmode includeRuby bodySize rubyLs bodyLs + +mergeBodyBands :: Int -> Bool -> Double -> [Line] -> [Line] -> [Line] +mergeBodyBands wmode includeRuby bodySize rubyLs bodyLs = + let bands = groupBodyBaselineBands bodySize (sortLinesByReadingOrder bodyLs) + in concatMap (mergeOneBand wmode includeRuby bodySize rubyLs) bands + +groupBodyBaselineBands :: Double -> [Line] -> [[Line]] +groupBodyBaselineBands _ [] = [] +groupBodyBaselineBands bodySize (l:ls) = + let (same, rest) = span (baselineClose bodySize l) ls + in (l : same) : groupBodyBaselineBands bodySize rest + +mergeOneBand :: Int -> Bool -> Double -> [Line] -> [Line] -> [Line] +mergeOneBand wmode includeRuby bodySize allRuby bodyBand = + let sorted = sortBy (comparing lineInlineStart) bodyBand + (segments, _) = foldSegments wmode bodySize allRuby sorted + repStart = head sorted + repEnd = last sorted + txt = renderRubySegments includeRuby segments + in if T.null txt + then [] + else [ repStart + { lineText = txt + , lineInlineEnd = lineInlineEnd repEnd + , lineInlineStart = lineInlineStart repStart + , lineSize = max (lineSize repStart) (lineSize repEnd) + } + ] + +data RubySegment + = PlainSeg !Line + | ClusterSeg [(Line, Line)] + deriving (Show) + +foldSegments :: Int -> Double -> [Line] -> [Line] -> ([RubySegment], [Line]) +foldSegments wmode bodySize rubyPool = + go rubyPool + where + go pool [] = ([], pool) + go pool (b:bs) = + case findRubyForBody wmode pool b of + Nothing -> + let (plain, rest) = span (\l' -> case findRubyForBody wmode pool l' of Nothing -> True; _ -> False) (b:bs) + (rest', pool') = go pool (drop (length plain) (b:bs)) + in (map PlainSeg plain ++ rest', pool') + Just r -> + let (cluster, restBs, pool') = spanCluster wmode bodySize (removeRubyLine r pool) r b bs + (rest', pool'') = go pool' restBs + in (ClusterSeg cluster : rest', pool'') + +spanCluster :: Int -> Double -> [Line] -> Line -> Line -> [Line] + -> ([(Line, Line)], [Line], [Line]) +spanCluster wmode bodySize pool r b bs = + go pool [(b, r)] bs + where + go rp pairs (b':bs') = + case findRubyForBody wmode rp b' of + Just r' | clusterContinuation (fst (last pairs)) b' -> + go (removeRubyLine r' rp) ((b', r') : pairs) bs' + _ -> (reverse pairs, b' : bs', rp) + go rp pairs [] = (reverse pairs, [], rp) + +renderRubySegments :: Bool -> [RubySegment] -> T.Text +renderRubySegments includeRuby = + T.concat . map renderSeg + where + renderSeg (PlainSeg l) = T.strip (lineText l) + renderSeg (ClusterSeg pairs) = + let base = clusterBaseText pairs + ruby = clusterRubyText pairs + suffix = clusterSuffixText pairs + marked = + if includeRuby + then aozoraRuby base ruby + else base + in marked `T.append` suffix + +rubyAlignsWithParent :: Int -> Line -> Line -> Bool +rubyAlignsWithParent wmode ruby parent = + let bodySize = lineSize parent + offset = rubyOffset wmode parent ruby + overlap = rubyOverlapFrac wmode ruby parent + in lineSize ruby <= 0.85 * bodySize + && offset > 0.15 * bodySize && offset <= 1.2 * bodySize + && overlap >= 0.2 + +rubyOverlapFrac :: Int -> Line -> Line -> Double +rubyOverlapFrac _ ruby parent = + let rLo = min (lineInlineStart ruby) (lineInlineEnd ruby) + rHi = max (lineInlineStart ruby) (lineInlineEnd ruby) + bLo = min (lineInlineStart parent) (lineInlineEnd parent) + bHi = max (lineInlineStart parent) (lineInlineEnd parent) + lo = max rLo bLo + hi = min rHi bHi + overlap = max 0 (hi - lo) + span = max (rHi - rLo) 1 + in overlap / span + +rubyOffset :: Int -> Line -> Line -> Double +rubyOffset wmode parent ruby = + if wmode == 1 + then lineBaseline parent - lineBaseline ruby + else lineBaseline ruby - lineBaseline parent + +inlineOverlapFrac :: Int -> Line -> Line -> Double +inlineOverlapFrac _ a b = + let aLo = min (lineInlineStart a) (lineInlineEnd a) + aHi = max (lineInlineStart a) (lineInlineEnd a) + bLo = min (lineInlineStart b) (lineInlineEnd b) + bHi = max (lineInlineStart b) (lineInlineEnd b) + lo = max aLo bLo + hi = min aHi bHi + overlap = max 0 (hi - lo) + span = max (bHi - bLo) 1 + in overlap / span + +-- Footnote heuristic (horizontal pages only): small-size lines in the +-- bottom band (or under a bottom horizontal rule) that start with a +-- marker such as †2 form footnote blocks; matching superscript markers +-- in the body are replaced with .... +inlineFootnotes :: [Rect] -> [Line] -> [Line] +inlineFootnotes graphics ls + | null ls = ls + | otherwise = + let bodySize = medianOf (map lineSize ls) + (lo, hi) = pageBaselineExtent ls + bandTop = lo + 0.35 * (hi - lo) + ruleYs = + [ max (rectY0 r) (rectY1 r) + | r <- graphics + , rectHeight r < 1 + , rectWidth r >= 40 + , min (rectY0 r) (rectY1 r) <= bandTop + ] + isSmall l = lineSize l <= 0.85 * bodySize + inRegion l = + isSmall l + && (lineBaseline l <= bandTop || any (> lineBaseline l) ruleYs) + tagged = [(inRegion l, l) | l <- ls] + regionLines = [l | (True, l) <- tagged] + blocks = footnoteBlocks regionLines + (consumedIdx, replaceBody) = matchAnchors blocks [l | (False, l) <- tagged] + consumedLines = S.fromList + [ i + | (bi, (_, _, lineIdxs)) <- zip [0 :: Int ..] blocks + , bi `S.member` consumedIdx + , i <- lineIdxs + ] + keep (i, (inR, l)) + | inR = not (regionIndexOf i `S.member` consumedLines) + | otherwise = True + regionIndexOf i = + length [() | (j, (True, _)) <- zip [0 ..] tagged, j < i] + in [ if inR then l else replaceBody l + | (i, (inR, l)) <- zip [0 :: Int ..] tagged + , keep (i, (inR, l)) + ] + +-- Blocks: (marker key, body text, indexes into the region line list). +footnoteBlocks :: [Line] -> [(T.Text, T.Text, [Int])] +footnoteBlocks regionLines = go (zip [0 ..] regionLines) + where + go [] = [] + go ((i, l) : rest) = + case blockStart l of + Nothing -> go rest + Just (key, firstText) -> + let (cont, rest') = break (\(_, l') -> blockStart l' /= Nothing) rest + bodyLines = firstText : map (T.strip . lineText . snd) cont + body = T.strip (foldl' cjkJoin T.empty bodyLines) + in (key, body, i : map fst cont) : go rest' + + cjkJoin a b + | T.null a = b + | T.null b = a + | otherwise = + let sep = paraJoinSep (T.stripEnd a) (T.stripStart b) + in if T.null sep + then a `T.append` b + else a `T.append` sep `T.append` b + +blockStart :: Line -> Maybe (T.Text, T.Text) +blockStart l = + case [mt | (0, mt) <- lineMarkers l] of + mt : _ | Just key <- markerKey mt -> + Just (key, T.strip (T.drop (T.length mt) (lineText l))) + _ -> + let t = T.stripStart (lineText l) + in case T.uncons t of + Just (c, rest) + | c `elem` ("\8224\8225*\8251" :: String) -> + let (ds, rest') = T.span isAsciiDigit rest + in if not (T.null ds) && T.length ds <= 3 + then Just (T.cons c ds, T.strip rest') + else Nothing + _ -> Nothing + +-- Anchor pass: returns consumed block indexes and a body-line rewriter. +matchAnchors :: [(T.Text, T.Text, [Int])] -> [Line] -> (S.Set Int, Line -> Line) +matchAnchors blocks bodyLines = + let anchors = + [ key + | l <- bodyLines + , (_, mt) <- lineMarkers l + , Just key <- [markerKey mt] + ] + assign consumed [] = consumed + assign consumed (key : rest) = + case [ bi + | (bi, (bkey, _, _)) <- zip [0 ..] blocks + , bkey == key + , not (bi `S.member` S.map fst consumed) + ] of + bi : _ -> assign (S.insert (bi, key) consumed) rest + [] -> assign consumed rest + consumedPairs = assign S.empty anchors + consumedIdx = S.map fst consumedPairs + bodyOf key = + case [ (bi, b) + | (bi, (bkey, b, _)) <- zip [0 ..] blocks + , bkey == key + , bi `S.member` consumedIdx + ] of + (_, b) : _ -> Just b + [] -> Nothing + rewrite l = + let (txt', finalPos, _) = + foldl' step (T.empty, 0, S.empty) (lineMarkers l) + step (acc, pos, used) (off, mt) = + let pre = T.take (off - pos) (T.drop pos (lineText l)) + after = off + T.length mt + in case markerKey mt of + Just key + | not (key `S.member` used) + , Just b <- bodyOf key -> + ( T.concat [acc, pre, "", b, ""] + , after + , S.insert key used + ) + _ -> (acc `T.append` pre `T.append` mt, after, used) + rest = T.drop finalPos (lineText l) + in if null (lineMarkers l) + then l + else l {lineText = txt' `T.append` rest, lineMarkers = []} + in (consumedIdx, rewrite) + +markerKey :: T.Text -> Maybe T.Text +markerKey mt = + let s = T.filter (not . isSpace) mt + in case T.uncons s of + Just (c, rest) + | c `elem` ("\8224\8225*\8251" :: String) + , digits rest -> Just s + _ | digits s -> Just s + _ -> Nothing + where + digits d = not (T.null d) && T.length d <= 3 && T.all isAsciiDigit d + +isAsciiDigit :: Char -> Bool +isAsciiDigit c = c >= '0' && c <= '9' + +medianOf :: [Double] -> Double +medianOf xs = + case sort xs of + [] -> 0 + sorted -> + let n = length sorted + mid = n `div` 2 + in if odd n + then sorted !! mid + else (sorted !! (mid - 1) + sorted !! mid) / 2 + +pageLinesRaw :: [PageItem] -> PageLines +pageLinesRaw items = + let glyphs = [g | ItemGlyph g <- items] + graphics = [r | ItemGraphic r <- items] + in if null glyphs + then PageFallback [] + else if fallbackNeeded glyphs + then PageFallback [fallbackText glyphs] + else let visible = filterPageGlyphs glyphs + wmode = dominantWMode visible + pageBounds = pageExtents visible + ls = map fixDingbatBulletLine (buildLines visible) + in PageNormal wmode graphics pageBounds ls + +linesFromGlyphs :: [Glyph] -> [Line] +linesFromGlyphs = buildLines + +-- RTL horizontal text is not supported; only LTR horizontal and vertical CJK. +sortLinesByReadingOrder :: [Line] -> [Line] +sortLinesByReadingOrder [] = [] +sortLinesByReadingOrder ls = + let (w0, w1) = partition ((== 0) . lineWMode) ls + sortHoriz = sortOn (\l -> (Down (lineBaseline l), lineFirstInline l)) + sortVert = sortOn (\l -> (Down (lineBaseline l), Down (lineFirstInline l))) + in if null w0 || null w1 + then if null w1 then sortHoriz w0 else sortVert w1 + else sortHoriz w0 ++ sortVert w1 + where + sortOn f = sortBy (comparing f) + +stripHeadersFooters :: Int -> [[Line]] -> [[Line]] +stripHeadersFooters pageCount pagesLines = + let threshold = + let raw = ceiling (0.2 * fromIntegral pageCount :: Double) :: Int + in max 3 (min raw 5) + pageInfos = + [ (ls, pageBaselineExtent ls) + | ls <- pagesLines + , not (null ls) + ] + topCounts = countBandCores Top pageInfos + bottomCounts = countBandCores Bottom pageInfos + repeatedTop = repeatedCores threshold pageCount topCounts + repeatedBottom = repeatedCores threshold pageCount bottomCounts + in map (filterLine repeatedTop repeatedBottom) pagesLines + where + filterLine repTop repBottom ls + | length ls <= 2 = + let extent = pageBaselineExtent ls + in if any (isRemoved repTop repBottom extent) ls + then filter (not . isRemoved repTop repBottom extent) ls + else ls + | otherwise = + let extent = pageBaselineExtent ls + in filter (not . isRemoved repTop repBottom extent) ls + + isRemoved repTop repBottom extent l = + let band = lineBand extent l + norm = normalizeHeaderFooterText (lineText l) + in shouldRemove band norm pageCount repTop repBottom + + repeatedCores thresh n counts + | n >= 3 = + S.fromList [ core | (core, c) <- M.toList counts, c >= thresh ] + | otherwise = S.empty + +countBandCores :: Band -> [([Line], (Double, Double))] -> M.Map T.Text Int +countBandCores band pageInfos = + M.fromListWith (+) + [ (headerFooterCore (lineText l), 1) + | (ls, extent) <- pageInfos + , l <- ls + , lineBand extent l == band + ] + +headerFooterCore :: T.Text -> T.Text +headerFooterCore = T.filter (/= '#') . normalizeHeaderFooterText + +shouldRemove :: Band -> T.Text -> Int -> S.Set T.Text -> S.Set T.Text -> Bool +shouldRemove band norm pageCount repTop repBottom + | band == Middle = False + | isBarePageNumber norm = pageCount >= 2 + | otherwise = + let core = headerFooterCore norm + repeated = case band of + Top -> repTop + Bottom -> repBottom + Middle -> S.empty + in S.member core repeated + +data Band = Top | Bottom | Middle + deriving (Eq, Ord, Show) + +lineBand :: (Double, Double) -> Line -> Band +lineBand (lo, hi) l = + let bl = lineBaseline l + span = hi - lo + in if span <= 0 + then Middle + else if bl >= hi - 0.15 * span + then Top + else if bl <= lo + 0.15 * span + then Bottom + else Middle + +pageBaselineExtent :: [Line] -> (Double, Double) +pageBaselineExtent ls = + let baselines = map lineBaseline ls + in (minimum baselines, maximum baselines) + +normalizeHeaderFooterText :: T.Text -> T.Text +normalizeHeaderFooterText = + replaceRomanNumerals . replaceAsciiDigits . T.filter (not . isSpace) + +replaceAsciiDigits :: T.Text -> T.Text +replaceAsciiDigits t = + let chars = T.unpack t + (out, _) = foldl' go ([], False) chars + in T.pack (reverse out) + where + go (acc, inRun) c + | c >= '0' && c <= '9' = + if inRun then (acc, True) else ('#' : acc, True) + | otherwise = (c : acc, False) + +replaceRomanNumerals :: T.Text -> T.Text +replaceRomanNumerals t = T.pack (go (T.unpack t) []) + where + go [] acc = reverse acc + go (c : cs') acc = + let (tok, rest) = span isRomanDigit (c : cs') + in if not (null tok) && length tok <= 7 + then go rest ('#' : acc) + else go cs' (c : acc) + +isRomanDigit :: Char -> Bool +isRomanDigit c = c `elem` ("ivxlcdmIVXLCDM" :: String) + +isBarePageNumber :: T.Text -> Bool +isBarePageNumber t = + not (T.null t) + && T.any (=='#') t + && T.all (\c -> c == '#' || c `elem` ("-/." :: String)) t + +pageBoundaryBreak :: T.Text -> Line -> Double -> Line -> Line -> Bool +pageBoundaryBreak paraSoFar firstLine pageMinInline lastLine firstLine' = + endsWithTerminal paraSoFar + || indentPageBreak pageMinInline firstLine + || abs (lineSize firstLine' - lineSize lastLine) + > 0.15 * max (lineSize firstLine') (lineSize lastLine) + || lineWMode lastLine /= lineWMode firstLine' + +fallbackNeeded :: [Glyph] -> Bool +fallbackNeeded glyphs = + let n = length glyphs + usable = length (filter usableGlyph glyphs) + in n == 0 || fromIntegral usable / fromIntegral n < 0.7 + +fallbackText :: [Glyph] -> T.Text +fallbackText = T.intercalate "\n" . map glyphText + +usableGlyph :: Glyph -> Bool +usableGlyph g = + glyphSize g > 0 + && not (isNaN (glyphX g) || isInfinite (glyphX g)) + && not (isNaN (glyphY g) || isInfinite (glyphY g)) + +-- | Drop coordinate outliers (e.g. footnote digits emitted far off-page). +filterPageGlyphs :: [Glyph] -> [Glyph] +filterPageGlyphs glyphs = + let horizVis = [g | g <- glyphs, glyphWMode g == 0, glyphY g >= 0] + vert = [g | g <- glyphs, glyphWMode g == 1] + horizBand = baselineBand glyphY glyphSize horizVis + vertBand = baselineBand (baselineOf 1) glyphSize vert + in filter (glyphInBand horizBand vertBand) glyphs + where + glyphInBand hBand vBand g + | glyphWMode g == 1 = inBand (baselineOf 1) vBand g + | otherwise = inBand glyphY hBand g + + inBand measure band g = + let v = measure g + in v >= 0 && case band of + Nothing -> True + Just (lo, hi) -> v >= lo && v <= hi + + baselineBand measure sizeOf gs = + let ys = sort (map measure gs) + in if length ys < 4 + then Nothing + else let q1 = quantile 0.25 ys + q3 = quantile 0.75 ys + iqr = q3 - q1 + medSize = medianOf (map sizeOf gs) + spread = max (max 1 iqr) (1.2 * medSize) + pad = 3 * spread + in Just (q1 - pad, q3 + pad) + + quantile q xs = + let n = length xs + i = min (n - 1) (max 0 (truncate (q * fromIntegral (n - 1)))) + in xs !! i + +dominantWMode :: [Glyph] -> Int +dominantWMode glyphs = + let counts = foldr (\g m -> M.insertWith (+) (glyphWMode g) 1 m) M.empty glyphs + in if M.null counts + then 0 + else fst (maximumBy (comparing snd) (M.toList counts)) + +pageExtents :: [Glyph] -> (Double, Double) +pageExtents glyphs = + let xs = concatMap (\g -> [glyphX g, glyphX g + glyphWidth g]) glyphs + ys = map glyphY glyphs + in (max 1 (maximum xs - minimum xs), max 1 (maximum ys - minimum ys)) + +baselineOf :: Int -> Glyph -> Double +baselineOf wmode g = if wmode == 1 then glyphX g else glyphY g + +inlineStartOf :: Int -> Glyph -> Double +inlineStartOf wmode g = if wmode == 1 then glyphY g else glyphX g + +inlineEndOf :: Int -> Glyph -> Double +inlineEndOf wmode g = + if wmode == 1 + then glyphY g - glyphWidth g + else glyphX g + glyphWidth g + +data Line = Line + { lineBaseline :: !Double + , lineInlineStart :: !Double + , lineInlineEnd :: !Double + , lineSize :: !Double + , lineFirstInline :: !Double + , lineWMode :: !Int + , lineText :: !T.Text + , lineMarkers :: [(Int, T.Text)] + , lineLastSuper :: !Bool + } deriving (Show) + +buildLines :: [Glyph] -> [Line] +buildLines = reverse . foldl' go [] + where + go [] g = [newLine g] + go (l:ls) g + | glyphWMode g /= lineWMode l = newLine g : l : ls + | superAttach = mergeSuper l g : ls + | rebaseAttach = mergeRebase l g : ls + | abs d <= 0.4 * max (glyphSize g) (lineSize l) = mergeGlyph l g : ls + | otherwise = newLine g : l : ls + where + d = baselineOf (lineWMode l) g - lineBaseline l + gap = inlineStartOf (lineWMode l) g - lineInlineEnd l + inlineCont refSize = gap >= -0.5 * refSize && gap <= 2.0 * refSize + superAttach = + glyphSize g <= 0.92 * lineSize l + && glyphSize g >= 0.5 * lineSize l + && inlineCont (lineSize l) + && ((d > 0.25 * lineSize l && d <= 0.75 * lineSize l) + || ((-d) > 0.25 * lineSize l && (-d) <= 0.4 * lineSize l)) + rebaseAttach = + lineSize l <= 0.92 * glyphSize g + && lineSize l >= 0.5 * glyphSize g + && inlineCont (glyphSize g) + && (((-d) > 0.25 * glyphSize g && (-d) <= 0.75 * glyphSize g) + || (d > 0.25 * glyphSize g && d <= 0.4 * glyphSize g)) + +newLine :: Glyph -> Line +newLine g = + Line + { lineBaseline = baselineOf (glyphWMode g) g + , lineInlineStart = inlineStartOf (glyphWMode g) g + , lineInlineEnd = inlineEndOf (glyphWMode g) g + , lineSize = glyphSize g + , lineFirstInline = inlineStartOf (glyphWMode g) g + , lineWMode = glyphWMode g + , lineText = glyphText g + , lineMarkers = [] + , lineLastSuper = False + } + +mergeGlyph :: Line -> Glyph -> Line +mergeGlyph line g = + let w = lineWMode line + gap = inlineStartOf w g - lineInlineEnd line + size = max (glyphSize g) (lineSize line) + space = intraLineSpace gap size (lastChar (lineText line)) (firstChar (glyphText g)) + in line + { lineInlineEnd = inlineEndOf w g + , lineInlineStart = min (lineInlineStart line) (inlineStartOf w g) + , lineSize = size + , lineText = lineText line `T.append` space `T.append` glyphText g + , lineLastSuper = False + } + +mergeSuper :: Line -> Glyph -> Line +mergeSuper line g = + let w = lineWMode line + gap = inlineStartOf w g - lineInlineEnd line + space = intraLineSpace gap (lineSize line) (lastChar (lineText line)) (firstChar (glyphText g)) + offset = T.length (lineText line) + T.length space + markers = + if lineLastSuper line + then case reverse (lineMarkers line) of + (off, mt) : restRev -> + reverse ((off, mt `T.append` space `T.append` glyphText g) : restRev) + [] -> [(offset, glyphText g)] + else lineMarkers line ++ [(offset, glyphText g)] + in line + { lineInlineEnd = inlineEndOf w g + , lineInlineStart = min (lineInlineStart line) (inlineStartOf w g) + , lineText = lineText line `T.append` space `T.append` glyphText g + , lineMarkers = markers + , lineLastSuper = True + } + +mergeRebase :: Line -> Glyph -> Line +mergeRebase line g = + let w = lineWMode line + gap = inlineStartOf w g - lineInlineEnd line + space = intraLineSpace gap (glyphSize g) (lastChar (lineText line)) (firstChar (glyphText g)) + in line + { lineBaseline = baselineOf w g + , lineSize = glyphSize g + , lineInlineEnd = inlineEndOf w g + , lineInlineStart = min (lineInlineStart line) (inlineStartOf w g) + , lineText = lineText line `T.append` space `T.append` glyphText g + , lineMarkers = [(0, lineText line)] + , lineLastSuper = False + } + +joinGlyphsRun :: [Glyph] -> T.Text +joinGlyphsRun [] = T.empty +joinGlyphsRun (g : gs) = + let (txt, _) = foldl' go (glyphText g, g) gs + in txt + where + go (acc, prev) g' = + let wmode = glyphWMode g' + gap = inlineStartOf wmode g' - inlineEndOf wmode prev + size = max (glyphSize g') (glyphSize prev) + space = intraLineSpace gap size (lastChar acc) (firstChar (glyphText g')) + in (acc `T.append` space `T.append` glyphText g', g') + +intraLineSpace :: Double -> Double -> Maybe Char -> Maybe Char -> T.Text +intraLineSpace gap size mc nc + | mc == Just '-' || nc == Just '-' = "" + | latinAdjacent mc nc, gap >= 0.25 * size = " " + | gap > 2.0 * size = " " + | gap > 0.3 * size, not (cjkAdjacent mc nc) = " " + | otherwise = "" + +isLatinLetter :: Char -> Bool +isLatinLetter c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') + +latinAdjacent :: Maybe Char -> Maybe Char -> Bool +latinAdjacent (Just a) (Just b) = + not (isCJK a || isCJK b) && (isLatinLetter a || isLatinLetter b) +latinAdjacent _ _ = False + +hyphenContinues :: Char -> Bool +hyphenContinues c = c == '-' || c == '\x00AD' + +paraJoinSep :: T.Text -> T.Text -> T.Text +paraJoinSep a' b' + | not (T.null a') && not (T.null b') + && isCJK (T.last a') && isCJK (T.head b') = T.empty + | not (T.null a') && hyphenContinues (T.last a') = T.empty + | otherwise = " " + +lastChar :: T.Text -> Maybe Char +lastChar t = if T.null t then Nothing else Just (T.last t) + +firstChar :: T.Text -> Maybe Char +firstChar t = if T.null t then Nothing else Just (T.head t) + +cjkAdjacent :: Maybe Char -> Maybe Char -> Bool +cjkAdjacent (Just a) (Just b) = isCJK a && isCJK b +cjkAdjacent _ _ = False + +isCJK :: Char -> Bool +isCJK c = + let cp = ord c + in (cp >= 0x4E00 && cp <= 0x9FFF) + || (cp >= 0x3040 && cp <= 0x309F) + || (cp >= 0x30A0 && cp <= 0x30FF) + || (cp >= 0x3000 && cp <= 0x303F) + || (cp >= 0xFF00 && cp <= 0xFFEF) + +listMarkerStart :: Line -> Bool +listMarkerStart l = + let t = T.stripStart (lineText l) + in letteredMarker t || numberedListMarker t + where + letteredMarker t = + case T.uncons t of + Just (c, rest) | c >= 'a' && c <= 'z' -> + case T.uncons (T.stripStart rest) of + Just ('.', _) -> True + _ -> False + _ -> False + numberedListMarker t = + case T.uncons t of + Just (c, rest) | isDigit c -> + case T.span isDigit t of + (ds, rest') -> + not (T.null ds) + && T.length ds <= 2 + && case T.uncons (T.stripStart rest') of + Just ('.', _) -> True + _ -> False + _ -> False + +hangWrappedContinuation :: Line -> Line -> Bool +hangWrappedContinuation prev cur = + lineFirstInline cur > lineFirstInline prev + 0.6 * lineSize prev + +afterListHeadingBreak :: Int -> Line -> Line -> [Double] -> Bool +afterListHeadingBreak wmode prev cur gaps = + listMarkerStart prev + && not (hangWrappedContinuation prev cur) + && abs (baselineGap wmode prev cur) + >= 0.75 * typicalLeading gaps (lineSize cur) + +listItemEnd :: Line -> Bool +listItemEnd l = + let t = T.strip (lineText l) + in T.isSuffixOf "こと" t || endsWithTerminal t + +sameHangListItemBreak :: Int -> Line -> Line -> [Double] -> Bool +sameHangListItemBreak wmode prev cur gaps + | isCodeLine prev || isCodeLine cur = False + | not (listItemEnd prev) = False + | otherwise = + let gap = abs (baselineGap wmode prev cur) + typical = typicalLeading gaps (lineSize cur) + tol = 0.35 * lineSize cur + in cjkAdjacent (lastChar (lineText prev)) (firstChar (lineText cur)) + && abs (lineFirstInline cur - lineFirstInline prev) <= tol + && gap >= 0.85 * typical + && not (hangWrappedContinuation prev cur) + +isNumberedCodeLine :: Line -> Bool +isNumberedCodeLine l = numberedCodeStart (T.stripStart (lineText l)) + +numberedCodeStart :: T.Text -> Bool +numberedCodeStart t = + case T.uncons t of + Just (c, rest) | isDigit c -> + case T.span isDigit t of + (ds, rest') -> + not (T.null ds) + && case T.uncons (T.stripStart rest') of + Just (codeSep, _) + | codeSep == ' ' || codeSep == '.' -> True + _ -> False + _ -> False + +isCodeLine :: Line -> Bool +isCodeLine l = + isNumberedCodeLine l + || (lineSize l <= 7.5 && smallMonospaceLine l && highLatinFraction (lineText l)) + +smallMonospaceLine :: Line -> Bool +smallMonospaceLine l = + let t = T.strip (lineText l) + in not (T.null t) + && lineSize l > 0 + && T.any isLatinLetter t + && not (T.any isCJK t) + +highLatinFraction :: T.Text -> Bool +highLatinFraction t = + let chars = filter (not . isSpace) (T.unpack t) + latin = length (filter isLatinLetter chars) + in not (null chars) && fromIntegral latin / fromIntegral (length chars) >= 0.5 + +codeBlockBreak :: Line -> Line -> Bool +codeBlockBreak prev cur = + isCodeLine cur /= isCodeLine prev + +codeIndentSpaces :: Double -> Double -> Line -> T.Text +codeIndentSpaces minX charW l = + let offset = max 0 (lineFirstInline l - minX) + n = truncate (offset / max charW 1) + in T.replicate n " " + +joinCodeLines :: [Line] -> T.Text +joinCodeLines ls = + let minX = minimum (map lineFirstInline ls) + charW = minimum (map (max 1 . (* 0.55) . lineSize) ls) + in T.intercalate "\n" + [ codeIndentSpaces minX charW l `T.append` T.strip (lineText l) + | l <- ls + ] + +groupParagraphs :: Int -> [Rect] -> (Double, Double) -> [Line] -> [[Line]] +groupParagraphs wmode graphics bounds lines = + go [] (filter (not . T.null . T.strip . lineText) (sortLinesByReadingOrder lines)) + where + go _ [] = [] + go pageGaps (l:ls) = + let (para, rest, pageGaps') = takeParagraph pageGaps l ls + in para : go pageGaps' rest + + takeParagraph pageGaps first rest = + let (paraLines, rest', pageGaps') = + spanLines pageGaps first rest [first] (lineInlineStart first) + in (paraLines, rest', pageGaps') + + spanLines pageGaps prev rest acc minInline = + case rest of + [] -> (reverse acc, [], pageGaps) + (l:ls) -> + if paragraphBreak wmode graphics bounds prev l pageGaps minInline + then (reverse acc, l:ls, pageGaps) + else let g = baselineGap wmode prev l + pageGaps' = if g > 0 then pageGaps ++ [g] else pageGaps + minInline' = min minInline (lineInlineStart l) + in spanLines pageGaps' l ls (l:acc) minInline' + +paragraphBreak :: Int -> [Rect] -> (Double, Double) -> Line -> Line -> [Double] -> Double -> Bool +paragraphBreak wmode graphics pageBounds prev cur gaps paraMinInline = + let gap = baselineGap wmode prev cur + typical = typicalLeading gaps (lineSize cur) + gapBreak = abs gap > 1.6 * typical + in negativeAdvance wmode prev cur + || listMarkerStart cur + || afterListHeadingBreak wmode prev cur gaps + || sameHangListItemBreak wmode prev cur gaps + || codeBlockBreak prev cur + || (gapBreak && not (cjkWrapContinuation prev cur)) + || indentBreak paraMinInline cur + || (graphicBreak wmode graphics pageBounds prev cur + && not (cjkWrapContinuation prev cur)) + +cjkWrapContinuation :: Line -> Line -> Bool +cjkWrapContinuation prev cur = + case (lastChar (lineText prev), firstChar (lineText cur)) of + (Just a, Just b) -> + isCJK a && isCJK b && not (endsWithTerminal (lineText prev)) + _ -> False + +fixDingbatBulletLine :: Line -> Line +fixDingbatBulletLine l = l {lineText = fixDingbatBullet (lineText l)} + +fixDingbatBullet :: T.Text -> T.Text +fixDingbatBullet t = + let open = T.singleton '\x300c' + t1 = fixPrefix t + in T.replace (T.pack " r" `T.append` open) (T.pack " \8226" `T.append` open) t1 + where + fixPrefix t = + case T.uncons t of + Just ('r', rest) -> + case T.uncons rest of + Just ('\x300c', _) -> T.cons '\x2022' rest + Just (' ', rest') -> + case T.uncons rest' of + Just (c, _) | not (isLowerLatin c) -> T.cons '\x2022' (T.cons ' ' rest') + _ -> t + Nothing -> T.singleton '\x2022' + _ -> t + _ -> t + isLowerLatin c = c >= 'a' && c <= 'z' + +baselineGap :: Int -> Line -> Line -> Double +baselineGap wmode prev cur = lineBaseline prev - lineBaseline cur + +negativeAdvance :: Int -> Line -> Line -> Bool +negativeAdvance wmode prev cur = baselineGap wmode prev cur < 0 + +typicalLeading :: [Double] -> Double -> Double +typicalLeading gaps lineSize = + case sort (filter (> 0) gaps) of + [] -> 1.2 * lineSize + [_] -> 1.2 * lineSize + gs -> + let mid = length gs `div` 2 + in if odd (length gs) + then gs !! mid + else (gs !! (mid - 1) + gs !! mid) / 2 + +indentBreak :: Double -> Line -> Bool +indentBreak paraMinInline cur = + lineFirstInline cur - paraMinInline >= 0.85 * lineSize cur + +indentPageBreak :: Double -> Line -> Bool +indentPageBreak pageMinInline cur = + lineFirstInline cur - pageMinInline >= 0.85 * lineSize cur + +graphicBreak :: Int -> [Rect] -> (Double, Double) -> Line -> Line -> Bool +graphicBreak wmode graphics pageBounds prev cur = + any (separatesLines wmode pageW pageH prev cur) (candidatesBetween wmode prev cur pageBounds graphics) + where + (pageW, pageH) = pageBounds + +candidatesBetween :: Int -> Line -> Line -> (Double, Double) -> [Rect] -> [Rect] +candidatesBetween wmode prev cur (pageW, pageH) graphics = + let tol = 0.2 * lineSize cur + lo = min (lineBaseline prev) (lineBaseline cur) - tol + hi = max (lineBaseline prev) (lineBaseline cur) + tol + in filter (graphicCandidate wmode pageW pageH lo hi) graphics + +graphicCandidate :: Int -> Double -> Double -> Double -> Double -> Rect -> Bool +graphicCandidate wmode pageW pageH lo hi r = + let bigEnough = rectWidth r > 0.8 * pageW && rectHeight r > 0.8 * pageH + tiny = rectWidth r < 0.5 && rectHeight r < 0.5 + rLo = if wmode == 1 then min (rectX0 r) (rectX1 r) else min (rectY0 r) (rectY1 r) + rHi = if wmode == 1 then max (rectX0 r) (rectX1 r) else max (rectY0 r) (rectY1 r) + in not bigEnough && not tiny && rLo <= hi && rHi >= lo + +separatesLines :: Int -> Double -> Double -> Line -> Line -> Rect -> Bool +separatesLines wmode _pageW _pageH prev cur r = + inlineOverlap wmode prev cur r + +rectWidth :: Rect -> Double +rectWidth r = abs (rectX1 r - rectX0 r) + +rectHeight :: Rect -> Double +rectHeight r = abs (rectY1 r - rectY0 r) + +inlineOverlap :: Int -> Line -> Line -> Rect -> Bool +inlineOverlap wmode prev cur r = + let unionLo = min (lineInlineStart prev) (lineInlineStart cur) + unionHi = max (lineInlineEnd prev) (lineInlineEnd cur) + unionLen = max 0 (unionHi - unionLo) + (rLo, rHi) = rectInlineRange wmode r + overlap = max 0 (min unionHi rHi - max unionLo rLo) + in unionLen <= 0 || overlap / unionLen >= 0.2 + +rectInlineRange :: Int -> Rect -> (Double, Double) +rectInlineRange wmode r = + if wmode == 1 + then (min (rectY0 r) (rectY1 r), max (rectY0 r) (rectY1 r)) + else (min (rectX0 r) (rectX1 r), max (rectX0 r) (rectX1 r)) + +joinParaLines :: [Line] -> T.Text +joinParaLines [] = T.empty +joinParaLines ls + | all isCodeLine ls = joinCodeLines ls + | otherwise = + T.strip $ foldl1 mergeText (map (T.strip . lineText) ls) + where + mergeText a b = + let a' = T.stripEnd a + b' = T.stripStart b + in a' `T.append` paraJoinSep a' b' `T.append` b' + +terminalChars :: String +terminalChars = "。．！？!?…" + +closingChars :: String +closingChars = "」』）)]】〉》\"'" + +endsWithTerminal :: T.Text -> Bool +endsWithTerminal t = endsWithTerminal' (T.strip t) + where + endsWithTerminal' s + | T.null s = False + | otherwise = + case T.unsnoc s of + Nothing -> False + Just (init, c) + | c `elem` closingChars -> endsWithTerminal' init + | c `elem` terminalChars -> True + | otherwise -> False diff --git a/src/PDF/Matrix.hs b/src/PDF/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/PDF/Matrix.hs @@ -0,0 +1,45 @@ +module PDF.Matrix + ( Matrix(..) + , identity + , mkMatrix + , multiply + , apply + , applyVec + , translate + , scale + , components + ) where + +data Matrix = Matrix !Double !Double !Double !Double !Double !Double + deriving (Eq, Show) + +identity :: Matrix +identity = mkMatrix 1 0 0 1 0 0 + +mkMatrix :: Double -> Double -> Double -> Double -> Double -> Double -> Matrix +mkMatrix = Matrix + +multiply :: Matrix -> Matrix -> Matrix +multiply (Matrix a1 b1 c1 d1 e1 f1) (Matrix a2 b2 c2 d2 e2 f2) = + Matrix + (a1 * a2 + b1 * c2) + (a1 * b2 + b1 * d2) + (c1 * a2 + d1 * c2) + (c1 * b2 + d1 * d2) + (e1 * a2 + f1 * c2 + e2) + (e1 * b2 + f1 * d2 + f2) + +apply :: Matrix -> (Double, Double) -> (Double, Double) +apply (Matrix a b c d e f) (x, y) = (a * x + c * y + e, b * x + d * y + f) + +applyVec :: Matrix -> (Double, Double) -> (Double, Double) +applyVec (Matrix a b c d _ _) (x, y) = (a * x + c * y, b * x + d * y) + +translate :: Double -> Double -> Matrix +translate tx ty = mkMatrix 1 0 0 1 tx ty + +scale :: Double -> Double -> Matrix +scale sx sy = mkMatrix sx 0 0 sy 0 0 + +components :: Matrix -> (Double, Double, Double, Double, Double, Double) +components (Matrix a b c d e f) = (a, b, c, d, e, f) diff --git a/src/PDF/Object.hs b/src/PDF/Object.hs --- a/src/PDF/Object.hs +++ b/src/PDF/Object.hs @@ -16,31 +16,49 @@ , parsePDFObj , parseRefsArray , pdfObj + , objectBody + , sliceObjectAt + , collectPDFObjs , pdfletters , pdfarray , pdfdictionary + , pdfstream , xref - , ) where import Data.Char (chr) +import qualified Data.Map as M import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.Text as T import Data.Text.Encoding (decodeUtf16BEWith) import Data.Text.Encoding.Error (strictDecode) -import Numeric (readOct, readHex) +import Numeric (readOct, readHex, readDec) import Data.ByteString.Builder (toLazyByteString, word16BE) -import Data.Attoparsec.ByteString.Char8 hiding (take) +import Data.Attoparsec.ByteString.Char8 hiding (take, skipWhile, takeTill) +import qualified Data.Attoparsec.ByteString.Char8 as AP +import Data.Attoparsec.ByteString as W (skipWhile, word8, notWord8, takeTill, anyWord8) import Data.Attoparsec.Combinator import Control.Applicative +import Control.Monad (void, guard) -import Debug.Trace +import Data.Word (Word8) import PDF.Definition +import PDF.Encrypt (Security, decryptString, decryptStream) -spaces = skipMany (comment <|> oneOf pdfspaces) --skipSpace +octalCharSafe :: String -> Char +octalCharSafe ds = case readOct ds of + [(n, "")] -> chr n + _ -> '?' + +hexCharSafe :: String -> Char +hexCharSafe s = case readHex s of + [(n, "")] -> chr n + _ -> '?' + +spaces = many (comment <|> pdfspaces) oneOf = satisfy . inClass noneOf = satisfy . notInClass @@ -48,28 +66,229 @@ pdfObj :: Parser PDFBS pdfObj = do - spaces -- skipMany (comment <|> oneOf pdfspaces) - objn <- many1 digit <* (spaces >> oneOf "0123456789" >> string " obj") - object <- manyTill anyChar (try $ string "endobj") + objn <- objectHeader + (body, _) <- match (objectBody Nothing objn) spaces - skipMany xref - skipMany startxref - return $ (read objn, BS.pack object) + string "endobj" + spaces + many xref + many startxref + return (objn, body) -pdfspaces :: [Char] -pdfspaces = map chr [0, 9, 10, 12, 13, 32] +objectHeader :: Parser Int +objectHeader = do + spaces + objnStr <- many1 digit + spaces + _ <- many1 digit + string " obj" + spaces + case readDec objnStr of + [(n, "")] -> return n + _ -> fail ("invalid object number: " ++ objnStr) -parsePDFObj :: PDFBS -> PDFObj -parsePDFObj (n,pdfobject) = case parseOnly (spaces >> many1 (try pdfobj <|> try objother)) pdfobject of - Left err -> (n,[PdfNull]) - Right obj -> (n,obj) +sliceOneObject :: BS.ByteString -> Maybe ((Int, BS.ByteString), BS.ByteString) +sliceOneObject bs = case AP.parse objectSlice bs of + AP.Done rest (objn, body) -> Just ((objn, body), rest) + _ -> Nothing + where + objectSlice = do + objn <- objectHeader + (body, _) <- match (objectBody Nothing objn) + spaces + string "endobj" + return (objn, body) -comment :: Parser Char +sliceObjectAt :: BS.ByteString -> Maybe BS.ByteString +sliceObjectAt bs = fmap snd $ fmap fst $ sliceOneObject bs + +collectPDFObjs :: BS.ByteString -> [PDFBS] +collectPDFObjs bs = loop (BS.dropWhile isPdfSpaceChar bs) + where + loop rest + | BS.null rest = [] + | otherwise = case sliceOneObject rest of + Just ((n, body), after) -> (n, body) : loop (BS.dropWhile isPdfSpaceChar after) + Nothing -> [] + +isPdfSpaceChar :: Char -> Bool +isPdfSpaceChar c = c `elem` ['\0', '\t', '\n', '\f', '\r', ' '] + +pdfspaces = do + W.word8 0 <|> W.word8 9 <|> W.word8 10 <|> W.word8 12 <|> W.word8 13 <|> W.word8 32 + return "" + +objectBody :: Maybe Security -> Int -> Parser [Obj] +objectBody sec objNum = pdfobjElem sec objNum + +pdfobjElem :: Maybe Security -> Int -> Parser [Obj] +pdfobjElem sec objNum = + try (dictAndStream sec objNum) <|> + fmap (:[]) (pdfobjAtom sec objNum) + +parsePDFObj :: Maybe Security -> PDFBS -> PDFObj +parsePDFObj sec (n,pdfobject) = + case parseOnly (spaces >> objectBody sec n) pdfobject of + Left err -> (n,[PdfNull]) + Right obj -> (n, obj) + +pdfobjAtom :: Maybe Security -> Int -> Parser Obj +pdfobjAtom Nothing _ = pdfobjAtomPlain +pdfobjAtom (Just sec) objNum = choice + [ try rrefs + , try pdfname + , try pdfnumber + , try (pdfhexSec (Just sec) objNum) <* spaces + , try pdfbool <* spaces + , try pdfnull <* spaces + , try (pdfarraySec (Just sec) objNum) <* spaces + , try (pdfdictionarySec (Just sec) objNum) <* spaces + , pdflettersSec (Just sec) objNum <* spaces + ] + +pdfobjAtomPlain :: Parser Obj +pdfobjAtomPlain = choice + [ try rrefs + , try pdfname + , try pdfnumber + , try pdfhex <* spaces + , try pdfbool <* spaces + , try pdfnull <* spaces + , try pdfarray <* spaces + , try pdfdictionary <* spaces + , pdfletters <* spaces + ] + +pdfobjSec :: Maybe Security -> Int -> Parser Obj +pdfobjSec sec objNum = do + elems <- pdfobjElem sec objNum + case elems of + [o] -> return o + _ -> fail "multi-element object in nested context" + +pdfdictionarySec :: Maybe Security -> Int -> Parser Obj +pdfdictionarySec sec objNum = do + pairs <- spaces >> string "<<" >> spaces *> manyTill (dictEntrySec sec objNum) (try $ spaces >> string ">>") + return $ PdfDict (pairsToDict pairs) + +dictEntrySec :: Maybe Security -> Int -> Parser (Obj, Obj) +dictEntrySec sec objNum = (,) <$> pdfname <*> pdfobjSec sec objNum + +pdfarraySec :: Maybe Security -> Int -> Parser Obj +pdfarraySec sec objNum = + PdfArray <$> (string "[" >> spaces *> manyTill (pdfobjSec sec objNum) (try $ spaces >> string "]")) + +pdflettersSec :: Maybe Security -> Int -> Parser Obj +pdflettersSec sec objNum = PdfText <$> parsePdfLettersSec sec objNum + +parsePdfLettersSec :: Maybe Security -> Int -> Parser T.Text +parsePdfLettersSec sec objNum = do + encrypted <- pdfLiteralBytes + let body = decryptString sec objNum 0 encrypted + case parseOnly parsePdfLetters (BS.cons '(' (BS.snoc body ')')) of + Right s -> return s + Left _ -> return $ T.pack $ BS.unpack body + +pdfLiteralBytes :: Parser BS.ByteString +pdfLiteralBytes = BS.pack <$> (char '(' *> manyTill pdfEscapedChar (char ')')) + where + pdfEscapedChar = choice + [ '(' <$ try (string "\\(") + , ')' <$ try (string "\\)") + , '\\' <$ try (string "\\\\") + , '\n' <$ try (string "\\n") + , '\r' <$ try (string "\\r") + , '\t' <$ try (string "\\t") + , '\b' <$ try (string "\\b") + , '\f' <$ try (string "\\f") + , octChar <$> try (char '\\' *> count 3 (oneOf "01234567")) + , octChar <$> try (char '\\' *> count 2 (oneOf "01234567")) + , octChar . (:[]) <$> try (char '\\' *> oneOf "01234567") + , noneOf "\\" + , '\\' <$ string "\\" + ] + octChar = octalCharSafe + +pdfhexSec :: Maybe Security -> Int -> Parser Obj +pdfhexSec sec objNum = hexSec sec objNum + where hexSec sec objNum = do + char '<' + lets <- BS.pack <$> manyTill (oneOf "0123456789abcdefABCDEF") (try $ char '>') + let decrypted = decryptString sec objNum 0 (decodeHexBytes lets) + case parseOnly ((try $ string "feff" <|> string "FEFF") *> (many1 (oneOf "0123456789abcdefABCDEF"))) (BS.pack $ BS.unpack decrypted) of + Right s -> return $ PdfHex (T.pack $ pdfhexletter (BS.pack s)) + Left _ -> + case parseOnly parsePdfLetters (BS.cons '(' (BS.snoc decrypted ')')) of + Right t -> return (PdfText t) + Left _ -> return (PdfHex (T.pack $ BS.unpack decrypted)) + +decodeHexBytes :: BS.ByteString -> BS.ByteString +decodeHexBytes bs = + let hex = filter (`elem` ("0123456789abcdefABCDEF" :: String)) (BS.unpack bs) + pairs = [ take 2 (drop i hex) | i <- [0,2..length hex - 1], i + 1 < length hex ] + hexByte s = hexCharSafe s + in BS.pack $ map hexByte pairs + +lookupDictInt :: Dict -> T.Text -> Maybe Int +lookupDictInt d key = case M.lookup key d of + Just (PdfNumber x) | x >= 0 -> Just (truncate x) + _ -> Nothing + +pairsToDict :: [(Obj, Obj)] -> Dict +pairsToDict pairs = + M.fromListWith (\_new old -> old) [(n, v) | (PdfName n, v) <- pairs] + +skipStreamEOL :: Parser () +skipStreamEOL = + void $ optional $ try (string "\r\n") <|> try (string "\n") <|> try (string "\r") + +streamEndMarker :: Parser () +streamEndMarker = void $ do + optional (try (string "\r\n") <|> try (string "\n") <|> try (string "\r")) + string "endstream" + +scanTillEndstream :: Parser BS.ByteString +scanTillEndstream = go BS.empty + where + go acc = + (try $ do + guard (BS.null acc || isPdfEol (BS.last acc)) + string "endstream" + return acc) <|> + (do w <- W.anyWord8; go (BS.snoc acc (chr (fromIntegral w)))) + isPdfEol c = c == '\r' || c == '\n' + +readStreamBody :: Dict -> Parser BSL.ByteString +readStreamBody dict = do + skipStreamEOL + case lookupDictInt dict "/Length" of + Just len -> + (try $ do + data_ <- AP.take len + streamEndMarker + return $ BSL.fromStrict data_) <|> + (BSL.fromStrict <$> scanTillEndstream) + Nothing -> + BSL.fromStrict <$> scanTillEndstream + +dictAndStream :: Maybe Security -> Int -> Parser [Obj] +dictAndStream sec objNum = do + d@(PdfDict dict) <- case sec of + Nothing -> pdfdictionary + Just s -> pdfdictionarySec (Just s) objNum + spaces + more <- optional (lookAhead (string "stream")) + case more of + Nothing -> return [d] + Just _ -> do + string "stream" + stm <- readStreamBody dict + spaces + return [d, PdfStream stm] + comment = do - char '%' - noneOf "%" - manyTill anyChar $ oneOf "\r\n" - return ' ' + W.word8 37 >> W.notWord8 37 >> W.takeTill (\w-> w == 13 || w == 10) + return " " xref :: Parser String xref = do @@ -92,12 +311,12 @@ stream :: Parser PDFStream stream = do string "stream" - spaces - stm <- BSL.pack <$> manyTill anyChar (try $ string "endstream") - return stm + readStreamBody M.empty pdfdictionary :: Parser Obj -pdfdictionary = PdfDict <$> (spaces >> string "<<" >> spaces *> manyTill dictEntry (try $ spaces >> string ">>")) +pdfdictionary = do + pairs <- spaces >> string "<<" >> spaces *> manyTill dictEntry (try $ spaces >> string ">>") + return $ PdfDict (pairsToDict pairs) dictEntry :: Parser (Obj, Obj) dictEntry = (,) <$> pdfname <*> pdfobj @@ -106,17 +325,17 @@ pdfarray = PdfArray <$> (string "[" >> spaces *> manyTill pdfobj (try $ spaces >> string "]")) pdfname :: Parser Obj -pdfname = PdfName . BS.unpack <$> (BS.append <$> string "/" <*> (BS.pack <$> manyTill anyChar (try $ lookAhead $ oneOf "><][)( \n\r/"))) <* spaces +pdfname = PdfName . T.pack . BS.unpack <$> (BS.append <$> string "/" <*> (BS.pack <$> manyTill anyChar (try $ lookAhead $ oneOf "><][)( \n\r/"))) <* spaces pdfletters :: Parser Obj pdfletters = PdfText <$> parsePdfLetters -parsePdfLetters :: Parser String -parsePdfLetters = concat <$> (char '(' *> +parsePdfLetters :: Parser T.Text +parsePdfLetters = T.pack <$> (concat <$> (char '(' *> manyTill (choice [ try pdfutf , try pdfoctutf , pdfletter]) - (try $ char ')')) + (try $ char ')'))) where pdfletter = choice [ "(" <$ try (string "\\(") , ")" <$ try (string "\\)") @@ -133,7 +352,7 @@ , "" <$ string "\\" ] - octal = return . chr . fst . head . readOct + octal = return . octalCharSafe pdfutf :: Parser String pdfutf = do @@ -145,7 +364,7 @@ str <- string "\\376\\377" *> manyTill pdfletter (lookAhead $ string ")") return $ utf16be $ concat str -utf16be = T.unpack . decodeUtf16BEWith strictDecode . BS.pack +utf16be = T.unpack . decodeUtf16BEWith strictDecode . BS.pack -- used only for String concat in pdfutf pdfstream :: Parser Obj pdfstream = PdfStream <$> stream @@ -166,8 +385,8 @@ char '<' lets <- BS.pack <$> manyTill (oneOf "0123456789abcdefABCDEF") (try $ char '>') case parseOnly ((try $ string "feff" <|> string "FEFF") *> (many1 (oneOf "0123456789abcdefABCDEF"))) lets of - Right s -> return $ pdfhexletter $ BS.pack s - Left e -> return . BS.unpack $ lets + Right s -> return $ T.pack $ pdfhexletter $ BS.pack s + Left _ -> return $ T.pack $ BS.unpack lets pdfhexletter s = case parseOnly (concat <$> many1 pdfhexutf16be) s of Right t -> utf16be t @@ -176,7 +395,9 @@ pdfhexutf16be :: Parser String pdfhexutf16be = do c <- count 4 $ oneOf "0123456789ABCDEFabcdef" - let b = BSL.unpack . toLazyByteString . word16BE $ fst . head . readHex $ c + let b = case readHex c of + [(n, "")] -> BSL.unpack . toLazyByteString . word16BE $ n + _ -> "?" return $ b pdfbool :: Parser Obj @@ -188,17 +409,7 @@ pdfnull = PdfNull <$ string "null" pdfobj :: Parser Obj -pdfobj = choice [ try rrefs <* spaces - , try pdfname <* spaces - , try pdfnumber <* spaces - , try pdfhex <* spaces -- Hexadecimal String - , try pdfbool <* spaces - , try pdfnull <* spaces - , try pdfarray <* spaces - , try pdfdictionary <* spaces - , {-# SCC pdfstream #-} try pdfstream <* spaces - , pdfletters <* spaces -- Literal String - ] +pdfobj = pdfobjAtomPlain rrefs :: Parser Obj rrefs = do @@ -208,10 +419,12 @@ spaces string "R" spaces - return $ ObjRef (read objnum) + case readDec objnum of + [(n, "")] -> return $ ObjRef n + _ -> fail ("invalid object reference: " ++ objnum) objother :: Parser Obj -objother = ObjOther <$> (manyTill anyChar space) +objother = ObjOther . T.pack . show <$> (W.takeTill (\w-> w == 10 || w == 13) <* (W.word8 10 <|> W.word8 13)) parseRefsArray :: [Obj] -> [Int] parseRefsArray (ObjRef x:y) = (x:parseRefsArray y) diff --git a/src/PDF/OpenType.hs b/src/PDF/OpenType.hs --- a/src/PDF/OpenType.hs +++ b/src/PDF/OpenType.hs @@ -18,7 +18,8 @@ import Control.Applicative -import Debug.Trace +import qualified Data.Map as Map +import qualified Data.Text as T import PDF.Definition @@ -37,11 +38,13 @@ cmap :: ByteString -> CMap cmap c = case parseOnly (offsetTable >>= tableRecords) c of - Right b -> let b' = (takeCmap b) - in case parseOnly cmapEncRecords b' of - Right records -> concatMap (subtable b') records - Left e -> error e - Left e -> error e + Right b -> case takeCmap b of + Just b' -> case parseOnly cmapEncRecords b' of + Right records -> Map.fromListWith (flip const) $ + concatMap (subtable b') records + Left _ -> Map.empty + Nothing -> Map.empty + Left _ -> Map.empty where offsetTable = do sfntVersion @@ -50,9 +53,9 @@ return $ fromIntegral n takeCmap ((Table "cmap" start end):_) - = BS.take (fromInteger end) $ BS.drop (fromInteger start) c + = Just $ BS.take (fromInteger end) $ BS.drop (fromInteger start) c takeCmap (_:rest) = takeCmap rest - takeCmap [] = error "no cmap" + takeCmap [] = Nothing cmapEncRecords = cmapVersion >> @@ -64,14 +67,14 @@ format = fromBytes $ BS.take 2 body in case parseOnly (parserByFormat format) body of Right b -> b - Left e -> error e + Left _ -> [] -parserByFormat :: Integer -> Parser CMap +parserByFormat :: Integer -> Parser [(Int, T.Text)] parserByFormat 14 = do format <- getUint16 length <- getUint32 rest <- (AP.take . fromInteger) length - return $ [] + return [] parserByFormat 12 = do format <- getUint16 @@ -83,13 +86,13 @@ return $ concat seqMapGroups where - seqMapGroup :: Parser CMap + seqMapGroup :: Parser [(Int, T.Text)] seqMapGroup = do startCharCode <- fromInteger <$> getUint32 endCharCode <- fromInteger <$> getUint32 startGlyphID <- fromInteger <$> getUint32 return $ toCmap startGlyphID [startCharCode .. endCharCode] - toCmap gid range = zip [gid ..] $ map ((:[]).chr) range + toCmap gid range = zip [gid ..] $ map (T.singleton . chr) range parserByFormat 4 = do format <- getUint16 @@ -115,15 +118,15 @@ in (getGlyphID s e d rest):(getGlyphIDs ss ee dd rest') getGlyphID :: Int -> Int -> Int -> ByteString - -> CMap + -> [(Int, T.Text)] getGlyphID start end delta rest = let offset = fromInteger $ fromBytes $ BS.take 2 rest in if offset == 0 then zip (map (+delta) [start .. end]) - (map ((:[]).chr) [start .. end]) + (map (T.singleton . chr) [start .. end]) else zip (map (getRangeOffsetGlyphID start offset rest) [start .. end]) - (map ((:[]).chr) [start .. end]) + (map (T.singleton . chr) [start .. end]) getRangeOffsetGlyphID s o bytestring c = fromInteger $ fromBytes $ BS.take 2 $ BS.drop (o + 2 * (c - s)) bytestring diff --git a/src/PDF/Outlines.hs b/src/PDF/Outlines.hs --- a/src/PDF/Outlines.hs +++ b/src/PDF/Outlines.hs @@ -14,19 +14,21 @@ ( getOutlines ) where -import Debug.Trace - -import Data.List (find) +import qualified Data.Map as M +import Control.Monad (msum) import Data.Attoparsec.ByteString hiding (inClass, notInClass, satisfy) import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.Combinator import qualified Data.ByteString.Char8 as BS import PDF.Definition hiding (toString) +import PDF.Document (Document(..), openDocument, docRootRef) import PDF.DocumentStructure +import PDF.Error (PdfError(..), PdfResult) import PDF.Object (parseRefsArray, parsePdfLetters) -import PDF.PDFIO +import qualified Data.Text as T + data PDFOutlines = PDFOutlinesTree [PDFOutlines] | PDFOutlinesEntry { dest :: Int , text :: String @@ -42,92 +44,215 @@ toString depth (PDFOutlinesTree os) = concatMap (toString depth) os toString depth PDFOutlinesNE = "" --- | Get information of \/Outlines from 'filename' - -getOutlines :: FilePath -> IO PDFOutlines -getOutlines filename = do - dict <- outlineObjFromFile filename - objs <- getPDFObjFromFile filename - firstref <- case findFirst dict of - Just r -> return r - Nothing -> error "No top level outline entry." - firstdict <- case findObjsByRef firstref objs of - Just [PdfDict d] -> return d - Just s -> error $ "Unknown Object: " ++ show s - Nothing -> error $ "No Object with Ref " ++ show firstref - return $ gatherOutlines firstdict objs +getOutlines :: FilePath -> Maybe String -> IO (PdfResult PDFOutlines) +getOutlines filename password = do + docResult <- openDocument filename password + case docResult of + Left err -> return (Left err) + Right doc -> do + edict <- outlineFromDoc doc + case edict of + Left err -> return (Left err) + Right (dict, destsRoot) -> do + let objs = docObjs doc + case findFirst dict of + Nothing -> return $ Left (MissingKey "/First" "outlines") + Just firstref -> case findObjsByRef firstref objs of + Just [PdfDict d] -> return $ gatherOutlines d objs destsRoot + Just s -> return $ Left (ParseError ("Unknown outline object: " ++ show s) BS.empty) + Nothing -> return $ Left (MissingObject firstref) -gatherChildren dict objs = case findFirst dict of +gatherChildren :: Dict -> PDFObjIndex -> Maybe Int -> PdfResult PDFOutlines +gatherChildren dict objs destsRoot = case findFirst dict of Just r -> case findObjsByRef r objs of - Just [PdfDict d] -> gatherOutlines d objs - Just s -> error $ "Unknown Object at " ++ show r - Nothing -> error $ "No Object with Ref " ++ show r - Nothing -> PDFOutlinesNE + Just [PdfDict d] -> gatherOutlines d objs destsRoot + Just s -> Left (ParseError ("Unknown outline child: " ++ show s) BS.empty) + Nothing -> Left (MissingObject r) + Nothing -> Right PDFOutlinesNE -gatherOutlines dict objs = - let c = gatherChildren dict objs - in case findNext dict of +gatherOutlines :: Dict -> PDFObjIndex -> Maybe Int -> PdfResult PDFOutlines +gatherOutlines dict objs destsRoot = do + c <- gatherChildren dict objs destsRoot + let dest = destPage dict objs destsRoot + title <- findTitle dict objs + case findNext dict of Just r -> case findObjsByRef r objs of - Just [PdfDict d] -> PDFOutlinesTree (PDFOutlinesEntry { dest = head $ findDest dict - , text = findTitle dict objs ++ "\n" - , subs = c} - : [gatherOutlines d objs]) - Just s -> error $ "Unknown Object at " ++ show r - Nothing -> error $ "No Object with Ref " ++ show r - Nothing -> PDFOutlinesEntry { dest = head $ findDest dict - , text = findTitle dict objs ++ "\n" - , subs = c} + Just [PdfDict d] -> do + next <- gatherOutlines d objs destsRoot + return $ PDFOutlinesTree (PDFOutlinesEntry { dest = dest + , text = title ++ "\n" + , subs = c} + : [next]) + Just s -> Left (ParseError ("Unknown outline sibling: " ++ show s) BS.empty) + Nothing -> Left (MissingObject r) + Nothing -> return $ PDFOutlinesEntry { dest = dest + , text = title ++ "\n" + , subs = c} -outlines :: Dict -> Int -outlines dict = case find isOutlinesRef dict of - Just (_, ObjRef x) -> x - Just s -> error $ "Unknown Object: " ++ show s - Nothing -> error "There seems no /Outlines in the root" - where - isOutlinesRef (PdfName "/Outlines", ObjRef x) = True - isOutlinesRef (_,_) = False +destPage :: Dict -> PDFObjIndex -> Maybe Int -> Int +destPage dict objs destsRoot = + maybe 0 id $ listToMaybe $ findDest dict objs destsRoot -outlineObjFromFile :: String -> IO Dict -outlineObjFromFile filename = do - objs <- getPDFObjFromFile filename - rootref <- getRootRef filename - rootobj <- case findObjsByRef rootref objs of - Just os -> return os - Nothing -> error "Could not get root object." - outlineref <- case findDict rootobj of - Just dict -> return $ outlines dict - Nothing -> error "Something wrong..." - case findObjsByRef outlineref objs of - Just [PdfDict d] -> return d - Just s -> error $ "Unknown Object: " ++ show s - Nothing -> error "Could not get outlines object" +findDest :: Dict -> PDFObjIndex -> Maybe Int -> [Int] +findDest dict objs destsRoot = + case findObjFromDict dict "/Dest" of + Just o -> destFromObj o objs + Nothing -> case findObjFromDict dict "/A" of + Just (ObjRef r) -> actionDest r objs destsRoot + Just (PdfDict d) -> destFromAction d objs destsRoot + _ -> [] -findTitle dict objs = +destFromObj :: Obj -> PDFObjIndex -> [Int] +destFromObj (PdfArray a) _ = parseRefsArray a +destFromObj (ObjRef r) objs = + case findObjsByRef r objs of + Just (o:_) -> destFromObj o objs + _ -> [] +destFromObj (PdfNumber n) _ | truncate n >= 0 = [truncate n] +destFromObj _ _ = [] + +actionDest :: Int -> PDFObjIndex -> Maybe Int -> [Int] +actionDest r objs destsRoot = case findObjsByRef r objs of + Just (PdfDict d : _) -> destFromAction d objs destsRoot + _ -> [] + +destFromAction :: Dict -> PDFObjIndex -> Maybe Int -> [Int] +destFromAction d objs destsRoot = + case findObjFromDict d "/D" of + Just o -> destFromGoTo o objs destsRoot + Nothing -> [] + +destFromGoTo :: Obj -> PDFObjIndex -> Maybe Int -> [Int] +destFromGoTo o objs destsRoot = + case objAsName o of + Just name -> lookupNamedDest destsRoot name objs + Nothing -> destFromObj o objs + +lookupNamedDest :: Maybe Int -> T.Text -> PDFObjIndex -> [Int] +lookupNamedDest Nothing _ _ = [] +lookupNamedDest (Just root) name objs = + case lookupNameNode root name objs of + Just o -> destFromNamedDest o objs + Nothing -> [] + +lookupNameNode :: Int -> T.Text -> PDFObjIndex -> Maybe Obj +lookupNameNode ref name objs = + resolveDict ref objs >>= \d -> + case findObjFromDict d "/Names" of + Just (PdfArray arr) -> lookupNamePair arr name + _ -> case findObjFromDict d "/Kids" of + Just (PdfArray kids) -> + msum [ lookupNameNode r name objs + | ObjRef r <- kids + , nameInLimits name r objs + ] + _ -> Nothing + +lookupNamePair :: [Obj] -> T.Text -> Maybe Obj +lookupNamePair (n : v : rest) name = + case objAsName n of + Just t | t == name -> Just v + _ -> lookupNamePair rest name +lookupNamePair _ _ = Nothing + +nameInLimits :: T.Text -> Int -> PDFObjIndex -> Bool +nameInLimits name ref objs = + case resolveDict ref objs of + Nothing -> True + Just d -> case findObjFromDict d "/Limits" of + Just (PdfArray [lo, hi]) -> + case (objAsName lo, objAsName hi) of + (Just a, Just b) -> a <= name && name <= b + _ -> True + _ -> True + +destFromNamedDest :: Obj -> PDFObjIndex -> [Int] +destFromNamedDest o objs = + case o of + ObjRef r -> case findObjsByRef r objs of + Just (destObj:_) -> + case destObj of + PdfDict d -> maybe (destFromObj destObj objs) (\dd -> destFromObj dd objs) + $ findObjFromDict d "/D" + _ -> destFromObj destObj objs + _ -> [] + PdfDict d -> maybe [] (`destFromObj` objs) $ findObjFromDict d "/D" + _ -> destFromObj o objs + +resolveDict :: Int -> PDFObjIndex -> Maybe Dict +resolveDict r objs = case findObjsByRef r objs of + Just (PdfDict d : _) -> Just d + _ -> Nothing + +objAsName :: Obj -> Maybe T.Text +objAsName (PdfName n) = Just n +objAsName (PdfText t) = Just t +objAsName _ = Nothing + +outlinesRef :: Dict -> PdfResult Int +outlinesRef dict = case M.lookup "/Outlines" dict of + Just (ObjRef x) -> Right x + Just s -> Left (ParseError ("Unknown /Outlines: " ++ show s) BS.empty) + Nothing -> Left (MissingKey "/Outlines" "root") + +outlineFromDoc :: Document -> IO (PdfResult (Dict, Maybe Int)) +outlineFromDoc doc = + case docRootRef doc of + Left err -> return (Left err) + Right rootref -> outlineFromRoot rootref (docObjs doc) + +outlineFromRoot :: Int -> PDFObjIndex -> IO (PdfResult (Dict, Maybe Int)) +outlineFromRoot rootref objs = + case findObjsByRef rootref objs of + Nothing -> return $ Left (MissingObject rootref) + Just rootobj -> case findDict rootobj of + Nothing -> return $ Left (ParseError "root is not a dictionary" BS.empty) + Just dict -> case outlinesRef dict of + Left err -> return (Left err) + Right outlineref -> case findObjsByRef outlineref objs of + Just [PdfDict d] -> return (Right (d, destsRootRef dict objs)) + Just s -> return $ Left (ParseError ("Unknown outlines object: " ++ show s) BS.empty) + Nothing -> return $ Left (MissingObject outlineref) + +destsRootRef :: Dict -> PDFObjIndex -> Maybe Int +destsRootRef dict objs = + resolveNamesDict dict objs >>= \names -> + case findObjFromDict names "/Dests" of + Just (ObjRef r) -> Just r + _ -> Nothing + +resolveNamesDict :: Dict -> PDFObjIndex -> Maybe Dict +resolveNamesDict dict objs = + case findObjFromDict dict "/Names" of + Just (PdfDict names) -> Just names + Just (ObjRef r) -> resolveDict r objs + _ -> Nothing + +findTitle :: Dict -> PDFObjIndex -> PdfResult String +findTitle dict objs = case findObjFromDict dict "/Title" of - Just (PdfText s) -> case parseOnly parsePdfLetters (BS.pack s) of - Right t -> t - Left err -> s + Just (PdfText s) -> case parseOnly parsePdfLetters (BS.pack (T.unpack s)) of + Right t -> Right (T.unpack t) + Left _ -> Right (T.unpack s) Just (ObjRef r) -> case findObjsByRef r objs of - Just [PdfText s] -> s - Just s -> error $ "Unknown Object at " ++ show r - Nothing -> error $ "No title object in " ++ show r - Just x -> show x - Nothing -> error "No title object." + Just [PdfText s] -> Right (T.unpack s) + Just s -> Left (ParseError ("Unknown title object: " ++ show s) BS.empty) + Nothing -> Left (MissingObject r) + Just x -> Right (show x) + Nothing -> Left (MissingKey "/Title" "outline") -findDest dict = - case findObjFromDict dict "/Dest" of - Just (PdfArray a) -> parseRefsArray a - Just s -> error $ "Unknown Object: " ++ show s - Nothing -> error "No destination object." +listToMaybe :: [a] -> Maybe a +listToMaybe (x:_) = Just x +listToMaybe [] = Nothing -findNext dict = +findNext :: Dict -> Maybe Int +findNext dict = case findObjFromDict dict "/Next" of Just (ObjRef x) -> Just x - Just s -> error $ "Unknown Object: " ++ show s - Nothing -> Nothing + _ -> Nothing +findFirst :: Dict -> Maybe Int findFirst dict = case findObjFromDict dict "/First" of Just (ObjRef x) -> Just x - Just s -> error $ "Unknown Object: " ++ show s - Nothing -> Nothing + _ -> Nothing diff --git a/src/PDF/PDFIO.hs b/src/PDF/PDFIO.hs --- a/src/PDF/PDFIO.hs +++ b/src/PDF/PDFIO.hs @@ -1,15 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-| -Module : PDF.PDFIO -Description : IO utilities for hpdft -Copyright : (c) Keiichiro Shikano, 2016 -License : MIT -Maintainer : k16.shikano@gmail.com - -Functions for use within IO. --} - module PDF.PDFIO ( getObjectByRef , getPDFBSFromFile , getPDFObjFromFile @@ -21,90 +11,61 @@ ) where import PDF.Definition -import PDF.DocumentStructure - (rawStream, rawStreamByRef, findObjs, findObjsByRef, - findDictByRef, findObjFromDict, rootRef, - findTrailer, expandObjStm) -import PDF.Object (parsePDFObj) - -import Debug.Trace +import PDF.Document (Document(..), openDocument, docRootRef, docInfoDict) +import PDF.DocumentStructure (rawStream, findObjs', findObjsByRef) +import PDF.Encrypt (Security) +import PDF.Error (PdfError(..), PdfResult, note) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy.Char8 as BSL --- | Get PDF objects as a whole bytestring. Use `getPDFObjFromFile` instead if there's no reason to see a raw bytestring. - -getPDFBSFromFile :: FilePath -> IO [PDFBS] +getPDFBSFromFile :: FilePath -> IO (PdfResult [PDFBS]) getPDFBSFromFile f = do c <- BS.readFile f - let bs = findObjs c - return bs - --- | Get PDF objects each parsed as 'PDFObj' without being sorted. - -getPDFObjFromFile :: FilePath -> IO [PDFObj] -getPDFObjFromFile f = do - c <- BS.readFile f - let obj = expandObjStm $ map parsePDFObj $ findObjs c - return obj - --- | Get a PDF object from a whole 'PDFObj' by specifying `ref :: Int` + return (findObjs' c) -getObjectByRef :: Int -> [PDFObj] -> IO [Obj] -getObjectByRef ref pdfobjs = do - case findObjsByRef ref pdfobjs of - Just os -> return os - Nothing -> error $ "No Object with Ref " ++ show ref +getPDFObjFromFile :: FilePath -> Maybe String -> IO (PdfResult (PDFObjIndex, Maybe Security)) +getPDFObjFromFile f password = do + docResult <- openDocument f password + return (fmap docObjsSec docResult) + where + docObjsSec doc = (docObjs doc, docSecurity doc) --- | Get a PDF stream from a whole 'PDFObj' by specifying `ref :: Int` +getObjectByRef :: Int -> PDFObjIndex -> IO (PdfResult [Obj]) +getObjectByRef ref pdfobjs = + return (note (MissingObject ref) (findObjsByRef ref pdfobjs)) -getStream :: Bool -> [Obj] -> IO BSL.ByteString -getStream hex obj = return $ showBSL hex $ rawStream obj +getStream :: Maybe Security -> Int -> Bool -> [Obj] -> IO (PdfResult BSL.ByteString) +getStream sec objNum hex obj = + return (fmap (showBSL hex) (rawStream sec objNum obj)) +showBSL :: Bool -> BSL.ByteString -> BSL.ByteString showBSL hex s = let strm' = (B.toLazyByteString . B.lazyByteStringHex) s in if hex then if BSL.length strm' > 256 then BSL.concat [BSL.take 256 strm', "...(omit)"] else strm' else s --- | The reference number of /Root in `filename`. - -getRootRef :: FilePath -> IO Int +getRootRef :: FilePath -> IO (PdfResult Int) getRootRef filename = do - c <- BS.readFile filename - let n = rootRef c - case n of - Just i -> return i - Nothing -> error "Could not find rood object" - --- | The /Root object in `filename`. - -getRootObj :: FilePath -> IO [Obj] -getRootObj filename = do - rootref <- getRootRef filename - objs <- getPDFObjFromFile filename - case findObjsByRef rootref objs of - Just os -> return os - Nothing -> error "Could not get root object" + docResult <- openDocument filename Nothing + return (docResult >>= docRootRef) --- | The trailer of `filename`. +getRootObj :: FilePath -> Maybe String -> IO (PdfResult [Obj]) +getRootObj filename password = do + docResult <- openDocument filename password + return $ do + doc <- docResult + rootref <- docRootRef doc + note (MissingObject rootref) (findObjsByRef rootref (docObjs doc)) -getTrailer :: FilePath -> IO Dict +getTrailer :: FilePath -> IO (PdfResult Dict) getTrailer filename = do - c <- BS.readFile filename - return $ findTrailer c - --- | /Info of `filename`. + docResult <- openDocument filename Nothing + return (fmap docTrailer docResult) -getInfo :: FilePath -> IO Dict -getInfo filename = do - d <- getTrailer filename - objs <- getPDFObjFromFile filename - let inforef = case findObjFromDict d "/Info" of - Just (ObjRef ref) -> ref - Just _ -> error "There seems to be no Info" - Nothing -> error "There seems to be no Info" - case findDictByRef inforef objs of - Just os -> return os - Nothing -> error "Could not get info object" +getInfo :: FilePath -> Maybe String -> IO (PdfResult Dict) +getInfo filename password = do + docResult <- openDocument filename password + return (docResult >>= docInfoDict) diff --git a/src/PDF/Page.hs b/src/PDF/Page.hs new file mode 100644 --- /dev/null +++ b/src/PDF/Page.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : PDF.Page +Description : Public page-level API for hpdft (0.4) +License : MIT + +Stable entry points for page enumeration and structured extraction. +Prefer this module over 'PDF.DocumentStructure' internals in scripts and +downstream tools. + +Typical workflow: 'openDocument', then 'pageCount' / 'pageRefAt', then +'pageParagraphs' or 'pageRegions' with 'PDF.Layout.LayoutOptions'. + +@example +import PDF.Document (openDocument) +import PDF.Layout (defaultLayoutOptions) +import PDF.Page (pageCount, pageRefAt, pageParagraphs) + +extractPage :: Document -> Int -> PdfResult [Text] +extractPage doc n = do + ref <- pageRefAt doc n + pageParagraphs doc ref defaultLayoutOptions +-} +module PDF.Page + ( PageRef + , pageCount + , pageRefAt + , pageRefs + , pageItems + , pageGlyphs + , pageLines + , pageParagraphs + , PageRegion(..) + , pageRegions + ) where + +import PDF.Definition (PDFObjIndex) +import PDF.Document (Document(..), docRootRef) +import PDF.DocumentStructure + ( findDictOfType + , findKids + , findObjsByRef + , findPages + ) +import PDF.Error (PdfError(..), PdfResult) +import PDF.Interpret (Glyph(..), PageItem(..), Rect(..), interpretPageItems) +import PDF.Layout + ( LayoutOptions + , Line(..) + , layoutParagraphsWith + , pageItemLines + , pageItemParagraphGroups + ) + +import Data.List (elemIndex) + +import qualified Data.Text as T + +-- | PDF page object reference number (same as catalog\/pages leaf ref). +type PageRef = Int + +-- | Number of pages in document order (1-based page numbers run @1 .. pageCount@). +pageCount :: Document -> PdfResult Int +pageCount doc = fmap length (pageRefs doc) + +-- | Resolve a 1-based page number to its object reference. +pageRefAt :: Document -> Int -> PdfResult PageRef +pageRefAt doc n + | n < 1 = Left (UnsupportedFeature ("page number " ++ show n ++ " out of range")) + | otherwise = do + refs <- pageRefs doc + if n > length refs + then Left (UnsupportedFeature ("page number " ++ show n ++ " out of range (1-" ++ show (length refs) ++ ")")) + else Right (refs !! (n - 1)) + +pageItems :: Document -> PageRef -> PdfResult [PageItem] +pageItems = interpretPageItems + +pageGlyphs :: Document -> PageRef -> PdfResult [Glyph] +pageGlyphs doc ref = fmap extractGlyphs (pageItems doc ref) + where + extractGlyphs items = [g | ItemGlyph g <- items] + +pageLines :: Document -> PageRef -> LayoutOptions -> PdfResult [Line] +pageLines doc ref opts = fmap (pageItemLines opts) (pageItems doc ref) + +pageParagraphs :: Document -> PageRef -> LayoutOptions -> PdfResult [T.Text] +pageParagraphs doc ref opts = fmap (layoutParagraphsWith opts) (pageItems doc ref) + +data PageRegion = PageRegion + { regionPage :: !Int + , regionParagraph :: !Int + , regionBBox :: !Rect + , regionText :: !T.Text + } deriving (Eq, Show) + +-- | Per-page paragraph regions without document-level cross-page merge. +-- Each 'PageRegion' carries the 1-based page number, paragraph index, bounding box, +-- and paragraph text. +-- +-- @example +-- ref <- pageRefAt doc 2 +-- regions <- pageRegions doc ref defaultLayoutOptions +-- mapM_ print regions +pageRegions :: Document -> PageRef -> LayoutOptions -> PdfResult [PageRegion] +pageRegions doc ref opts = do + items <- pageItems doc ref + pageNo <- pageNumberOf doc ref + let texts = layoutParagraphsWith opts items + groups = pageItemParagraphGroups opts items + return + [ PageRegion pageNo idx (paraBBox grp) txt + | (idx, (txt, grp)) <- zip [1 ..] (zip texts groups) + ] + +pageRefs :: Document -> PdfResult [PageRef] +pageRefs doc = do + root <- docRootRef doc + return (pageRefsFromRoot root (docObjs doc)) + +pageNumberOf :: Document -> PageRef -> PdfResult Int +pageNumberOf doc ref = do + refs <- pageRefs doc + case elemIndex ref refs of + Nothing -> Left (MissingObject ref) + Just i -> Right (i + 1) + +pageRefsFromRoot :: Int -> PDFObjIndex -> [PageRef] +pageRefsFromRoot parent objs = + case findObjsByRef parent objs of + Just os -> case findDictOfType "/Catalog" os of + Just dict -> case findPages dict of + Just pr -> pageRefsFromRoot pr objs + Nothing -> [] + Nothing -> case findDictOfType "/Pages" os of + Just dict -> case findKids dict of + Just kidsrefs -> concatMap (\k -> pageRefsFromRoot k objs) kidsrefs + Nothing -> [] + Nothing -> case findDictOfType "/Page" os of + Just _ -> [parent] + Nothing -> [] + Nothing -> [] + +paraBBox :: [Line] -> Rect +paraBBox [] = Rect 0 0 0 0 +paraBBox ls = + Rect + { rectX0 = minimum (map lineInlineStart ls) + , rectY0 = minimum (map (\l -> lineBaseline l - lineSize l) ls) + , rectX1 = maximum (map lineInlineEnd ls) + , rectY1 = maximum (map lineBaseline ls) + } diff --git a/src/PDF/Structure.hs b/src/PDF/Structure.hs new file mode 100644 --- /dev/null +++ b/src/PDF/Structure.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE OverloadedStrings #-} + +module PDF.Structure + ( StructElem(..) + , StructKid(..) + , RubySpan(..) + , structTree + , logicalOrder + , collectRubySpans + ) where + +import PDF.Definition +import PDF.Document (Document(..), docRootRef) +import PDF.DocumentStructure + ( findDict + , findDictByRef + , findDictOfType + , findObjFromDict + , findObjsByRef + ) +import PDF.Error (PdfError(..), PdfResult) + +import qualified Data.Text as T +import Data.List (foldl') +import Data.Maybe (listToMaybe, maybeToList) +import qualified Data.Set as S + +data StructElem = StructElem + { seType :: T.Text + , seKids :: [StructKid] + } deriving (Eq, Show) + +data StructKid = KidElem StructElem | KidMCID Int Int deriving (Eq, Show) + +-- Parallel base/ruby MCID lists from a /Ruby element's /RB and /RT kids. +data RubySpan = RubySpan + { rsPage :: Int + , rsBases :: [Int] + , rsRubies :: [Int] + } deriving (Eq, Show) + +maxStructDepth :: Int +maxStructDepth = 512 + +structTree :: Document -> PdfResult (Maybe StructElem) +structTree doc = do + rootRef <- docRootRef doc + let objs = docObjs doc + case findObjsByRef rootRef objs of + Just os -> case findDictOfType "/Catalog" os of + Just catalog -> case findObjFromDict catalog "/StructTreeRoot" of + Just (ObjRef r) -> parseStructRef r Nothing objs S.empty 0 + Just (PdfDict d) -> parseStructDict d Nothing objs S.empty 0 + _ -> Right Nothing + Nothing -> Left (MissingKey "/Type" "catalog") + Nothing -> Left (MissingObject rootRef) + +parseStructRef :: Int -> Maybe Int -> PDFObjIndex -> S.Set Int -> Int + -> PdfResult (Maybe StructElem) +parseStructRef ref pg objs visited depth + | depth >= maxStructDepth = Right Nothing + | S.member ref visited = Right Nothing + | otherwise = + case findObjsByRef ref objs of + Just os -> case findDict os of + Just d -> parseStructDict d pg objs (S.insert ref visited) depth + Nothing -> Right Nothing + Nothing -> Left (MissingObject ref) + +parseStructDict :: Dict -> Maybe Int -> PDFObjIndex -> S.Set Int -> Int + -> PdfResult (Maybe StructElem) +parseStructDict d pg objs visited depth = do + let pg' = pageRefFromDict d pg objs + stype = structTypeName d + kids <- parseKids (findObjFromDict d "/K") pg' objs visited (depth + 1) + if T.null stype && null kids + then return Nothing + else return (Just (StructElem stype kids)) + +structTypeName :: Dict -> T.Text +structTypeName d = + case findObjFromDict d "/S" of + Just (PdfName n) -> n + _ -> case findObjFromDict d "/Type" of + Just (PdfName n) -> n + _ -> T.empty + +logicalOrder :: StructElem -> [([T.Text], Int, Int)] +logicalOrder root = walk [] root + where + walk ancestors (StructElem stype kids) = + let path = ancestors ++ [stype] + in concatMap (kidWalk path) kids + + kidWalk path (KidMCID page mcid) = [(path, page, mcid)] + kidWalk path (KidElem elem) = walk path elem + +collectRubySpans :: StructElem -> [RubySpan] +collectRubySpans root = walk root + where + walk (StructElem stype kids) = + let childSpans = concatMap kidWalk kids + here = if stype == "/Ruby" then maybeToList (rubySpan kids) else [] + in here ++ childSpans + + kidWalk (KidElem e) = walk e + kidWalk _ = [] + +rubySpan :: [StructKid] -> Maybe RubySpan +rubySpan kids = + case (findKidElem "/RB" kids, findKidElem "/RT" kids) of + (Just rb, Just rt) -> + let bases = mcidsFromElem rb + rubies = mcidsFromElem rt + in case bases of + (page, _) : _ -> + if null bases || null rubies + then Nothing + else Just (RubySpan page (map snd bases) (map snd rubies)) + [] -> Nothing + _ -> Nothing + +findKidElem :: T.Text -> [StructKid] -> Maybe StructElem +findKidElem want = foldr go Nothing + where + go (KidElem e@(StructElem t _)) Nothing + | t == want = Just e + go _ acc = acc + +mcidsFromElem :: StructElem -> [(Int, Int)] +mcidsFromElem (StructElem _ kids) = concatMap kidMcids kids + where + kidMcids (KidMCID page mcid) = [(page, mcid)] + kidMcids (KidElem e) = mcidsFromElem e + kidMcids _ = [] + +pageRefFromDict :: Dict -> Maybe Int -> PDFObjIndex -> Maybe Int +pageRefFromDict d pg _ = + case findObjFromDict d "/Pg" of + Just (ObjRef r) -> Just r + _ -> pg + +parseKids :: Maybe Obj -> Maybe Int -> PDFObjIndex -> S.Set Int -> Int + -> PdfResult [StructKid] +parseKids Nothing _ _ _ _ = Right [] +parseKids (Just (PdfNumber n)) pg _ _ _ = + case pg of + Just p -> Right [KidMCID p (truncate n)] + Nothing -> Right [] +parseKids (Just (PdfArray arr)) pg objs visited depth = + foldl' (\acc o -> do + ks <- acc + more <- parseKid o pg objs visited depth + return (ks ++ more)) (Right []) arr +parseKids (Just o) pg objs visited depth = parseKid o pg objs visited depth + +parseKid :: Obj -> Maybe Int -> PDFObjIndex -> S.Set Int -> Int + -> PdfResult [StructKid] +parseKid (PdfNumber n) pg _ _ _ = + case pg of + Just p -> Right [KidMCID p (truncate n)] + Nothing -> Right [] +parseKid (ObjRef r) pg objs visited depth = do + case findObjsByRef r objs of + Just os -> case findDict os of + Just d -> parseKidDict d pg objs visited depth + Nothing -> Right [] + Nothing -> Left (MissingObject r) +parseKid (PdfDict d) pg objs visited depth = parseKidDict d pg objs visited depth +parseKid _ _ _ _ _ = Right [] + +parseKidDict :: Dict -> Maybe Int -> PDFObjIndex -> S.Set Int -> Int + -> PdfResult [StructKid] +parseKidDict d pg objs visited depth = + case findObjFromDict d "/Type" of + Just (PdfName "/MCR") -> + let pg' = pageRefFromDict d pg objs + mcid = case findObjFromDict d "/MCID" of + Just (PdfNumber n) -> Just (truncate n) + _ -> Nothing + in case (pg', mcid) of + (Just p, Just m) -> Right [KidMCID p m] + _ -> Right [] + Just (PdfName "/OBJR") -> Right [] + _ -> do + elem' <- parseStructDict d pg objs visited depth + case elem' of + Just e -> Right [KidElem e] + Nothing -> Right [] diff --git a/src/PDF/Text.hs b/src/PDF/Text.hs new file mode 100644 --- /dev/null +++ b/src/PDF/Text.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : PDF.Text +Description : Text extraction drivers for hpdft +License : MIT + +High-level text extraction from an opened 'PDF.Document.Document' or a file path. + +* __Default (CLI equivalent)__: 'pdfToTextTaggedDoc' tries tagged PDF structure + extraction and falls back to geometry layout when structure is missing or unusable. +* __Geometry__: 'pdfToTextGeomDoc' reconstructs paragraphs from glyph positions + (same pipeline as @hpdft text --geom@). +* __Tagged__: 'pdfToTextTaggedDocWith' forces the tagged path when a structure tree exists. +* __Legacy__: 'pdfToTextDoc' / 'walkdown' preserve the pre-0.3 stream-order extractor + (same as @hpdft text --legacy@). + +Pass 'PDF.Layout.LayoutOptions' to the @…With@ variants for footnotes and ruby. + +@example +import PDF.Document (openDocument) +import PDF.Text (pdfToTextTaggedDoc) +import qualified Data.ByteString.Lazy.Char8 as BSL + +main = do + result <- openDocument "doc.pdf" Nothing + case result of + Left err -> print err + Right doc -> + case pdfToTextTaggedDoc doc of + Left err -> print err + Right bs -> BSL.putStr bs +-} +module PDF.Text + ( initstate + , walkdown + , pdfToTextBS + , pdfToTextWithWarnings + , pdfToTextDoc + , pdfToTextGeomBS + , pdfToTextGeomBSWith + , pdfToTextGeomDoc + , pdfToTextGeomDocWith + , pdfToTextTaggedBS + , pdfToTextTaggedBSWith + , pdfToTextTaggedDoc + , pdfToTextTaggedDocWith + , pageTextGeom + , pageTextGeomWith + , pdfToTextStreamDoc + ) where + +import PDF.Definition +import PDF.Error (PdfResult, PdfWarning(..)) +import PDF.Document (Document(..), openDocument, docRootRef) +import PDF.DocumentStructure +import PDF.Encrypt (Security) +import PDF.Interpret (Glyph(..), Rect(..), PageItem(..), interpretPageItems) +import PDF.Layout (LayoutOptions(..), defaultLayoutOptions, aozoraRuby, joinGlyphsRun, layoutDocumentFromPageLines, layoutPageTextWith, linesFromGlyphs, pageLinesRaw, stripHeadersFooters, joinParaLines, forcePageLines) +import PDF.Page (pageRefs) +import PDF.Structure (StructElem(..), RubySpan(..), structTree, logicalOrder, collectRubySpans) + +import Control.DeepSeq (force) +import Control.Parallel.Strategies (Eval, parList, using) +import Data.List (foldl') +import qualified Data.Set as S +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.ByteString.Lazy.UTF8 as BSLU +import qualified Data.Text as T + +initstate :: PSR +initstate = PSR { linex=0 + , liney=0 + , absolutex=0 + , absolutey=0 + , leftmargin=0.0 + , text_lm=(1,0,0,1,0,0) + , text_m=(1,0,0,1,0,0) + , text_break=False + , top=0.0 + , bottom=0.0 + , fontfactor=1 + , curfont=T.empty + , fontmaps=Map.empty + , cmaps=Map.empty + , colorspace=T.empty + , xcolorspaces=[] + , warnings=[] + } + +pdfToTextBS :: FilePath -> Maybe String -> IO (PdfResult BSL.ByteString) +pdfToTextBS filename mpw = do + result <- pdfToTextWithWarnings filename mpw + return (fmap fst result) + +pdfToTextWithWarnings :: FilePath -> Maybe String -> IO (PdfResult (BSL.ByteString, [PdfWarning])) +pdfToTextWithWarnings filename mpw = do + docResult <- openDocument filename mpw + return $ do + doc <- docResult + rootref <- docRootRef doc + return (walkdown initstate rootref (docSecurity doc) (docObjs doc)) + +pdfToTextDoc :: Document -> (BSL.ByteString, [PdfWarning]) +pdfToTextDoc doc = + case docRootRef doc of + Right rootref -> walkdown initstate rootref (docSecurity doc) (docObjs doc) + Left _ -> ("", []) + +-- | Legacy stream-order extraction, one page at a time in document order. +-- +-- The callback receives a 1-based page number, total page count, and that +-- page's legacy text (same bytes as the corresponding segment of 'pdfToTextDoc'). +-- Concatenating all page outputs in order yields the 'fst' of 'pdfToTextDoc'. +-- Warnings from every page are collected and returned. +pdfToTextStreamDoc :: + Document -> (Int -> Int -> BSL.ByteString -> IO ()) -> IO [PdfWarning] +pdfToTextStreamDoc doc callback = + case pageRefs doc of + Left _ -> return [] + Right refs -> do + let total = length refs + sec = docSecurity doc + objs = docObjs doc + wss <- mapM (streamPage total sec objs) (zip [1 ..] refs) + return (concat wss) + where + streamPage total sec objs (num, ref) = + case findObjsByRef ref objs of + Just os -> + case findDictOfType "/Page" os of + Just dict -> do + let (txt, ws) = pageContent dict initstate sec objs + callback num total txt + return ws + Nothing -> return [] + Nothing -> return [] + +pdfToTextGeomBS :: FilePath -> Maybe String -> IO (PdfResult BSL.ByteString) +pdfToTextGeomBS = pdfToTextGeomBSWith defaultLayoutOptions + +pdfToTextGeomBSWith :: LayoutOptions -> FilePath -> Maybe String -> IO (PdfResult BSL.ByteString) +pdfToTextGeomBSWith opts filename mpw = do + docResult <- openDocument filename mpw + return (docResult >>= pdfToTextGeomDocWith opts) + +pdfToTextGeomDoc :: Document -> PdfResult BSL.ByteString +pdfToTextGeomDoc = pdfToTextGeomDocWith defaultLayoutOptions + +-- | Geometry-based full-document text (paragraph layout across all pages). +pdfToTextGeomDocWith :: LayoutOptions -> Document -> PdfResult BSL.ByteString +pdfToTextGeomDocWith opts doc = do + refs <- pageRefs doc + layouts <- parallelPageResults (interpretPageLinesRaw doc) forcePageLines refs + return (layoutPagesFromLines opts layouts) + +interpretPageLinesRaw doc ref = + pageLinesRaw <$> interpretPageItems doc ref + +interpretAllPages :: Document -> PdfResult ([Int], [[PageItem]]) +interpretAllPages doc = do + refs <- pageRefs doc + pages <- parallelPageResults (interpretPageItems doc) forcePageItems refs + return (refs, pages) + +-- | Evaluate per-page 'PdfResult' work in parallel, then sequence in page order. +parallelPageResults :: + (Int -> PdfResult a) -> (a -> ()) -> [Int] -> PdfResult [a] +parallelPageResults f forcePayload refs = + let results = map f refs `using` parList (evalResultPayload forcePayload) + in sequence results + +evalResultPayload :: (a -> ()) -> PdfResult a -> Eval (PdfResult a) +evalResultPayload forceIt result = + case result of + Left e -> e `seq` return result + Right v -> forceIt v `seq` return result + +-- | Force interpreted page items for parallel evaluation. 'FontInfo' width +-- functions inside the interpreter are not touched; only glyph text and coords. +forcePageItems :: [PageItem] -> () +forcePageItems = foldr forcePageItem () + +forcePageItem :: PageItem -> () -> () +forcePageItem (ItemGlyph g) () = forceGlyph g +forcePageItem (ItemGraphic r) () = + rectX0 r `seq` rectY0 r `seq` rectX1 r `seq` rectY1 r `seq` () + +forceGlyph :: Glyph -> () +forceGlyph g = + force (glyphText g) `seq` + glyphX g `seq` glyphY g `seq` glyphWidth g `seq` glyphSize g `seq` + force (glyphFont g) `seq` glyphWMode g `seq` glyphMCID g `seq` () + +layoutPagesFromLines opts layouts = + BSLU.fromString (T.unpack (layoutDocumentFromPageLines opts layouts)) + +pageTextGeom :: Document -> Int -> PdfResult BSL.ByteString +pageTextGeom = pageTextGeomWith defaultLayoutOptions + +pageTextGeomWith :: LayoutOptions -> Document -> Int -> PdfResult BSL.ByteString +pageTextGeomWith opts doc pageRef = do + items <- interpretPageItems doc pageRef + return $ BSLU.fromString (T.unpack (layoutPageTextWith opts items)) + +pdfToTextTaggedBS :: FilePath -> Maybe String -> IO (PdfResult BSL.ByteString) +pdfToTextTaggedBS = pdfToTextTaggedBSWith defaultLayoutOptions + +pdfToTextTaggedBSWith :: LayoutOptions -> FilePath -> Maybe String -> IO (PdfResult BSL.ByteString) +pdfToTextTaggedBSWith opts filename mpw = do + docResult <- openDocument filename mpw + return (docResult >>= pdfToTextTaggedDocWith opts) + +pdfToTextTaggedDoc :: Document -> PdfResult BSL.ByteString +pdfToTextTaggedDoc = pdfToTextTaggedDocWith defaultLayoutOptions + +-- | Tagged structure extraction with geometry fallback (default CLI behaviour). +pdfToTextTaggedDocWith :: LayoutOptions -> Document -> PdfResult BSL.ByteString +pdfToTextTaggedDocWith opts doc = do + mroot <- structTree doc + case mroot of + Nothing -> pdfToTextGeomDocWith opts doc + Just root -> do + (refs, pages) <- interpretAllPages doc + if taggedUsable pages + then Right (BSLU.fromString (T.unpack (assembleTagged opts root refs pages))) + else Right (layoutPagesFromLines opts (map pageLinesRaw pages)) + +taggedUsable :: [[PageItem]] -> Bool +taggedUsable pages = + let glyphs = [g | pg <- pages, ItemGlyph g <- pg] + total = length glyphs + tagged = length [g | g <- glyphs, glyphMCID g /= Nothing] + in total > 0 && fromIntegral tagged / fromIntegral total >= 0.5 + +assembleTagged :: LayoutOptions -> StructElem -> [Int] -> [[PageItem]] -> T.Text +assembleTagged opts root refs pages = + let mcidMaps = zip refs (map mcidGlyphMap pages) + mcidLookup = Map.fromList + [((page, mcid), gs) | (page, m) <- mcidMaps, (mcid, gs) <- Map.toList m] + rubyMap = structureRubyMap opts root refs pages + structRubyPages = S.fromList [rsPage s | s <- collectRubySpans root] + geomRubyPerPage = + Map.fromList + [ (page, layoutPageTextWith opts items) + | (page, items) <- zip refs pages + , optRuby opts + , not (page `S.member` structRubyPages) + ] + artifactLinesPerPage = + Map.fromList $ + zip refs + (stripHeadersFooters (length pages) + (map (linesFromGlyphs . artifactGlyphs) pages)) + geomRubyEmitted = Map.empty :: Map.Map Int Bool + + lastPathType [] = T.empty + lastPathType path = last path + + snocSep hasContent prevEnd acc = + if prevEnd && hasContent + then acc . (T.append "\n\n") + else acc + + appendMCID (acc, hasContent, prevParaEnd, emitted) (path, page, mcid) = + if Map.member page geomRubyPerPage && not (Map.findWithDefault False page emitted) + then let run = Map.findWithDefault T.empty page geomRubyPerPage + in ( snocSep hasContent prevParaEnd acc . T.append run + , True + , False + , Map.insert page True emitted + ) + else case Map.lookup (page, mcid) mcidLookup of + Nothing -> (acc, hasContent, prevParaEnd, emitted) + Just gs -> + let run = joinGlyphsRun gs + paraEnd = paragraphEnd (lastPathType path) + formatted = case Map.lookup (page, mcid) rubyMap of + Just rt -> aozoraRuby run rt + _ -> run + in ( snocSep hasContent prevParaEnd acc . T.append formatted + , True + , paraEnd + , emitted + ) + + appendArtifacts (acc, hasContent, emitted) page = + if Map.member page geomRubyPerPage + then (acc, hasContent, emitted) + else case Map.lookup page artifactLinesPerPage of + Just ls | not (null ls) -> + let run = joinParaLines ls + in if T.null run + then (acc, hasContent, emitted) + else if not hasContent + then (acc . T.append run, True, emitted) + else (acc . (T.append "\n\n") . T.append run, True, emitted) + _ -> (acc, hasContent, emitted) + + order = logicalOrder root + (structAcc, structHasContent, _, _) = + foldl' appendMCID (id, False, False, geomRubyEmitted) order + (outAcc, _, _) = + foldl' appendArtifacts (structAcc, structHasContent, geomRubyEmitted) refs + out = outAcc T.empty + in if T.null out then "\n" else out `T.append` "\n" + +structureRubyMap :: + LayoutOptions -> StructElem -> [Int] -> [[PageItem]] -> Map.Map (Int, Int) T.Text +structureRubyMap opts root refs pages + | not (optRuby opts) = Map.empty + | otherwise = + let mcidMaps = Map.fromList (zip refs (map mcidGlyphMap pages)) + glyphTextFor page mcid = + case Map.lookup page mcidMaps >>= Map.lookup mcid of + Just gs -> joinGlyphsRun gs + _ -> T.empty + in Map.fromList + [ ((rsPage span, baseMcid), rubyTxt) + | span <- collectRubySpans root + , (baseMcid, rubyMcid) <- zip (rsBases span) (rsRubies span) + , let rubyTxt = glyphTextFor (rsPage span) rubyMcid + , not (T.null rubyTxt) + ] + +paragraphEnd :: T.Text -> Bool +paragraphEnd stype = stype `elem` + [ "/P", "/H1", "/H2", "/H3", "/H4", "/H5", "/H6" + , "/LI", "/LBody", "/TD", "/TH", "/Caption", "/Title" + ] + +mcidGlyphMap :: [PageItem] -> Map.Map Int [Glyph] +mcidGlyphMap items = + Map.map reverse $ + Map.fromListWith (++) [(mcid, [g]) | ItemGlyph g <- items, Just mcid <- [glyphMCID g]] + +artifactGlyphs :: [PageItem] -> [Glyph] +artifactGlyphs items = [g | ItemGlyph g <- items, glyphMCID g == Nothing] + +walkdown :: PSR -> Int -> Maybe Security -> PDFObjIndex -> (BSL.ByteString, [PdfWarning]) +walkdown st parent sec objs = + case findObjsByRef parent objs of + Just os -> case findDictOfType "/Catalog" os of + Just dict -> case findPages dict of + Just pr -> walkdown st pr sec objs + Nothing -> ("", []) + Nothing -> case findDictOfType "/Pages" os of + Just dict -> case findKids dict of + Just kidsrefs -> + let results = map (\k -> walkdown st k sec objs) kidsrefs + in ( BSL.concat (map fst results) + , concatMap snd results + ) + Nothing -> ("", []) + Nothing -> case findDictOfType "/Page" os of + Just dict -> pageContent dict st sec objs + Nothing -> ("", []) + Nothing -> ("", []) + +pageContent :: Dict -> PSR -> Maybe Security -> PDFObjIndex -> (BSL.ByteString, [PdfWarning]) +pageContent dict st sec objs = + case contentsStream dict st sec objs of + Right (s, ws) -> (s, ws) + Left _ -> ("", []) diff --git a/src/PDF/Type1.hs b/src/PDF/Type1.hs --- a/src/PDF/Type1.hs +++ b/src/PDF/Type1.hs @@ -19,7 +19,8 @@ import Control.Applicative -import Debug.Trace +import qualified Data.Map as Map +import qualified Data.Text as T import PDF.Definition @@ -33,10 +34,10 @@ encoding :: ByteString -> Encoding encoding c = case parseOnly encodingArray c of - Right ss -> Encoding ss - Left e -> error "Can not find /Encoding in the Type1 Font" + Right ss -> Encoding $ Map.fromListWith (flip const) ss + Left _ -> NullMap -encodingArray :: Parser [(Char,String)] +encodingArray :: Parser [(Char,T.Text)] encodingArray = do manyTill anyChar (try $ lookAhead $ string "/Encoding") string "/Encoding" @@ -50,12 +51,12 @@ where skipFor = manyTill anyChar (try $ string "for") -specialEncodings :: Parser (Char, String) +specialEncodings :: Parser (Char, T.Text) specialEncodings = do spaces (,) <$> (spaces >> string "dup" >> spaces *> index) <*> (spaces >> charName <* spaces) where index = (chr . read) <$> many1 digit - charName = manyTill anyChar (try $ (spaces >> string "put")) + charName = T.pack <$> manyTill anyChar (try $ (spaces >> string "put")) diff --git a/test/Golden.hs b/test/Golden.hs new file mode 100644 --- /dev/null +++ b/test/Golden.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +import PDF.Text (pdfToTextBS, pdfToTextTaggedBS) + +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.List (isSuffixOf, sort) +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) +import System.Exit (exitFailure) +import System.FilePath ((), takeBaseName) +import Control.Monad (when) + +fixturesDir, expectedDir, expectedLegacyDir, knownFailingDir :: FilePath +fixturesDir = "data/fixtures" +expectedDir = fixturesDir "expected" +expectedLegacyDir = fixturesDir "expected-legacy" +knownFailingDir = fixturesDir "known-failing" + +main :: IO () +main = do + entries <- filter (".pdf" `isSuffixOf`) <$> listDirectory fixturesDir + let pdfs = map (fixturesDir ) (sort entries) + failsDefault <- concat <$> mapM (checkFixture "default" expectedDir pdfToTextTaggedBS) pdfs + failsLegacy <- concat <$> mapM (checkFixture "legacy" expectedLegacyDir pdfToTextBS) pdfs + let fails = failsDefault ++ failsLegacy + known <- listKnownFailing + mapM_ (putStrLn . ("SKIP (known-failing): " ++)) known + when (not (null fails)) $ do + mapM_ putStrLn fails + exitFailure + +listKnownFailing :: IO [FilePath] +listKnownFailing = do + exists <- doesDirectoryExist knownFailingDir + if not exists + then return [] + else do + entries <- listDirectory knownFailingDir + return $ sort $ filter (".pdf" `isSuffixOf`) entries + +checkFixture :: String -> FilePath -> (FilePath -> Maybe String -> IO (Either e BSL.ByteString)) -> FilePath -> IO [String] +checkFixture mode expDir extract pdf = do + let name = takeBaseName pdf + label = name ++ " (" ++ mode ++ ")" + expectedPath = expDir (name ++ ".txt") + exists <- doesFileExist expectedPath + if not exists + then return [label ++ ": FAIL (missing expected " ++ expectedPath ++ ")"] + else do + result <- extract pdf (Just "") + case result of + Left _ -> return [label ++ ": FAIL (extraction error)"] + Right actual -> do + expected <- BSL.readFile expectedPath + let actualOut = BSLC.append actual "\n" + if actualOut == expected + then do + putStrLn $ label ++ ": OK" + return [] + else do + putStrLn $ label ++ ": FAIL" + return [diffMessage label actualOut expected] + +diffMessage :: String -> BSL.ByteString -> BSL.ByteString -> String +diffMessage name actual expected = + let aLines = take 20 $ BSLC.lines actual + eLines = take 20 $ BSLC.lines expected + pairs = zipWith (\i (a, e) -> show (i + 1) ++ ": -" ++ BSLC.unpack e ++ "\n +" ++ BSLC.unpack a) [0..] (zip aLines eLines) + in unlines $ (name ++ " mismatch (first lines):") : pairs diff --git a/test/Unit.hs b/test/Unit.hs new file mode 100644 --- /dev/null +++ b/test/Unit.hs @@ -0,0 +1,1321 @@ +{-# LANGUAGE OverloadedStrings #-} +import PDF.Matrix (Matrix, identity, multiply, apply, applyVec, translate, scale, mkMatrix, components) +import PDF.Definition (Obj(..), FontInfo(..), Encoding(..)) +import PDF.Interpret + ( Glyph(..) + , Rect(..) + , PageItem(..) + , interpretContentWithFonts + , interpretContentWithFontsItems + , interpretPageImageHits + ) +import PDF.Layout (LayoutOptions(..), defaultLayoutOptions, needsAozoraBar, aozoraRuby, layoutParagraphs, layoutParagraphsWith, layoutPageText, layoutDocument, sortLinesByReadingOrder, linesFromGlyphs, Line(..)) +import PDF.Structure (StructElem(..), StructKid(..), structTree, logicalOrder) +import PDF.Document (Document(..), openDocument) +import PDF.Page (pageCount, pageRefAt, pageParagraphs) +import PDF.Diff (TextChange(..), compareDocuments, diffParagraphs) +import PDF.DocumentStructure (parseCIDWidths, simpleWidthAt, decodeStreamBytes) +import PDF.Image + ( ImageFormat(..) + , PageImage(..) + , classifyImageBytes + , encodePngRgb + , extractPageImages + ) +import PDF.FormExtract (pageFormNames, extractFormPdf) +import PDF.Text (pdfToTextTaggedBS, pdfToTextDoc, pdfToTextStreamDoc) +import PDF.Error (PdfResult) + +import qualified Data.Map as M +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC +import qualified Data.Text as T + +import System.Exit (exitFailure) +import System.IO.Unsafe (unsafePerformIO) +import System.Directory (doesFileExist, getTemporaryDirectory) +import System.FilePath (()) +import Control.Monad (when) +import Data.IORef (newIORef, readIORef, modifyIORef) +import TuiScroll + ( ScrollState(..) + , initialScrollState + , scrollBy + , scrollToTop + , scrollToEnd + , scrollHalfPageDown + , scrollHalfPageUp + , searchForwardFrom + , searchBackwardFrom + , visibleLineRange + , statusLineNumber + , stringDisplayWidth + , clipToDisplayWidth + , padToDisplayWidth + ) + +import Data.Word (Word8) + +epsilon :: Double +epsilon = 1e-9 + +approxEq :: Double -> Double -> Bool +approxEq x y = abs (x - y) <= epsilon + +pointEq :: (Double, Double) -> (Double, Double) -> Bool +pointEq (x1, y1) (x2, y2) = approxEq x1 x2 && approxEq y1 y2 + +matrixEq :: Matrix -> Matrix -> Bool +matrixEq m1 m2 = + let (a1, b1, c1, d1, e1, f1) = components m1 + (a2, b2, c2, d2, e2, f2) = components m2 + in approxEq a1 a2 + && approxEq b1 b2 + && approxEq c1 c2 + && approxEq d1 d2 + && approxEq e1 e2 + && approxEq f1 f2 + +data Result = Pass String | Fail String + +pass :: String -> Result +pass label = Pass label + +testFail :: String -> String -> Result +testFail label msg = Fail (label ++ ": FAIL (" ++ msg ++ ")") + +assertEq :: String -> Matrix -> Matrix -> Result +assertEq label expected actual = + if matrixEq expected actual + then pass label + else testFail label ("expected " ++ show expected ++ ", got " ++ show actual) + +assertPointEq :: String -> (Double, Double) -> (Double, Double) -> Result +assertPointEq label expected actual = + if pointEq expected actual + then pass label + else testFail label ("expected " ++ show expected ++ ", got " ++ show actual) + +assertBool :: String -> Bool -> Result +assertBool label True = pass label +assertBool label False = testFail label "condition false" + +assertDoubleEq :: String -> Double -> Double -> Result +assertDoubleEq label expected actual = + if approxEq expected actual + then pass label + else testFail label ("expected " ++ show expected ++ ", got " ++ show actual) + +assertTextEq :: String -> T.Text -> T.Text -> Result +assertTextEq label expected actual = + if expected == actual + then pass label + else testFail label ("expected " ++ show expected ++ ", got " ++ show actual) + +assertGlyphOrigin :: String -> Double -> Double -> Glyph -> Result +assertGlyphOrigin label x y g = + if approxEq x (glyphX g) && approxEq y (glyphY g) + then pass label + else testFail label ("expected origin (" ++ show x ++ "," ++ show y ++ "), got (" ++ show (glyphX g) ++ "," ++ show (glyphY g) ++ ")") + +assertGlyphWidth :: String -> Double -> Glyph -> Result +assertGlyphWidth label w g = + assertDoubleEq label w (glyphWidth g) + +assertGlyphSize :: String -> Double -> Glyph -> Result +assertGlyphSize label s g = + assertDoubleEq label s (glyphSize g) + +assertMapEq :: String -> M.Map Int Double -> M.Map Int Double -> Result +assertMapEq label expected actual = + if expected == actual + then pass label + else testFail label ("expected " ++ show expected ++ ", got " ++ show actual) + +sampleMatrices :: [Matrix] +sampleMatrices = + [ identity + , translate 3 4 + , scale 2 3 + , mkMatrix 1 2 3 4 5 6 + , multiply (scale 12 12) (translate 100 700) + ] + +samplePoints :: [(Double, Double)] +samplePoints = + [ (0, 0) + , (1, 0) + , (0, 1) + , (1, 1) + , (5, 7) + , (-2, 3.5) + ] + +main :: IO () +main = do + let results = + identityLeftResults + ++ identityRightResults + ++ applyIdentityResults + ++ associativityResults + ++ composeApplyResults + ++ translateScaleResults + ++ compoundPdfResults + ++ cmPremultiplyResults + ++ parseCIDWidthsResults + ++ simpleWidthAtResults + ++ interpretGeometryResults + ++ layoutParagraphResults + ++ sortLinesByReadingOrderResults + ++ layoutDocumentResults + ++ superscriptResults + ++ rubyResults + ++ interpretGraphicResults + ++ interpretMCIDResults + ++ structureTreeResults + ++ pageApiResults + ++ diffResults + ++ filterDecodeResults + ++ imageExtractResults + ++ formExtractResults + ++ taggedEndToEndResults + ++ textStreamResults + ++ tuiScrollResults + let failures = [msg | Fail msg <- results] + passed = length results - length failures + mapM_ reportResult results + putStrLn $ show passed ++ " cases passed" + when (not (null failures)) exitFailure + +reportResult :: Result -> IO () +reportResult (Pass label) = putStrLn $ label ++ ": PASS" +reportResult (Fail msg) = putStrLn msg + +identityLeftResults :: [Result] +identityLeftResults = + [ assertEq ("multiply identity m: " ++ show m) m (multiply identity m) + | m <- sampleMatrices + ] + +identityRightResults :: [Result] +identityRightResults = + [ assertEq ("multiply m identity: " ++ show m) m (multiply m identity) + | m <- sampleMatrices + ] + +applyIdentityResults :: [Result] +applyIdentityResults = + [ assertPointEq ("apply identity " ++ show p) p (apply identity p) + | p <- samplePoints + ] + +associativityMatrices :: (Matrix, Matrix, Matrix) +associativityMatrices = + ( mkMatrix 1 2 3 4 5 6 + , translate 1 2 + , scale 3 4 + ) + +associativityResults :: [Result] +associativityResults = + let (m1, m2, m3) = associativityMatrices + left = multiply (multiply m1 m2) m3 + right = multiply m1 (multiply m2 m3) + in [assertEq "associativity multiply (m1*m2)*m3 == m1*(m2*m3)" right left] + +composeApplyResults :: [Result] +composeApplyResults = + [ assertPointEq + ("apply (multiply m1 m2) " ++ show p ++ " == apply m2 (apply m1 p)") + (apply m2 (apply m1 p)) + (apply (multiply m1 m2) p) + | m1 <- sampleMatrices + , m2 <- sampleMatrices + , p <- samplePoints + ] + +translateScaleResults :: [Result] +translateScaleResults = + [ assertPointEq "apply (translate 3 4) (1,1)" (4, 5) (apply (translate 3 4) (1, 1)) + , assertPointEq "apply (scale 2 3) (5,7)" (10, 21) (apply (scale 2 3) (5, 7)) + ] + +compoundPdfResults :: [Result] +compoundPdfResults = + let m = multiply (scale 12 12) (translate 100 700) + in [ assertPointEq "compound scale*translate at origin" (100, 700) (apply m (0, 0)) + , assertPointEq "compound scale*translate at (1,0)" (112, 700) (apply m (1, 0)) + ] + +cmPremultiplyResults :: [Result] +cmPremultiplyResults = + let cmMat = scale 2 2 + ctm1 = multiply cmMat identity + textMat = scale 10 10 + trm = multiply (multiply textMat (translate 30 200)) ctm1 + in [ assertPointEq "cm premultiply: multiply cmMat ctm stores scale" + (0, 0) (apply ctm1 (0, 0)) + , assertPointEq "cm premultiply: scaled text rendering origin" + (60, 400) (apply trm (0, 0)) + , assertPointEq "cm premultiply: unit x vector length" + (2, 0) (applyVec ctm1 (1, 0)) + ] + +testFontWidth :: Int -> Double +testFontWidth 65 = 600 +testFontWidth 66 = 700 +testFontWidth 81 = 550 +testFontWidth 88 = 500 +testFontWidth 89 = 600 +testFontWidth _ = 500 + +testFontInfo :: FontInfo +testFontInfo = FontInfo + { fiEncoding = NullMap + , fiToUnicode = M.empty + , fiWidth = testFontWidth + , fiWidthV = const (-500) + , fiWMode = 0 + , fiBytesPerCode = 1 + , fiDefaultWidth = 500 + } + +verticalFontInfo :: FontInfo +verticalFontInfo = testFontInfo {fiWMode = 1} + +testResources :: M.Map T.Text Obj +testResources = M.fromList [("/Font", PdfDict M.empty)] + +testFonts :: M.Map T.Text FontInfo +testFonts = M.fromList [("/F1", testFontInfo)] + +runInterp :: String -> [Glyph] +runInterp content = + interpretContentWithFonts Nothing M.empty testResources testFonts (BSLC.pack content) + +runInterpVertical :: String -> [Glyph] +runInterpVertical content = + interpretContentWithFonts Nothing M.empty testResources (M.singleton "/F1" verticalFontInfo) (BSLC.pack content) + +interpretGeometryResults :: [Result] +interpretGeometryResults = + let ab = runInterp "BT /F1 10 Tf 100 700 Td (AB) Tj ET" + tmxy = runInterp "BT /F1 10 Tf 1 0 0 1 200 500 Tm (X) Tj ET" + tj = runInterp "BT /F1 10 Tf 50 400 Td [(A) -200 (B)] TJ ET" + scaled = runInterp "q 2 0 0 2 0 0 cm BT /F1 10 Tf 30 200 Td (Q) Tj Q ET" + restore = runInterp "q 2 0 0 2 0 0 cm BT /F1 10 Tf 10 10 Td (A) Tj ET Q BT /F1 10 Tf 10 10 Td (B) Tj ET" + vert = runInterpVertical "BT /F1 10 Tf 100 200 Td (A) Tj ET" + leadingDot = runInterp "q .913 0 0 .913 0 595.276 cm BT /F1 10 Tf 0 0 Td (X) Tj ET" + in [ assertBool "interpret Tj AB produces one segment" (length ab == 1) + , assertTextEq "interpret Tj AB text" (T.pack "AB") (glyphText (head ab)) + , assertGlyphOrigin "interpret Tj AB origin" 100 700 (head ab) + , assertGlyphWidth "interpret Tj AB width" 13 (head ab) + , assertGlyphSize "interpret Tj AB size" 10 (head ab) + , assertBool "interpret Tm produces one segment" (length tmxy == 1) + , assertGlyphOrigin "interpret Tm origin" 200 500 (head tmxy) + , assertGlyphWidth "interpret Tm width" 5 (head tmxy) + , assertBool "interpret TJ produces two segments" (length tj == 2) + , assertGlyphOrigin "interpret TJ first origin" 50 400 (tj !! 0) + , assertGlyphWidth "interpret TJ first width" 6 (tj !! 0) + , assertGlyphOrigin "interpret TJ second origin" 58 400 (tj !! 1) + , assertGlyphWidth "interpret TJ second width" 7 (tj !! 1) + , assertBool "interpret CTM scale produces one segment" (length scaled == 1) + , assertGlyphOrigin "interpret CTM scale origin" 60 400 (head scaled) + , assertGlyphSize "interpret CTM scale size" 20 (head scaled) + , assertGlyphWidth "interpret CTM scale width" 11 (head scaled) + , assertBool "interpret q/Q restore produces two segments" (length restore == 2) + , assertGlyphOrigin "interpret q/Q first origin scaled" 20 20 (restore !! 0) + , assertGlyphOrigin "interpret q/Q second origin restored" 10 10 (restore !! 1) + , assertBool "interpret vertical produces one segment" (length vert == 1) + , assertGlyphOrigin "interpret vertical origin" 100 200 (head vert) + , assertGlyphWidth "interpret vertical width" 5 (head vert) + , assertBool "interpret hex Tj without space" (length hexTj == 1) + , assertTextEq "interpret hex Tj text" (T.pack "AB") (glyphText (head hexTj)) + , assertBool "interpret leading-dot cm produces one segment" (length leadingDot == 1) + , assertGlyphSize "interpret leading-dot cm size" 9.13 (head leadingDot) + , assertGlyphWidth "interpret leading-dot cm width" 4.565 (head leadingDot) + ] + where + hexTj = runInterp "BT /F1 10 Tf 0 0 Td <4142>Tj ET" + +mkGlyph :: Double -> Double -> Double -> Double -> Int -> T.Text -> Glyph +mkGlyph x y w sz wmode txt = + Glyph + { glyphText = txt + , glyphX = x + , glyphY = y + , glyphWidth = w + , glyphSize = sz + , glyphFont = "/F1" + , glyphWMode = wmode + , glyphMCID = Nothing + } + +layoutParagraphResults :: [Result] +layoutParagraphResults = + let samePara = layoutParagraphs + [ ItemGlyph (mkGlyph 72 700 100 12 0 "Alpha") + , ItemGlyph (mkGlyph 72 686 100 12 0 "Beta") + ] + gapSplit = layoutParagraphs + [ ItemGlyph (mkGlyph 72 700 100 12 0 "First") + , ItemGlyph (mkGlyph 72 650 100 12 0 "Second") + ] + indentSplit = layoutParagraphs + [ ItemGlyph (mkGlyph 72 700 100 12 0 "Normal") + , ItemGlyph (mkGlyph 92 686 100 12 0 "Indented") + ] + ruleSplit = layoutParagraphs + [ ItemGlyph (mkGlyph 72 700 100 12 0 "Above") + , ItemGraphic (Rect 70 680 200 682) + , ItemGlyph (mkGlyph 72 660 100 12 0 "Below") + ] + latinSpace = layoutPageText + [ ItemGlyph (mkGlyph 72 700 6 12 0 "A") + , ItemGlyph (mkGlyph 85 700 6 12 0 "B") + ] + latinLowGap = layoutPageText + [ ItemGlyph (mkGlyph 72 700 36 9 0 "Word") + , ItemGlyph (mkGlyph 110.25 700 30 9 0 "Next") + ] + latinZeroGap = layoutPageText + [ ItemGlyph (mkGlyph 72 700 15 9 0 "Wor") + , ItemGlyph (mkGlyph 87 700 10 9 0 "d") + ] + cjkHalfGap = layoutPageText + [ ItemGlyph (mkGlyph 72 700 12 12 0 "\x3068") + , ItemGlyph (mkGlyph 90 700 12 12 0 "\x3046") + ] + hyphenJoin = head (layoutParagraphs + [ ItemGlyph (mkGlyph 72 511.83 60 10 0 "authenti-") + , ItemGlyph (mkGlyph 72 496.527 40 10 0 "cated") + ]) + cjkNoSpace = layoutPageText + [ ItemGlyph (mkGlyph 72 700 12 12 0 "\x3068") + , ItemGlyph (mkGlyph 84 700 12 12 0 "\x3046") + ] + fallbackZero = layoutParagraphs + [ ItemGlyph (mkGlyph 72 700 10 0 0 "X") + , ItemGlyph (mkGlyph 72 686 10 0 0 "Y") + ] + vertCols = layoutParagraphs + [ ItemGlyph (mkGlyph 500 700 10 12 1 "\x3042") + , ItemGlyph (mkGlyph 500 680 10 12 1 "\x3044") + , ItemGlyph (mkGlyph 440 700 10 12 1 "\x3046") + , ItemGlyph (mkGlyph 440 680 10 12 1 "\x3048") + ] + outlierSplit = layoutParagraphs + [ ItemGlyph (mkGlyph 70 384 8 8 0 "\x5b9f") + , ItemGlyph (mkGlyph 255 387 4 6 0 "\x2020") + , ItemGlyph (mkGlyph 259 (-167) 3 5 0 "2") + , ItemGlyph (mkGlyph 263 384 8 8 0 "\x3092") + , ItemGlyph (mkGlyph 310 384 8 8 0 "\x8a18") + , ItemGlyph (mkGlyph 62 372 8 8 0 "\x6cd5") + , ItemGlyph (mkGlyph 70 372 8 8 0 "\x3067") + ] + cjkWrapSplit = layoutParagraphs + [ ItemGlyph (mkGlyph 310 384 8 8 0 "\x8a18") + , ItemGlyph (mkGlyph 62 372 8 8 0 "\x6cd5") + , ItemGlyph (mkGlyph 70 372 8 8 0 "\x3067") + , ItemGlyph (mkGlyph 78 372 8 8 0 "\x898b") + ] + dingbatBullet = layoutPageText + [ ItemGlyph (mkGlyph 60 434 0 9 0 "r") + , ItemGlyph (mkGlyph 66 431 0 8 0 "HTTP") + ] + letteredList = layoutParagraphs + [ ItemGlyph (mkGlyph 63 275 6 8 0 "a.") + , ItemGlyph (mkGlyph 74 275 40 8 0 "\x533a\x5225") + , ItemGlyph (mkGlyph 63 260 6 8 0 "b.") + , ItemGlyph (mkGlyph 70 260 40 8 0 "\x30bd\x30fc\x30b9") + , ItemGlyph (mkGlyph 58 241 40 8 0 "\x4fe1\x983c") + ] + hangList = layoutParagraphs + [ ItemGlyph (mkGlyph 66 201 80 8 0 "\x5909\x6570\x306f\x3053\x3068") + , ItemGlyph (mkGlyph 66 186 80 8 0 "\x30bd\x30fc\x30b9\x3053\x3068") + , ItemGlyph (mkGlyph 66 171 80 8 0 "\x30b9\x30ad\x30fc\x30de\x3053\x3068") + ] + codeBlockText = layoutPageText + [ ItemGlyph (mkGlyph 274 511 10 6 0 "\x30b3\x30fc\x30c9") + , ItemGlyph (mkGlyph 40 506 4 6 0 "1") + , ItemGlyph (mkGlyph 55 506 20 6 0 "is.into_iter()") + , ItemGlyph (mkGlyph 40 499 4 6 0 "2") + , ItemGlyph (mkGlyph 70 499 20 6 0 ".flatten()") + ] + in [ assertBool "layout same-baseline two lines one paragraph" (length samePara == 1) + , assertTextEq "layout same-baseline joined" + (T.pack "Alpha Beta") (head samePara) + , assertBool "layout large gap two paragraphs" (length gapSplit == 2) + , assertBool "layout indent starts new paragraph" (length indentSplit == 2) + , assertBool "layout graphic rule splits paragraphs" (length ruleSplit == 2) + , assertTextEq "layout Latin gap inserts space" (T.pack "A B\n") latinSpace + , assertTextEq "layout Latin low gap inserts space" (T.pack "Word Next\n") latinLowGap + , assertTextEq "layout Latin zero gap no space" (T.pack "Word\n") latinZeroGap + , assertTextEq "layout CJK half-size gap no space" (T.pack "\x3068\x3046\n") cjkHalfGap + , assertTextEq "layout hyphen line join" (T.pack "authenti-cated") hyphenJoin + , assertBool "layout hyphen line join no spurious space" + (not (T.isInfixOf "authenti- cated" hyphenJoin)) + , assertTextEq "layout CJK gap no space" (T.pack "\x3068\x3046\n") cjkNoSpace + , assertBool "layout fallback zero sizes" (length fallbackZero == 1) + , assertTextEq "layout fallback joins with newline" + (T.pack "X\nY") (head fallbackZero) + , assertBool "layout vertical two columns" (length vertCols == 2) + , assertTextEq "layout vertical first column" + (T.pack "\x3042\x3044") (head vertCols) + , assertTextEq "layout vertical second column" + (T.pack "\x3046\x3048") (vertCols !! 1) + , assertBool "layout outlier glyph does not split paragraph" (length outlierSplit == 1) + , assertBool "layout outlier glyph keeps CJK wrap" + (T.isInfixOf (T.pack "\x8a18\x6cd5\x3067") (head outlierSplit)) + , assertBool "layout CJK wrap keeps one paragraph" (length cjkWrapSplit == 1) + , assertTextEq "layout CJK wrap joined text" + (T.pack "\x8a18\x6cd5\x3067\x898b") (head cjkWrapSplit) + , assertTextEq "layout dingbat r prefix becomes bullet" + (T.pack "\8226 HTTP\n") dingbatBullet + , assertBool "layout lettered list items split" (length letteredList == 3) + , assertBool "layout hang-indent list items split" (length hangList == 3) + , assertBool "layout code block keeps newlines" + (length (T.lines codeBlockText) >= 3) + , assertBool "layout code caption separate from block" + (length (layoutParagraphs + [ ItemGlyph (mkGlyph 274 511 10 6 0 "\x30b3\x30fc\x30c9") + , ItemGlyph (mkGlyph 40 506 4 6 0 "1") + , ItemGlyph (mkGlyph 55 506 20 6 0 "is") + ]) == 2) + ] + +sortLinesByReadingOrderResults :: [Result] +sortLinesByReadingOrderResults = + let rowOrderItems = + [ ItemGlyph (mkGlyph 72 650 30 12 0 "Bot-C") + , ItemGlyph (mkGlyph 72 700 30 12 0 "Top-A") + , ItemGlyph (mkGlyph 200 700 30 12 0 "Top-B") + ] + rowOrderText = layoutPageText rowOrderItems + vertReversedItems = + [ ItemGlyph (mkGlyph 440 700 10 12 1 "\x3046") + , ItemGlyph (mkGlyph 440 680 10 12 1 "\x3048") + , ItemGlyph (mkGlyph 500 700 10 12 1 "\x3042") + , ItemGlyph (mkGlyph 500 680 10 12 1 "\x3044") + ] + vertReversed = layoutParagraphs vertReversedItems + sameRowLines = + [ mkTestLine 700 72 78 0 "A" + , mkTestLine 700 200 206 0 "B" + ] + sortedSameRow = map lineText (sortLinesByReadingOrder sameRowLines) + in [ assertBool "sort rows: Top before Bot" + (let t = T.stripEnd rowOrderText + (preA, _) = T.breakOn "Top-A" t + (preB, _) = T.breakOn "Bot-C" t + in T.isInfixOf "Top-A" t + && T.isInfixOf "Bot-C" t + && T.length preA <= T.length preB) + , assertTextEq "sort same row left-to-right" + (T.pack "A B") (T.intercalate " " sortedSameRow) + , assertBool "sort vertical columns right-to-left" + (length vertReversed == 2 + && head vertReversed == T.pack "\x3042\x3044" + && vertReversed !! 1 == T.pack "\x3046\x3048") + , assertTextEq "sortLinesByReadingOrder direct" + (T.pack "A B") (T.intercalate " " sortedSameRow) + ] + +mkTestLine :: Double -> Double -> Double -> Int -> T.Text -> Line +mkTestLine baseline inlineStart inlineEnd wmode txt = + Line + { lineBaseline = baseline + , lineInlineStart = inlineStart + , lineInlineEnd = inlineEnd + , lineSize = 12 + , lineFirstInline = inlineStart + , lineWMode = wmode + , lineText = txt + , lineMarkers = [] + , lineLastSuper = False + } + +headerBodyFooter :: Int -> T.Text -> T.Text -> [PageItem] +headerBodyFooter n header body = + [ ItemGlyph (mkGlyph 250 750 80 12 0 header) + , ItemGlyph (mkGlyph 72 700 100 12 0 body) + , ItemGlyph (mkGlyph 280 50 10 12 0 (T.pack (show n))) + ] + +layoutDocumentResults :: [Result] +layoutDocumentResults = + let repeatedHdr = + layoutDocument + [ headerBodyFooter 1 "RepeatHeader" "Body one." + , headerBodyFooter 2 "RepeatHeader" "Body two." + , headerBodyFooter 3 "RepeatHeader" "Body three." + ] + pageNums = + layoutDocument + [ headerBodyFooter 1 "UniqueA" "Alpha text." + , headerBodyFooter 2 "UniqueB" "Beta text." + ] + uniqueHdr = + layoutDocument + [ headerBodyFooter 1 "HdrA" "One." + , headerBodyFooter 2 "HdrB" "Two." + , headerBodyFooter 3 "HdrC" "Three." + ] + cjkMerge = + layoutDocument + [ [ ItemGlyph (mkGlyph 72 700 12 12 0 "\x6587\x3068") + ] + , [ ItemGlyph (mkGlyph 72 700 12 12 0 "\x3046\x308b") + ] + ] + terminalSplit = + layoutDocument + [ [ ItemGlyph (mkGlyph 72 700 12 12 0 "\x7d42\x308f\x308a\x3002") + ] + , [ ItemGlyph (mkGlyph 72 700 12 12 0 "\x59cb\x307e\x308a") + ] + ] + indentPageSplit = + layoutDocument + [ [ ItemGlyph (mkGlyph 72 700 100 12 0 "First part") + ] + , [ ItemGlyph (mkGlyph 84 700 100 12 0 "Indented start") + , ItemGlyph (mkGlyph 72 680 100 12 0 "Same page body") + ] + ] + indent1em = + layoutParagraphs + [ ItemGlyph (mkGlyph 72 700 100 12 0 "Normal") + , ItemGlyph (mkGlyph 84 686 100 12 0 "Indented") + ] + titlePage = + layoutDocument + [ [ ItemGlyph (mkGlyph 250 750 80 12 0 "Unique Title Header") + , ItemGlyph (mkGlyph 250 400 80 12 0 "Book Title") + ] + , headerBodyFooter 2 "RepeatHeader" "Chapter one." + , headerBodyFooter 3 "RepeatHeader" "Chapter two." + ] + twoLineRepeated = + layoutDocument + (replicate 10 + [ ItemGlyph (mkGlyph 250 750 80 12 0 "RepeatHeader") + , ItemGlyph (mkGlyph 72 700 100 12 0 "Body only.") + ]) + alternatingHdr = + layoutDocument + (zipWith + (\hdr body -> headerBodyFooter 1 hdr body) + (cycle ["vi 序文", "序文 vii"]) + (replicate 10 "Body text.")) + in [ assertBool "layout doc repeated header removed" + (not (T.isInfixOf "RepeatHeader" repeatedHdr)) + , assertBool "layout doc bare page numbers removed" + (not (any (\n -> T.strip n `elem` [T.pack "1", T.pack "2"]) (T.lines pageNums))) + , assertBool "layout doc unique headers kept" + (T.isInfixOf "HdrA" uniqueHdr + && T.isInfixOf "HdrB" uniqueHdr + && T.isInfixOf "HdrC" uniqueHdr) + , assertTextEq "layout doc CJK cross-page merge" + (T.pack "\x6587\x3068\x3046\x308b\n") + cjkMerge + , assertBool "layout doc terminal punctuation splits pages" + (length (T.lines (T.stripEnd terminalSplit)) >= 2) + , assertBool "layout doc indented page start splits" + (length (T.lines (T.stripEnd indentPageSplit)) >= 2) + , assertBool "layout doc indent break at 1.0em" (length indent1em == 2) + , assertBool "layout doc title page keeps all lines" + (T.isInfixOf "Unique Title Header" titlePage + && T.isInfixOf "Book Title" titlePage) + , assertBool "layout doc two-line page repeated header removed" + (not (T.isInfixOf "RepeatHeader" twoLineRepeated)) + , assertBool "layout doc alternating roman headers removed" + (not (T.isInfixOf "vi 序文" alternatingHdr) + && not (T.isInfixOf "序文 vii" alternatingHdr)) + ] + +-- A body line at y=700 size 10, with a superscript marker (size 7, +-- +3.5 above) and footnote apparatus at page bottom. +superscriptResults :: [Result] +superscriptResults = + let body t = ItemGlyph (mkGlyph 72 700 60 10 0 t) + supAt x t = ItemGlyph (mkGlyph x 703.5 4 7 0 t) + bodyAfter x t = ItemGlyph (mkGlyph x 700 10 10 0 t) + merged = layoutParagraphs + [ body "text", supAt 132 "\8224", supAt 136 "1", bodyAfter 140 "." ] + farSupGlyphs = + [ g | ItemGlyph g <- [body "text", ItemGlyph (mkGlyph 132 708.5 4 7 0 "\8224")]] + rebase = layoutParagraphs + [ ItemGlyph (mkGlyph 72 87.6 4 7 0 "\8224") + , ItemGlyph (mkGlyph 76 87.6 4 7 0 "1") + , ItemGlyph (mkGlyph 82 84.3 100 9 0 "note body") + ] + fnPage = + [ body "anchor", supAt 132 "\8224", supAt 136 "1" + , ItemGlyph (mkGlyph 72 500 60 10 0 "more body text here") + , ItemGraphic (Rect 72 95 200 95.5) + , ItemGlyph (mkGlyph 72 87.6 3 7 0 "\8224") + , ItemGlyph (mkGlyph 75 87.6 3 7 0 "1") + , ItemGlyph (mkGlyph 80 84.3 60 8 0 "the note") + ] + fnOn = T.concat (layoutParagraphsWith (defaultLayoutOptions {optFootnotes = True}) fnPage) + fnOff = T.concat (layoutParagraphs fnPage) + unmatchedAnchor = T.concat + (layoutParagraphsWith (defaultLayoutOptions {optFootnotes = True}) + [ body "anchor", supAt 132 "\8224", supAt 136 "9" + , ItemGlyph (mkGlyph 72 500 60 10 0 "more body text here") + ]) + orphanBlock = T.concat + (layoutParagraphsWith (defaultLayoutOptions {optFootnotes = True}) + [ body "just body content" + , ItemGlyph (mkGlyph 72 500 60 10 0 "more body text here") + , ItemGlyph (mkGlyph 72 87.6 3 7 0 "\8224") + , ItemGlyph (mkGlyph 75 87.6 3 7 0 "2") + , ItemGlyph (mkGlyph 80 84.3 60 8 0 "orphan note") + ]) + in [ assertBool "superscript merges inline" (length merged == 1) + , assertTextEq "superscript inline text order" + (T.pack "text\8224\&1.") (head merged) + , assertBool "superscript beyond window stays separate line" + (length (linesFromGlyphs farSupGlyphs) == 2) + , assertBool "marker line rebases onto body" (length rebase == 1) + , assertTextEq "rebased line text" (T.pack "\8224\&1note body") (head rebase) + , assertBool "footnotes on: body inlined" + (T.isInfixOf "anchorthe note" fnOn) + , assertBool "footnotes on: block removed" + (not (T.isInfixOf "\8224\&1 the note" fnOn)) + , assertBool "footnotes off: marker kept" + (T.isInfixOf "anchor\8224\&1" fnOff) + , assertBool "footnotes off: block kept" + (T.isInfixOf "the note" fnOff) + , assertBool "unmatched anchor kept as-is" + (T.isInfixOf "anchor\8224\&9" unmatchedAnchor) + , assertBool "orphan footnote block stays" + (T.isInfixOf "orphan note" orphanBlock) + ] + +rubyResults :: [Result] +rubyResults = + let kanji = "\x6f22" -- 漢 + kanRuby = "\x304b\x3093" -- かん + mixedBase = "\x9727\x306e\x30ed\x30f3\x30c9\x30f3\x8b66\x8996\x5e81" + mixedRuby = "\x30b9\x30b3\x30c3\x30c8\x30e9\x30f3\x30c9\x30e4\x30fc\x30c9" + horizPage = + [ ItemGlyph (mkGlyph 72 700 12 12 0 kanji) + , ItemGlyph (mkGlyph 72 710 6 7 0 "\x304b") + , ItemGlyph (mkGlyph 78 710 6 7 0 "\x3093") + ] + vertPage = + [ ItemGlyph (mkGlyph 500 700 12 12 1 kanji) + , ItemGlyph (mkGlyph 488 700 14 7 1 kanRuby) + ] + mixedPage = + [ ItemGlyph (mkGlyph 72 700 120 12 0 mixedBase) + , ItemGlyph (mkGlyph 72 710 80 7 0 mixedRuby) + ] + interleavedPage = + let bodyY = 110.85098199999993 + rubyY = 118.75664899999992 + bodySz = 8.410829900000001 + rubySz = 4.2053693 + in [ ItemGlyph (mkGlyph 66.33 bodyY 100.93 bodySz 0 "\x64cd\4f5c\3092") + , ItemGlyph (mkGlyph 167.26 rubyY 8.41 rubySz 0 "\x3079\x304d") + , ItemGlyph (mkGlyph 167.26 bodyY 8.41 bodySz 0 "\x5186") + , ItemGlyph (mkGlyph 175.67 rubyY 8.41 rubySz 0 "\x3068\x3046") + , ItemGlyph (mkGlyph 175.67 bodyY 84.11 bodySz 0 "\x7b49\306a\3082\306e\306b\3059\308b\3053\3068\12290") + ] + rubyOn = layoutParagraphsWith (defaultLayoutOptions {optRuby = True}) + rubyOff = layoutParagraphsWith defaultLayoutOptions + horizOn = T.concat (rubyOn horizPage) + horizOff = T.concat (rubyOff horizPage) + vertOn = T.concat (rubyOn vertPage) + mixedOn = T.concat (rubyOn mixedPage) + in [ assertBool "needsAozoraBar single hiragana" (not (needsAozoraBar "\x3042\x304a\x305e\x3089")) + , assertBool "needsAozoraBar single kanji" (not (needsAozoraBar "\x9752\x7a7a\x6587\x5eab")) + , assertBool "needsAozoraBar mixed scripts" (needsAozoraBar mixedBase) + , assertTextEq "aozoraRuby single script" + (kanji `T.append` "\x300a" `T.append` kanRuby `T.append` "\x300b") + (aozoraRuby kanji kanRuby) + , assertTextEq "aozoraRuby mixed base bar" + (mixedBase `T.append` "\xff5c\x300a" `T.append` mixedRuby `T.append` "\x300b") + (aozoraRuby mixedBase mixedRuby) + , assertBool "ruby horizontal geometry" + (T.isInfixOf (kanji `T.append` "\x300a" `T.append` kanRuby `T.append` "\x300b") horizOn) + , assertBool "ruby vertical geometry" + (T.isInfixOf (kanji `T.append` "\x300a" `T.append` kanRuby `T.append` "\x300b") vertOn) + , assertBool "ruby mixed base bar in layout" + (T.isInfixOf ("\xff5c\x300a" `T.append` mixedRuby `T.append` "\x300b") mixedOn) + , assertBool "ruby off leaves plain text" + (not (T.isInfixOf "\x300a" horizOff) && T.isInfixOf kanji horizOff) + , assertBool "ruby interleaved stream order" + (T.isInfixOf + ("\x5186\x7b49\x300a\x3079\x304d\x3068\x3046\x300b") + (T.concat (rubyOn interleavedPage))) + , assertBool "ruby interleaved off suppresses orphan lines" + (let out = T.concat (rubyOff interleavedPage) + in T.isInfixOf "\x5186\x7b49" out + && not (T.isInfixOf "\x3079\x304d" out) + && not (T.isInfixOf "\x3068\x3046" out)) + ] + +interpretGraphicResults :: [Result] +interpretGraphicResults = + let items = interpretContentWithFontsItems Nothing M.empty testResources testFonts + (BSLC.pack "10 0 0 10 50 100 cm 0 0 20 10 re f") + graphics = [r | ItemGraphic r <- items] + in [ assertBool "interpret re f emits one graphic" (length graphics == 1) + , assertRectEq "interpret re f bbox x0" 50 (rectX0 (head graphics)) + , assertRectEq "interpret re f bbox y0" 100 (rectY0 (head graphics)) + , assertRectEq "interpret re f bbox x1" 250 (rectX1 (head graphics)) + , assertRectEq "interpret re f bbox y1" 200 (rectY1 (head graphics)) + ] + +assertRectEq :: String -> Double -> Double -> Result +assertRectEq label expected actual = assertDoubleEq label expected actual + +parseCIDWidthsResults :: [Result] +parseCIDWidthsResults = + [ assertMapEq "parseCIDWidths consecutive form" + (M.fromList [(10, 100), (11, 200), (12, 300)]) + (parseCIDWidths + [ PdfNumber 10 + , PdfArray [PdfNumber 100, PdfNumber 200, PdfNumber 300] + ]) + , assertMapEq "parseCIDWidths range form" + (M.fromList [(5, 500), (6, 500), (7, 500)]) + (parseCIDWidths [PdfNumber 5, PdfNumber 7, PdfNumber 500]) + , assertMapEq "parseCIDWidths mixed forms" + (M.fromList [(1, 50), (2, 50), (10, 100), (11, 200)]) + (parseCIDWidths + [ PdfNumber 1, PdfNumber 2, PdfNumber 50 + , PdfNumber 10 + , PdfArray [PdfNumber 100, PdfNumber 200] + ]) + ] + +simpleWidthAtResults :: [Result] +simpleWidthAtResults = + let widths = [PdfNumber 250, PdfNumber 500, PdfNumber 750] + in [ assertDoubleEq "simpleWidthAt in range" 500 (simpleWidthAt 32 widths 0 33) + , assertDoubleEq "simpleWidthAt below range" 0 (simpleWidthAt 32 widths 0 20) + , assertDoubleEq "simpleWidthAt above range" 0 (simpleWidthAt 32 widths 0 40) + , assertDoubleEq "simpleWidthAt missing width fallback" 99 (simpleWidthAt 0 [PdfText "x"] 99 0) + ] + +interpretMCIDResults :: [Result] +interpretMCIDResults = + let bdc = runInterp "/P <> BDC BT /F1 10 Tf 0 0 Td (A) Tj ET EMC" + nested = runInterp "/Span BMC /P <> BDC BT /F1 10 Tf 10 0 Td (B) Tj ET EMC EMC" + inherit = runInterp "/Span BMC BT /F1 10 Tf 0 0 Td (C) Tj ET EMC" + afterPop = runInterp "/P <> BDC BT /F1 10 Tf 0 0 Td (D) Tj ET EMC BT /F1 10 Tf 20 0 Td (E) Tj ET" + underflow = runInterp "BT /F1 10 Tf 0 0 Td (F) Tj ET EMC" + in [ assertBool "interpret BDC MCID one glyph" (length bdc == 1) + , assertBool "interpret BDC MCID value" (glyphMCID (head bdc) == Just 0) + , assertBool "interpret nested BMC inherits MCID" (length nested == 1) + , assertBool "interpret nested MCID value" (glyphMCID (head nested) == Just 1) + , assertBool "interpret BMC no MCID on glyph" (all (== Nothing) (map glyphMCID inherit)) + , assertBool "interpret EMC clears MCID" (glyphMCID (afterPop !! 1) == Nothing) + , assertBool "interpret EMC underflow tolerated" (length underflow == 1) + ] + +mkTestDoc :: M.Map Int [Obj] -> Document +mkTestDoc objs = + Document (M.fromList [("/Root", ObjRef 1)]) objs Nothing M.empty M.empty + +structureTreeResults :: [Result] +structureTreeResults = + let objs = M.fromList + [ (1, [PdfDict (M.fromList + [ ("/Type", PdfName "/Catalog") + , ("/StructTreeRoot", ObjRef 6) + ])]) + , (6, [PdfDict (M.fromList + [ ("/Type", PdfName "/StructTreeRoot") + , ("/K", ObjRef 8) + ])]) + , (8, [PdfDict (M.fromList + [ ("/Type", PdfName "/StructElem") + , ("/S", PdfName "/Document") + , ("/K", PdfArray [ObjRef 9, PdfNumber 2, ObjRef 10, ObjRef 11]) + ])]) + , (9, [PdfDict (M.fromList + [ ("/Type", PdfName "/StructElem") + , ("/S", PdfName "/Sect") + , ("/Pg", ObjRef 3) + , ("/K", PdfNumber 0) + ])]) + , (10, [PdfDict (M.fromList + [ ("/Type", PdfName "/MCR") + , ("/Pg", ObjRef 3) + , ("/MCID", PdfNumber 1) + ])]) + , (11, [PdfDict (M.fromList + [ ("/Type", PdfName "/OBJR") + , ("/Obj", ObjRef 99) + ])]) + ] + doc = mkTestDoc objs + parsed = structTree doc :: PdfResult (Maybe StructElem) + order = case parsed of + Right (Just root) -> logicalOrder root + _ -> [] + in [ assertBool "structTree parses hand-built tree" (isRight parsed) + , assertBool "structTree root type" (rootType parsed == "/StructTreeRoot") + , assertBool "structTree nested sect kid" (hasSect parsed) + , assertBool "structTree K int becomes MCID" (elem (3, 0) (mcidPairs order)) + , assertBool "structTree MCR dict becomes MCID" (elem (3, 1) (mcidPairs order)) + , assertBool "structTree OBJR skipped" (length order == 2) + ] + where + isRight (Right _) = True + isRight _ = False + rootType (Right (Just (StructElem t _))) = t + rootType _ = "" + hasSect (Right (Just root)) = "/Sect" `elem` elemTypes root + hasSect _ = False + elemTypes (StructElem t kids) = t : concatMap kidTypes kids + kidTypes (KidElem e) = elemTypes e + kidTypes _ = [] + mcidPairs = map (\(_, page, mcid) -> (page, mcid)) + +taggedEndToEndResults :: [Result] +taggedEndToEndResults = + [ runTaggedFixture + ] + +pageApiResults :: [Result] +pageApiResults = + [ runMultipagePageCount + , runMultipagePageRefAt + , runParagraphsPageParagraphs + ] + +runMultipagePageCount :: Result +runMultipagePageCount = + let path = "data/fixtures/multipage.pdf" + in unsafePerformIO $ do + result <- openDocument path Nothing + return $ case result of + Right doc -> + case pageCount doc of + Right n -> assertEqInt "multipage.pdf pageCount" 3 n + Left err -> testFail "multipage.pdf pageCount" (show err) + Left err -> testFail "multipage.pdf pageCount open" (show err) + +runMultipagePageRefAt :: Result +runMultipagePageRefAt = + let path = "data/fixtures/multipage.pdf" + in unsafePerformIO $ do + result <- openDocument path Nothing + return $ case result of + Right doc -> + case pageRefAt doc 1 of + Right r1 -> + case pageRefAt doc 3 of + Right r3 -> + assertBool "multipage.pdf pageRefAt refs distinct" + (r1 /= r3 && r1 == 3 && r3 == 5) + Left err -> testFail "multipage.pdf pageRefAt page 3" (show err) + Left err -> testFail "multipage.pdf pageRefAt page 1" (show err) + Left err -> testFail "multipage.pdf pageRefAt open" (show err) + +runParagraphsPageParagraphs :: Result +runParagraphsPageParagraphs = + let path = "data/fixtures/paragraphs.pdf" + in unsafePerformIO $ do + result <- openDocument path Nothing + return $ case result of + Right doc -> + case pageRefAt doc 1 of + Right ref -> + case pageParagraphs doc ref defaultLayoutOptions of + Right ps -> + assertBool "paragraphs.pdf pageParagraphs count" + (length ps == 3 + && T.isInfixOf "Line one of A." (head ps) + && T.isInfixOf "Indent line B1." (ps !! 1) + && T.strip (last ps) == "Line C only.") + Left err -> testFail "paragraphs.pdf pageParagraphs" (show err) + Left err -> testFail "paragraphs.pdf pageRefAt" (show err) + Left err -> testFail "paragraphs.pdf pageParagraphs open" (show err) + +assertEqInt :: String -> Int -> Int -> Result +assertEqInt label expected actual = + if expected == actual + then pass label + else testFail label ("expected " ++ show expected ++ ", got " ++ show actual) + +{-# NOINLINE runMultipagePageCount #-} +{-# NOINLINE runMultipagePageRefAt #-} +{-# NOINLINE runParagraphsPageParagraphs #-} + +diffResults :: [Result] +diffResults = + [ assertBool "diffParagraphs identical lists" (null (diffParagraphs ps ps)) + , assertBool "diffParagraphs one change" + ( case diffParagraphs [T.pack "First paragraph text", T.pack "Second"] + [T.pack "First paragraph changed", T.pack "Second"] of + [TextChange{changeParaA = Just 0, changeParaB = Just 0, changeOld = old, changeNew = new}] -> + old == T.pack "First paragraph text" + && new == T.pack "First paragraph changed" + _ -> False + ) + , assertBool "diffParagraphs insert only" + ( case diffParagraphs [T.pack "A"] [T.pack "A", T.pack "B"] of + [TextChange{changeParaB = Just 1, changeOld = old, changeNew = new}] -> + T.null old && new == T.pack "B" + _ -> False + ) + , assertBool "diffParagraphs delete only" + ( case diffParagraphs [T.pack "A", T.pack "B"] [T.pack "A"] of + [TextChange{changeParaA = Just 1, changeOld = old, changeNew = new}] -> + old == T.pack "B" && T.null new + _ -> False + ) + , runMultipageSelfDiff + ] + where + ps = [T.pack "Alpha", T.pack "Beta"] + +runMultipageSelfDiff :: Result +runMultipageSelfDiff = + let path = "data/fixtures/multipage.pdf" + in unsafePerformIO $ do + result <- openDocument path Nothing + return $ case result of + Right doc -> + case compareDocuments defaultLayoutOptions doc doc of + Right changes -> assertBool "multipage.pdf self-diff empty" (null changes) + Left err -> testFail "multipage.pdf self-diff" (show err) + Left err -> testFail "multipage.pdf self-diff open" (show err) + +{-# NOINLINE runMultipageSelfDiff #-} + +filterDecodeResults :: [Result] +filterDecodeResults = + [ assertBool "DCTDecode pass-through" + ( case decodeStreamBytes dctDict (BSLC.pack jpegStub) of + Right bs -> bs == BSC.pack jpegStub + _ -> False + ) + , assertBool "no filter pass-through" + ( case decodeStreamBytes noFilterDict (BSLC.pack "plain") of + Right bs -> bs == BSC.pack "plain" + _ -> False + ) + ] + where + dctDict = M.fromList [("/Filter", PdfName "/DCTDecode")] + noFilterDict = M.empty + jpegStub = "\xff\xd8\xff\xe0" ++ replicate 10 'x' ++ "\xff\xd9" + +imageExtractResults :: [Result] +imageExtractResults = + pngEncodeResults + ++ classifyImageResults + ++ pageImageFixtureResults + +pngEncodeResults :: [Result] +pngEncodeResults = + let w = 2 + h = 2 + rgb = BS.pack (map (fromIntegral :: Int -> Word8) [255, 0, 0, 0, 255, 0, 0, 0, 255, 255, 255, 255]) + pngSig = BS.pack (map (fromIntegral :: Int -> Word8) [137, 80, 78, 71, 13, 10, 26, 10]) + in [ assertBool "encodePngRgb signature" + ( case encodePngRgb w h rgb of + Right png -> BS.take 8 png == pngSig + _ -> False + ) + , assertBool "encodePngRgb IHDR chunk" + ( case encodePngRgb w h rgb of + Right png -> BS.length png > 40 + _ -> False + ) + ] + +classifyImageResults :: [Result] +classifyImageResults = + let dctDict = M.fromList [("/Filter", PdfName "/DCTDecode")] + jpegBs = BSC.pack jpegStub + in [ assertBool "classifyImageBytes DCTDecode" + ( case classifyImageBytes M.empty dctDict jpegBs of + Right (ImageJPEG, bs) -> bs == jpegBs + _ -> False + ) + , assertBool "classifyImageBytes raw RGB to PNG" + ( case classifyImageBytes M.empty rgbDict (BS.replicate 12 0) of + Right (ImagePNG, png) -> + BS.take 8 png + == BS.pack (map (fromIntegral :: Int -> Word8) [137, 80, 78, 71, 13, 10, 26, 10]) + _ -> False + ) + ] + where + rgbDict = + M.fromList + [ ("/Width", PdfNumber 2) + , ("/Height", PdfNumber 2) + , ("/BitsPerComponent", PdfNumber 8) + , ("/ColorSpace", PdfName "/DeviceRGB") + ] + jpegStub = "\xff\xd8\xff\xe0" ++ replicate 10 'x' ++ "\xff\xd9" + +pageImageFixtureResults :: [Result] +pageImageFixtureResults = + [ runJpegImageFixture + , runJpegImageHits + , runFormNestedImageHits + ] + +runJpegImageFixture :: Result +runJpegImageFixture = + let path = "data/fixtures/jpeg-image.pdf" + in unsafePerformIO $ do + result <- openDocument path Nothing + return $ case result of + Right doc -> + case extractPageImages doc 1 of + Right [img] + | piFormat img == ImageJPEG + && BS.take 2 (piBytes img) == BS.pack [0xff, 0xd8] -> + pass "jpeg-image.pdf extractPageImages" + Right xs -> + testFail "jpeg-image.pdf extractPageImages" ("expected 1 image, got " ++ show (length xs)) + Left err -> testFail "jpeg-image.pdf extractPageImages" (show err) + Left err -> testFail "jpeg-image.pdf open" (show err) + +runJpegImageHits :: Result +runJpegImageHits = + let path = "data/fixtures/jpeg-image.pdf" + in unsafePerformIO $ do + result <- openDocument path Nothing + return $ case result of + Right doc -> + case pageRefAt doc 1 of + Right r -> + case interpretPageImageHits doc r of + Right [(ref, bbox)] + | ref == 5 && approxEq 50 (rectX0 bbox) -> + pass "jpeg-image interpretPageImageHits" + Right xs -> testFail "jpeg-image hits" ("unexpected hits " ++ show xs) + Left err -> testFail "jpeg-image hits" (show err) + Left err -> testFail "jpeg-image pageRefAt" (show err) + Left err -> testFail "jpeg-image open hits" (show err) + +{-# NOINLINE runJpegImageFixture #-} +{-# NOINLINE runJpegImageHits #-} + +runFormNestedImageHits :: Result +runFormNestedImageHits = + let path = "test/fixtures/form-nested-image.pdf" + in unsafePerformIO $ do + result <- openDocument path Nothing + return $ case result of + Right doc -> + case pageRefAt doc 1 of + Right r -> + case interpretPageImageHits doc r of + Right [(ref, bbox)] + | ref == 5 && approxEq 50 (rectX0 bbox) -> + pass "form-nested-image interpretPageImageHits" + Right xs -> testFail "form-nested-image hits" ("unexpected hits " ++ show xs) + Left err -> testFail "form-nested-image hits" (show err) + Left err -> testFail "form-nested-image pageRefAt" (show err) + Left err -> testFail "form-nested-image open hits" (show err) + +{-# NOINLINE runFormNestedImageHits #-} + +formExtractResults :: [Result] +formExtractResults = + [ runFormExportParentNames + , runFormExportParentExtract + , runFm42Integration + ] + +runFormExportParentNames :: Result +runFormExportParentNames = + let path = "test/fixtures/form-export-parent.pdf" + in unsafePerformIO $ do + result <- openDocument path Nothing + return $ case result of + Right doc -> + case pageFormNames doc 1 of + Right names -> + assertBool "form-export-parent pageFormNames" + (names == [T.pack "Fm0"]) + Left err -> testFail "form-export-parent pageFormNames" (show err) + Left err -> testFail "form-export-parent open names" (show err) + +runFormExportParentExtract :: Result +runFormExportParentExtract = + let path = "test/fixtures/form-export-parent.pdf" + in unsafePerformIO $ do + result <- openDocument path Nothing + case result of + Right doc -> + case extractFormPdf doc 1 (T.pack "Fm0") of + Right bytes + | BSC.take 4 bytes /= BSC.pack "%PDF" -> + return $ testFail "form-export-parent extractFormPdf" "missing %PDF header" + | otherwise -> do + tmpDir <- getTemporaryDirectory + let out = tmpDir "hpdft-form-export-test.pdf" + BS.writeFile out bytes + opened <- openDocument out Nothing + return $ case opened of + Right doc2 -> + case pageCount doc2 of + Right 1 -> pass "form-export-parent extractFormPdf" + Right n -> + testFail "form-export-parent extractFormPdf" + ("expected 1 page, got " ++ show n) + Left err -> testFail "form-export-parent extractFormPdf pageCount" (show err) + Left err -> testFail "form-export-parent extractFormPdf reopen" (show err) + Left err -> return $ testFail "form-export-parent extractFormPdf" (show err) + Left err -> return $ testFail "form-export-parent open extract" (show err) + +runFm42Integration :: Result +runFm42Integration = + unsafePerformIO $ do + let path = "/home/k16/work/wwtawwta-systems/publish/8965333188777.pdf" + exists <- doesFileExist path + if not exists + then return $ pass "8965333188777 Fm42 integration (skipped)" + else do + result <- openDocument path Nothing + case result of + Right doc -> + case extractFormPdf doc 205 (T.pack "Fm42") of + Right bytes + | BSC.take 4 bytes /= BSC.pack "%PDF" -> + return $ testFail "8965333188777 Fm42 extract" "missing %PDF header" + | otherwise -> do + tmpDir <- getTemporaryDirectory + let out = tmpDir "hpdft-fm42-test.pdf" + BS.writeFile out bytes + opened <- openDocument out Nothing + return $ case opened of + Right doc2 -> + case pageCount doc2 of + Right 1 -> pass "8965333188777 Fm42 extract" + Right n -> + testFail "8965333188777 Fm42 extract" + ("expected 1 page, got " ++ show n) + Left err -> testFail "8965333188777 Fm42 pageCount" (show err) + Left err -> testFail "8965333188777 Fm42 reopen" (show err) + Left err -> return $ testFail "8965333188777 Fm42 extract" (show err) + Left err -> return $ testFail "8965333188777 open" (show err) + +{-# NOINLINE runFormExportParentNames #-} +{-# NOINLINE runFormExportParentExtract #-} +{-# NOINLINE runFm42Integration #-} + +runTaggedFixture :: Result +runTaggedFixture = + let path = "data/fixtures/tagged.pdf" + in unsafePerformIO $ do + result <- pdfToTextTaggedBS path (Just "") + return $ case result of + Right bs -> + let actual = BSLC.unpack bs + expected = "First paragraph.\n\nSecond paragraph.\n" + in assertTextEq "tagged.pdf end-to-end" (T.pack expected) (T.pack actual) + Left err -> testFail "tagged.pdf end-to-end" (show err) + +{-# NOINLINE runTaggedFixture #-} + +textStreamResults :: [Result] +textStreamResults = + [ runTextStreamConcat + , runTextStreamPageOrder + ] + +runTextStreamConcat :: Result +runTextStreamConcat = + unsafePerformIO $ do + result <- openDocument "data/fixtures/multipage.pdf" Nothing + case result of + Left err -> return $ testFail "pdfToTextStreamDoc concat open" (show err) + Right doc -> do + let (expected, _) = pdfToTextDoc doc + ref <- newIORef BSL.empty + _ <- pdfToTextStreamDoc doc $ \_ _ bs -> modifyIORef ref (<> bs) + actual <- readIORef ref + return $ assertTextEqLazy "pdfToTextStreamDoc concat == pdfToTextDoc" expected actual + +{-# NOINLINE runTextStreamConcat #-} + +runTextStreamPageOrder :: Result +runTextStreamPageOrder = + unsafePerformIO $ do + result <- openDocument "data/fixtures/multipage.pdf" Nothing + case result of + Left err -> return $ testFail "pdfToTextStreamDoc page order open" (show err) + Right doc -> do + ref <- newIORef ([] :: [(Int, Int)]) + _ <- pdfToTextStreamDoc doc $ \pg total _ -> modifyIORef ref ((pg, total) :) + events <- readIORef ref + return $ assertBool "pdfToTextStreamDoc page order" + (reverse events == [(1, 3), (2, 3), (3, 3)]) + +{-# NOINLINE runTextStreamPageOrder #-} + +assertTextEqLazy :: String -> BSL.ByteString -> BSL.ByteString -> Result +assertTextEqLazy label expected actual = + if expected == actual + then pass label + else testFail label ("length expected " ++ show (BSL.length expected) + ++ ", got " ++ show (BSL.length actual)) + +tuiScrollResults :: [Result] +tuiScrollResults = + let st = ScrollState {scrollTopLine = 0, scrollTotalLines = 20, scrollTextRows = 5} + in [ assertBool "tuiScroll initial top" (scrollTopLine (initialScrollState 5) == 0) + , assertBool "tuiScroll scrollBy down" + (scrollTopLine (scrollBy 3 st) == 3) + , assertBool "tuiScroll clamp at end" + (scrollTopLine (scrollBy 100 st) == 15) + , assertBool "tuiScroll scrollToTop" + (scrollTopLine (scrollToTop (scrollBy 10 st)) == 0) + , assertBool "tuiScroll scrollToEnd" + (scrollTopLine (scrollToEnd st) == 15) + , assertBool "tuiScroll half page down" + (scrollTopLine (scrollHalfPageDown st) == 2) + , assertBool "tuiScroll visible range" + (visibleLineRange (scrollBy 4 st) == (4, 9)) + , assertBool "tuiScroll status line" + (statusLineNumber (scrollBy 4 st) == 5) + , assertBool "tuiScroll search forward hit" + (searchForwardFrom (== "b") 0 ["a", "b", "c", "b"] == Just 1) + , assertBool "tuiScroll search forward from offset" + (searchForwardFrom (== "b") 2 ["a", "b", "c", "b"] == Just 3) + , assertBool "tuiScroll search forward miss" + (searchForwardFrom (== "z") 0 ["a", "b"] == Nothing) + , assertBool "tuiScroll search forward negative start clamps" + (searchForwardFrom (== "a") (-3) ["a", "b"] == Just 0) + , assertBool "tuiScroll search backward hit" + (searchBackwardFrom (== "b") 3 ["a", "b", "c", "b"] == Just 3) + , assertBool "tuiScroll search backward from offset" + (searchBackwardFrom (== "b") 2 ["a", "b", "c", "b"] == Just 1) + , assertBool "tuiScroll search backward miss" + (searchBackwardFrom (== "z") 3 ["a", "b"] == Nothing) + , assertBool "tuiScroll search backward negative start" + (searchBackwardFrom (== "a") (-1) ["a"] == Nothing) + , assertBool "tuiScroll display width ascii" + (stringDisplayWidth "abc" == 3) + , assertBool "tuiScroll display width CJK" + (stringDisplayWidth "あい" == 4) + , assertBool "tuiScroll display width mixed" + (stringDisplayWidth "/検索x" == 6) + , assertBool "tuiScroll clip CJK at boundary" + (clipToDisplayWidth 3 "あい" == "あ") + , assertBool "tuiScroll clip mixed" + (clipToDisplayWidth 4 "aあい" == "aあ") + , assertBool "tuiScroll pad CJK to width" + (padToDisplayWidth 6 "あ" == "あ ") + , assertBool "tuiScroll pad straddling wide char" + (stringDisplayWidth (padToDisplayWidth 4 "あい") == 4) + ] +