106 lines
3.4 KiB
Racket
106 lines
3.4 KiB
Racket
#lang racket/base
|
|
(require racket/contract/base
|
|
racket/class
|
|
racket/gui/base
|
|
framework
|
|
"prefs.rkt"
|
|
"controller.rkt"
|
|
"display.rkt"
|
|
"text.rkt")
|
|
|
|
#|
|
|
|
|
Code for generating images that look like the contents of a syntax
|
|
browser, with the same pretty-printing, mark-based coloring,
|
|
suffixing, etc.
|
|
|
|
TODO: tacked arrows
|
|
|
|
|#
|
|
|
|
(provide/contract
|
|
[print-syntax-columns
|
|
(parameter/c (or/c exact-positive-integer? 'infinity))]
|
|
[print-syntax-to-png
|
|
(->* (syntax? path-string?)
|
|
(#:columns (or/c exact-positive-integer? 'infinity))
|
|
any)]
|
|
[print-syntax-to-bitmap
|
|
(->* (syntax?)
|
|
(#:columns (or/c exact-positive-integer? 'infinity))
|
|
(is-a?/c bitmap%))]
|
|
[print-syntax-to-eps
|
|
(->* (syntax? path-string?)
|
|
(#:columns (or/c exact-positive-integer? 'infinity))
|
|
any)])
|
|
|
|
;; print-syntax-columns : (parameter-of (U number 'infinity))
|
|
(define print-syntax-columns (make-parameter 40))
|
|
|
|
;; print-syntax-to-png : syntax path -> void
|
|
(define (print-syntax-to-png stx file
|
|
#:columns [columns (print-syntax-columns)])
|
|
(let ([bmp (print-syntax-to-bitmap stx #:columns columns)])
|
|
(send bmp save-file file 'png))
|
|
(void))
|
|
|
|
;; print-syntax-to-bitmap : syntax -> (is-a?/c bitmap%)
|
|
(define (print-syntax-to-bitmap stx
|
|
#:columns [columns (print-syntax-columns)])
|
|
(define t (prepare-editor stx columns))
|
|
(define admin (new dummy-admin%))
|
|
(send t set-admin admin)
|
|
(define dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1))))
|
|
(define char-width
|
|
(let* ([sl (send t get-style-list)]
|
|
[style (send sl find-named-style (editor:get-default-color-style-name))]
|
|
[font (send style get-font)])
|
|
(send dc set-font font)
|
|
(send dc get-char-width)))
|
|
(let ([ew (box 0.0)]
|
|
[eh (box 0.0)])
|
|
(send t set-min-width (* columns char-width))
|
|
(send t get-extent ew eh)
|
|
(let* ([w (inexact->exact (unbox ew))]
|
|
[h (inexact->exact (unbox eh))]
|
|
[bmp (make-object bitmap% w (+ 1 h))]
|
|
[ps (new ps-setup%)])
|
|
(send dc set-bitmap bmp)
|
|
(send dc set-background (make-object color% "White"))
|
|
(send dc clear)
|
|
(send ps set-margin 0 0)
|
|
(send ps set-editor-margin 0 0)
|
|
(parameterize ((current-ps-setup ps))
|
|
(send t print-to-dc dc 1))
|
|
bmp)))
|
|
|
|
;; print-syntax-to-eps : syntax path -> void
|
|
(define (print-syntax-to-eps stx file
|
|
#:columns [columns (print-syntax-columns)])
|
|
(define t (prepare-editor stx columns))
|
|
(define ps-setup (new ps-setup%))
|
|
(send ps-setup set-mode 'file)
|
|
(send ps-setup set-file file)
|
|
(send ps-setup set-scaling 1 1)
|
|
(parameterize ((current-ps-setup ps-setup))
|
|
(send t print #f #f 'postscript #f #f #t)))
|
|
|
|
(define (prepare-editor stx columns)
|
|
(define t (new browser-text%))
|
|
(define sl (send t get-style-list))
|
|
(send t change-style (send sl find-named-style (editor:get-default-color-style-name)))
|
|
(print-syntax-to-editor stx t
|
|
(new controller%) (new syntax-prefs/readonly%)
|
|
columns (send t last-position))
|
|
t)
|
|
|
|
;; dummy editor-admin
|
|
(define dummy-admin%
|
|
(class editor-admin%
|
|
(define the-dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1))))
|
|
(define/override (get-dc [x #f] [y #f])
|
|
(when x (set-box! x 0.0))
|
|
(when y (set-box! y 0.0))
|
|
the-dc)
|
|
(super-new)))
|