typesetting/pitfall/pitfall/document.rkt

#lang pitfall/racket
(require "reference.rkt" "object.rkt" "page.rkt")
(require "vector.rkt" "color.rkt" "fonts.rkt" "text.rkt")
(provide PDFDocument)

(define mixed% (text-mixin (fonts-mixin (color-mixin (vector-mixin object%)))))

(define PDFDocument
  (class mixed% ; actually is an instance of readable.Stream, which is an input port
    (init-field [options (mhash)])
    (super-new)

    (field [byte-strings empty] ; list of byte chunks to push onto; simulates interface of stream.readable
           [version 1.3] ; PDF version
           [compress (hash-ref options 'compress #t)] ; Whether streams should be compressed
           [_pageBuffer null]
           [_pageBufferStart 0]
           [_offsets null] ; The PDF object store
           [_waiting 0]
           [_ended #f]
           [_offset 0]
           [_root (ref this
                       (mhash 'Type "Catalog"
                              'Pages (ref this
                                          (mhash 'Type "Pages"
                                                 'Count 0
                                                 'Kids empty))))] ; top object
           [page #f] ; The current page
           [x 0]
           [y 0]
           [info (mhash
                  'Producer "PitfallKit"
                  'Creator "PitfallKit"
                  'CreationDate (seconds->date (if (test-mode)
                                                   0
                                                   (current-seconds)) #f))]  ; Initialize the metadata
           [op #f] ; for `pipe`
           [_info #f]) ; for `end`

    ;; Initialize mixins
    (· this initColor)
    (· this initVector)
    (· this initFonts)
    (· this initText)
    #;(· this initImages) ; todo

    (as-methods
     addPage
     flushPages
     ref
     push
     _write
     addContent
     _refEnd
     pipe
     end
     _finalize)

    (for ([(key val) (in-hash (hash-ref options 'info (hash)))]) ; if no 'info key, nothing will be copied from (hash)
      (hash-set! info key val))

    ;; Write the header
    (_write this (format "%PDF-~a" version)) ;  PDF version
    (let ([c (integer->char #xFF)])
      (_write this (string-append "%" (string c c c c)))) ; 4 binary chars, as recommended by the spec

    ;; Add the first page
    (unless (not (hash-ref options 'autoFirstPage #t))
      (addPage this))))

    
(define/contract (addPage this [options-arg (· this options)])
  (() (hash?) . ->*m . object?)
  ;; end the current page if needed
  (unless (hash-ref (· this options) 'bufferPages #f)
    (send this flushPages))

  ;; create a page object
  (set-field! page this (make-object PDFPage this options-arg))
  (push-end-field! _pageBuffer this (· this page))
  ;; add the page to the object store
  (define pages (· this _root data Pages data))
  (hash-update! pages 'Kids (curry cons (· this page dictionary)) null)
  (hash-update! pages 'Count add1)

  ;; reset x and y coordinates
  (set-field! x this (· this page margins left))
  (set-field! y this (· this page margins top))
  ;; flip PDF coordinate system so that the origin is in
  ;; the top left rather than the bottom left
  (set-field! _ctm this default-ctm-value)
  (send this transform 1 0 0 -1 0 (· this page height))

  #;(@emit "pageAdded") ; from eventemitter interface
  this)


(define/contract (flushPages this)
  (->m list?)
  ;; this local variable exists so we're future-proof against
  ;; reentrant calls to flushPages.
  (define pages (· this _pageBuffer))
  (set-field! _pageBuffer this empty)
  (increment-field! _pageBufferStart this (length pages))
  (·map end pages))


;; every js function argument is 'undefined' by default
;; so even a function defined without default values
;; can be called without arguments
(define/contract (ref this [data (mhash)])
  (() (hash?) . ->*m . (is-a?/c PDFReference))
  (define newref (make-object PDFReference this (add1 (length (· this _offsets))) data))
  (push-end-field! _offsets this #f) ; placeholder for this object's offset once it is finalized
  (increment-field! _waiting this)
  newref)


(define/contract (push this chunk)
  (any/c . ->m . void?)
  (push-field! byte-strings this chunk))


(define/contract (_write this data)
  (any/c . ->m . void?)
  (let ([data (if (not (isBuffer? data))
                  (newBuffer (string-append data "\n"))
                  data)])
    (push this data)
    (increment-field! _offset this (buffer-length data))
    (void)))


(define/contract (addContent this data)
  (any/c . ->m . object?)
  (send (· this page) write data)
  this)


(define/contract (_refEnd this ref)
  ((is-a?/c PDFReference) . ->m . void?)
  (set-field! _offsets this (for/list ([(offset idx) (in-indexed (· this _offsets))])
                              (if (= (· ref id) (add1 idx))
                                  (· ref offset)
                                  offset)))
  (increment-field! _waiting this -1)
  (if (and (zero? (· this _waiting)) (· this _ended))
      (· this _finalize)
      (set-field! _ended this #f)))


(define/contract (pipe this port)
  (port? . ->m . void?)
  (set-field! op this port))


(define/contract (end this)
  (->m boolean?)
  (flushPages this)
  (set-field! _info this (ref this))
  (for ([(key val) (in-hash (· this info))])
    ;; upgrade string literal to String struct
    (hash-set! (· this _info data) key (if (string? val) (String val) val)))
  (· this _info end)

  (for ([font (in-hash-values (· this _fontFamilies))])
    (· font finalize))

  (· this _root end)
  (· this _root data Pages end)

  (if (zero? (· this _waiting))
      (· this _finalize)
      (set-field! _ended this #t))

  #t)


(define/contract (_finalize this [fn #f])
  (() ((or/c procedure? #f)) . ->*m . void?)
  ;; generate xref
  (define xref-offset (· this _offset))
  (with-method ([this-write (this _write)])
    (define this-offsets (· this _offsets)) 
    (this-write "xref")
    (this-write (format "0 ~a" (add1 (length this-offsets))))
    (this-write "0000000000 65535 f ")
    (for ([offset (in-list this-offsets)])
      (this-write (string-append
                   (~r offset #:min-width 10 #:pad-string "0")
                   " 00000 n ")))
    (this-write "trailer") ;; trailer
    (this-write (convert
                 (mhash 'Size (add1 (length this-offsets))
                        'Root (· this _root)
                        'Info (· this _info))))
    (this-write "startxref")
    (this-write (number xref-offset))
    (this-write "%%EOF"))

  ;; end the stream
  ;; in node you (@push null) which signals to the stream
  ;; to copy to its output port
  ;; here we'll do it manually
  (define this-op (· this op))
  (copy-port (open-input-bytes (apply bytes-append (reverse (· this byte-strings)))) this-op)
  (close-output-port this-op))


(module+ test
  (define d (new PDFDocument)))