From bd00bd53033108ea69c24c665a60074da089d3e7 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Mon, 1 Nov 2010 17:35:16 -0600 Subject: [PATCH] add first draft of a mixin for text% objects that displays line numbers original commit: dc6350244d4d324dae97e863c2fc4a38d1b1dac3 --- collects/framework/private/sig.rkt | 2 + collects/framework/private/text.rkt | 253 +++++++++++++++++++++++++++- 2 files changed, 252 insertions(+), 3 deletions(-) diff --git a/collects/framework/private/sig.rkt b/collects/framework/private/sig.rkt index 48f83b6c..702b0178 100644 --- a/collects/framework/private/sig.rkt +++ b/collects/framework/private/sig.rkt @@ -163,6 +163,7 @@ (define-signature text-class^ (basic<%> first-line<%> + line-numbers<%> foreground-color<%> hide-caret/selection<%> nbsp->space<%> @@ -199,6 +200,7 @@ basic-mixin first-line-mixin + line-numbers-mixin foreground-color-mixin hide-caret/selection-mixin nbsp->space-mixin diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 72d5bbb1..0fe9a276 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -11,12 +11,13 @@ WARNING: printf is rebound in the body of the unit to always scheme/class scheme/match scheme/path - "sig.ss" - "../gui-utils.ss" - "../preferences.ss" + "sig.rkt" + "../gui-utils.rkt" + "../preferences.rkt" mred/mred-sig mrlib/interactive-value-port setup/dirs + racket/list (prefix-in srfi1: srfi/1)) (require setup/xref scribble/xref @@ -3696,3 +3697,249 @@ designates the character that triggers autocompletion (define backup-autosave% (editor:backup-autosave-mixin clever-file-format%)) (define searching% (searching-mixin backup-autosave%)) (define info% (info-mixin (editor:info-mixin searching%))) + +;; ============================================================ +;; line number text% + +(define line-numbers<%> + (interface () show-line-numbers!)) + +(define line-numbers-mixin + (mixin ((class->interface text%)) (line-numbers<%>) + (super-new) + (inherit get-visible-line-range + get-visible-position-range + find-position + line-start-position + line-end-position) + (define show-line-numbers? #t) + (define/public (show-line-numbers! what) + (set! show-line-numbers? what)) + (define old-origin-x 0) + (define old-origin-y 0) + (define cached-snips (list)) + (define need-to-recalculate-snips #f) + (define (get-style-font) + (let* ([style-list (send this get-style-list)] + [std (or (send style-list find-named-style "Standard") + #t + #; + (send style-list basic-style))]) + (send std get-font))) + + ;; get the y position of a snip + (define (get-snip-y snip) + (define x (box 0)) + (define y (box 0)) + (send this get-snip-location snip x y) + (unbox y)) + + ;; returns an ordered list of snip y positions + ;; TODO: cache this list and update it incrementally + (define (snip-heights snip dc) + (define-struct snip-size (start end)) + (define (get-size snip) + (define x (box 0)) + (define y (box 0)) + (send this get-snip-location snip x y) + (define width (box 0)) + (define height (box 0)) + (send snip get-extent dc (unbox x) (unbox y) width height) + (make-snip-size (unbox y) (+ (unbox y) (unbox height)))) + ;; size2 can be merged into size1 + (define (can-merge? size1 size2) + (and (between (snip-size-start size1) + (snip-size-start size2) + (snip-size-end size1)) + #; + (between (snip-size-start size1) + (snip-size-end size2) + (snip-size-end size1)))) + (define (merge-sizes sizes) + (match sizes + [(list size1 size2 rest ...) + #; + (printf "Merge ~a,~a into ~a,~a?\n" + (snip-size-start size2) (snip-size-end size2) + (snip-size-start size1) (snip-size-end size1)) + (if (can-merge? size1 size2) + (merge-sizes (cons size1 rest)) + (cons size1 (merge-sizes (cons size2 rest))))] + [else sizes])) + + (let loop ([all '()] + [snip snip]) + (if snip + (loop (cons (get-size snip) all) (send snip next)) + (map (lambda (size) + (snip-size-start size)) + (merge-sizes (remove-duplicates + (sort (reverse all) + (lambda (a b) + (< (snip-size-start a) + (snip-size-start b))))))))) + #; + (let loop ([all '()] + [snip snip]) + (if snip + (loop (cons snip all) (send snip next)) + (remove-duplicates (sort (reverse (map get-snip-y all)) <))))) + + (define (show-all-snips dc) + (define snip (send this find-first-snip)) + (newline) + (define (next snip) + (when snip + (define x (box 0)) + (define y (box 0)) + (send this get-snip-location snip x y) + #; + (printf "Snip ~a at ~a,~a\n" snip (unbox x) (unbox y)) + (next (send snip next)))) + (next snip)) + + ;; a <= b <= c + (define (between low what high) + (and (>= what low) + (<= what high))) + + ;; finds the first item in the sequence for which `ok?' returns true + (define (find-first sequence ok?) + (define-values (more? get) (sequence-generate sequence)) + (let loop () + (if (more?) + (if (ok? (get)) + #t + (loop)) + #f))) + + ;; true if the `y' location is within the positions specified by the + ;; lines `start' and `end' + (define (ok-height y start end) + (define position (find-position 0 y)) + ;; this is why we need some `break' ability in for loops + (find-first (in-range start end) + (lambda (line) + (define low (line-start-position line)) + (define high (line-end-position line)) + (between low position high)))) + + (define/augment (on-insert start length) + (set! need-to-recalculate-snips #t)) + + (define (get-snip-heights dc) + (when need-to-recalculate-snips + (set! need-to-recalculate-snips #f) + (set! cached-snips (snip-heights (send this find-first-snip) dc))) + cached-snips) + + (define (draw-line-numbers dc left top right bottom dx dy) + (define start-line (box 0)) + (define end-line (box 0)) + (get-visible-line-range start-line end-line #f) + (define start-position (box 0)) + (define end-position (box 0)) + #; + (get-visible-position-range start-line end-line) + (define (draw-text . args) + (send/apply dc draw-text args)) + (define old-pen (send dc get-pen)) + #; + (send dc set-font (send this get-font)) + (send dc set-font (get-style-font)) + (define-values (font-width font-height baseline space) + (send dc get-text-extent "a")) + #; + (printf "Style list ~a\n" (send this get-style-list)) + #; + (printf "My height ~a text height ~a\n" font-height (text-height (send this get-dc) "a")) + (send dc set-text-foreground (make-object color% "black")) + #; + (send dc set-pen "red" 2 'solid) + #; + (send dc set-pen (send (send this get-dc) get-pen)) + #; + (printf "First snip at ~a\n" (send this find-first-snip)) + #; + (show-all-snips dc) + #; + (printf "Snip positions ~a\n" (snip-heights (send this find-first-snip) dc)) + + #; + (printf "Repaint from ~a to ~a dx ~a dy ~a visible ~a ~a\n" top bottom dx dy (unbox start-line) (unbox end-line)) + #; + (printf "Snips ~a\n" (snip-heights (send this find-first-snip) dc)) + + (define heights (get-snip-heights dc)) + (for ([y heights] + [line (in-naturals 1)]) + #; + (printf "ok height? ~a ~a is ~a\n" y line (ok-height y (unbox start-line) (unbox end-line))) + (when (and (ok-height y (unbox start-line) (add1 (unbox end-line))) + (between top y bottom)) + #; + (printf "~a at ~a\n" line (+ dy y)) + (draw-text (number->string line) 0 (+ dy y)))) + + #; + (for ([i (in-range top bottom font-height)] + [y (snip-heights (send this find-first-snip) dc)] + [line (in-naturals 1)]) + (define point (round (inexact->exact (/ i font-height)))) + #; + (printf "Draw ~a at ~a\n" (add1 point) point) + (printf "y ~a top ~a bottom ~a dy ~a\n" y top bottom dy) + (when (and (>= y top) + (<= y bottom)) + (draw-text (number->string (+ (unbox start-line) line)) + 0 (+ dy y))) + #; + (draw-text (number->string (+ (unbox start-line) (add1 point))) + 0 place + #; + (+ dy (* point font-height)))) + + #; + (for ([i (in-range 0 (- (unbox end-line) (unbox start-line)))]) + (draw-text (number->string (add1 i)) 0 (* i font-height))) + #; + (send dc set-pen old-pen) + #; + (define-values (line-x x1 x2 x3) + (send dc get-text-extent "10000")) + (define line-x (text-width dc "10000")) + (send dc draw-line line-x (+ dy top) line-x (+ dy bottom)) + ) + + (define (text-width dc stuff) + (define-values (font-width font-height baseline space) + (send dc get-text-extent stuff)) + font-width) + + (define (text-height dc stuff) + (define-values (font-width height baseline space) + (send dc get-text-extent stuff)) + height) + + (define/override (on-paint before? dc left top right bottom dx dy draw-caret) + (when show-line-numbers? + (if before? + (let () + ;; save old origin and push it to the right a little bit + ;; TODO: maybe allow the line numbers to be drawn on the right hand side? + (define-values (x y) (send dc get-origin)) + (set! old-origin-x x) + (set! old-origin-y y) + #| + (define start (box 0)) + (define end (box 0)) + (get-visible-line-range start end) + |# + (define-values (font-width font-height baseline space) + (send dc get-text-extent "10000")) + (send dc set-origin (+ x (text-width dc "100000")) y)) + (begin + (send dc set-origin old-origin-x old-origin-y) + (draw-line-numbers dc left top right bottom dx dy)))) + (super on-paint before? dc left top right bottom dx dy draw-caret)) + ))