hpdft 0.1.1.3 → 0.4.6.0
raw patch · 41 files changed
+10626/−1096 lines, 41 filesdep +arraydep +cryptondep +deepseqdep ~basedep ~bytestringdep ~containersnew-component:exe:extract-textnew-component:exe:interpret-pagenew-component:exe:page-api
Dependencies added: array, crypton, deepseq, dlist, filepath, parallel, terminal-size
Dependency ranges changed: base, bytestring, containers, directory, file-embed, parsec, text, zlib
Files
- CHANGELOG.md +178/−0
- README.md +119/−17
- TuiPreview.hs +382/−0
- TuiScroll.hs +118/−0
- dev/0.3-roadmap.md +165/−0
- dev/0.4-roadmap.md +227/−0
- dev/0.5-text-ux.md +138/−0
- dev/README.md +12/−0
- dev/performance-0.4.md +182/−0
- docs/library.md +217/−0
- examples/extract-text/Main.hs +60/−0
- examples/page-api/Main.hs +94/−0
- hpdft.cabal +120/−23
- hpdft.hs +701/−194
- scripts/bench_book.sh +7/−0
- scripts/bench_pages.hs +47/−0
- scripts/interpret_page.hs +54/−0
- src/PDF/CFF.hs +51/−42
- src/PDF/Cmap.hs +51/−29
- src/PDF/ContentStream.hs +133/−86
- src/PDF/Definition.hs +67/−38
- src/PDF/Diff.hs +184/−0
- src/PDF/Document.hs +155/−0
- src/PDF/DocumentStructure.hs +1015/−446
- src/PDF/Encrypt.hs +306/−0
- src/PDF/Error.hs +90/−0
- src/PDF/FormExtract.hs +442/−0
- src/PDF/Image.hs +266/−0
- src/PDF/Interpret.hs +1086/−0
- src/PDF/Layout.hs +1293/−0
- src/PDF/Matrix.hs +45/−0
- src/PDF/Object.hs +261/−48
- src/PDF/OpenType.hs +19/−16
- src/PDF/Outlines.hs +201/−76
- src/PDF/PDFIO.hs +36/−75
- src/PDF/Page.hs +153/−0
- src/PDF/Structure.hs +189/−0
- src/PDF/Text.hs +365/−0
- src/PDF/Type1.hs +7/−6
- test/Golden.hs +69/−0
- test/Unit.hs +1321/−0
+ CHANGELOG.md view
@@ -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
README.md view
@@ -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. +[](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 <footnote> 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**.
+ TuiPreview.hs view
@@ -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"
+ TuiScroll.hs view
@@ -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) ' '
+ dev/0.3-roadmap.md view
@@ -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 系で脚注本文を `<footnote>…</footnote>` にインライン化 |++`-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 化） |
+ dev/0.4-roadmap.md view
@@ -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 までの完了内容
+ dev/0.5-text-ux.md view
@@ -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）
+ dev/README.md view
@@ -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` を実行してください。
+ dev/performance-0.4.md view
@@ -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 計測 |
+ docs/library.md view
@@ -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/).
+ examples/extract-text/Main.hs view
@@ -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
+ examples/page-api/Main.hs view
@@ -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
hpdft.cabal view
@@ -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
hpdft.hs view
@@ -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 <footnote> 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 <footnote> 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)
+ scripts/bench_book.sh view
@@ -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
+ scripts/bench_pages.hs view
@@ -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
+ scripts/interpret_page.hs view
@@ -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
src/PDF/CFF.hs view
@@ -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]
src/PDF/Cmap.hs view
@@ -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-
src/PDF/ContentStream.hs view
@@ -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
src/PDF/Definition.hs view
@@ -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)-
+ src/PDF/Diff.hs view
@@ -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
+ src/PDF/Document.hs view
@@ -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)
src/PDF/DocumentStructure.hs view
@@ -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
+ src/PDF/Encrypt.hs view
@@ -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
+ src/PDF/Error.hs view
@@ -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
+ src/PDF/FormExtract.hs view
@@ -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"+ ]
+ src/PDF/Image.hs view
@@ -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]+ ]
+ src/PDF/Interpret.hs view
@@ -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
+ src/PDF/Layout.hs view
@@ -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 @\<footnote\>@ 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 <footnote>...</footnote>.+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, "<footnote>", b, "</footnote>"]+ , 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
+ src/PDF/Matrix.hs view
@@ -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)
src/PDF/Object.hs view
@@ -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)
src/PDF/OpenType.hs view
@@ -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
src/PDF/Outlines.hs view
@@ -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
src/PDF/PDFIO.hs view
@@ -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)
+ src/PDF/Page.hs view
@@ -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)+ }
+ src/PDF/Structure.hs view
@@ -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 []
+ src/PDF/Text.hs view
@@ -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 _ -> ("", [])
src/PDF/Type1.hs view
@@ -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"))
+ test/Golden.hs view
@@ -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
+ test/Unit.hs view
@@ -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 "anchor<footnote>the note</footnote>" 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 <</MCID 0>> BDC BT /F1 10 Tf 0 0 Td (A) Tj ET EMC"+ nested = runInterp "/Span BMC /P <</MCID 1>> 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 <</MCID 0>> 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)+ ]+