committing the tests
original commit: 50b959c7b9f52ad4f1542908078f1fdf0a9f357b
This commit is contained in:
parent
a82730944d
commit
0224d867e8
|
@ -0,0 +1,4 @@
|
|||
(require (lib "aligned-pasteboard.ss" "mrlib"))
|
||||
(with-handlers ([exn? (lambda (x) #f)])
|
||||
(send (new pasteboard%) insert (new aligned-editor-snip% (editor (new horizontal-pasteboard%))))
|
||||
#t)
|
23
collects/mrlib/private/aligned-pasteboard/tests/minimal.ss
Normal file
23
collects/mrlib/private/aligned-pasteboard/tests/minimal.ss
Normal file
|
@ -0,0 +1,23 @@
|
|||
(require
|
||||
"../aligned-editor-container.ss"
|
||||
"../aligned-pasteboard.ss"
|
||||
(lib "debug.ss" "mike-lib"))
|
||||
|
||||
(define my-string-snip%
|
||||
(class string-snip%
|
||||
(init-field label)
|
||||
(rename [super-size-cache-invalid size-cache-invalid])
|
||||
(define/override (size-cache-invalid)
|
||||
(mytrace size-cache-invalid ()
|
||||
(super-size-cache-invalid)))
|
||||
(super-make-object label)))
|
||||
|
||||
(define f (new frame% (label "test") (width 200) (height 200)))
|
||||
(define e (new vertical-pasteboard%))
|
||||
(define c (new aligned-editor-canvas% (editor e) (parent f)))
|
||||
(define pb (new vertical-pasteboard%))
|
||||
(define s (new aligned-editor-snip% (editor pb) (stretchable-height #f) (stretchable-width #f)))
|
||||
(send pb insert (new my-string-snip% (label "Long snip")))
|
||||
(send pb insert (new my-string-snip% (label "Longer snip")))
|
||||
(send e insert s)
|
||||
(send f show #t)
|
|
@ -0,0 +1,28 @@
|
|||
(require
|
||||
"../aligned-editor-container.ss"
|
||||
"../aligned-pasteboard.ss")
|
||||
|
||||
(define pb (new horizontal-pasteboard%))
|
||||
(send* pb
|
||||
(insert (make-object string-snip% "Call") #f)
|
||||
(insert (new editor-snip% (editor (new text%))) #f))
|
||||
(define z (new aligned-editor-snip% (editor pb) (stretchable-height #f) (stretchable-width #f)))
|
||||
(define f (new frame% (label "more-tests-text") (width 200) (height 200)))
|
||||
(define e (new vertical-pasteboard%))
|
||||
(define c (new aligned-editor-canvas% (editor e) (parent f)))
|
||||
(send e insert z)
|
||||
(send f show #t)
|
||||
|
||||
;;;;;;;;;;
|
||||
;; exploration
|
||||
(require "../snip-lib.ss")
|
||||
(define (margin snip)
|
||||
(let ([left (box 0)]
|
||||
[top (box 0)]
|
||||
[right (box 0)]
|
||||
[bottom (box 0)])
|
||||
(send snip get-margin left top right bottom)
|
||||
(list (cons 'left (unbox left))
|
||||
(cons 'right (unbox right))
|
||||
(cons 'top (unbox top))
|
||||
(cons 'bottom (unbox bottom)))))
|
|
@ -0,0 +1,28 @@
|
|||
(require
|
||||
"../aligned-editor-container.ss"
|
||||
"../aligned-pasteboard.ss")
|
||||
|
||||
(define pb (new horizontal-pasteboard%))
|
||||
(send* pb
|
||||
(insert (make-object string-snip% "Call") #f)
|
||||
(insert (new editor-snip% (editor (new text%))) #f))
|
||||
(define z (new aligned-editor-snip% (editor pb)))
|
||||
(define f (new frame% (label "more-tests-text") (width 200) (height 200)))
|
||||
(define e (new pasteboard%))
|
||||
(define c (new editor-canvas% (editor e) (parent f)))
|
||||
(send e insert z)
|
||||
(send f show #t)
|
||||
|
||||
;;;;;;;;;;
|
||||
;; exploration
|
||||
(require "../snip-lib.ss")
|
||||
(define (margin snip)
|
||||
(let ([left (box 0)]
|
||||
[top (box 0)]
|
||||
[right (box 0)]
|
||||
[bottom (box 0)])
|
||||
(send snip get-margin left top right bottom)
|
||||
(list (cons 'left (unbox left))
|
||||
(cons 'right (unbox right))
|
||||
(cons 'top (unbox top))
|
||||
(cons 'bottom (unbox bottom)))))
|
|
@ -0,0 +1,42 @@
|
|||
(require
|
||||
"../aligned-editor-container.ss"
|
||||
"../aligned-pasteboard.ss")
|
||||
|
||||
(define editor (new vertical-pasteboard%))
|
||||
(define pb (new horizontal-pasteboard%))
|
||||
(send* pb
|
||||
(insert (make-object string-snip% "Call") #f)
|
||||
(insert (new editor-snip% (editor (new text%))) #f))
|
||||
(send editor insert (new aligned-editor-snip% (editor pb)))
|
||||
(define f (new frame% (label "more-test-jacob") (width 200) (height 200)))
|
||||
(define e (new vertical-pasteboard%))
|
||||
(define c (new aligned-editor-canvas% (editor e) (parent f)))
|
||||
(define t (new aligned-editor-snip%
|
||||
(editor editor)
|
||||
(stretchable-height #f)
|
||||
(stretchable-width #f)))
|
||||
(send e insert t)
|
||||
(send f show #t)
|
||||
|
||||
;;;;;;;;;;
|
||||
;; exploration
|
||||
(require "../snip-lib.ss")
|
||||
(define t-e (send t get-editor))
|
||||
(send t-e get-aligned-min-width)
|
||||
(send t get-aligned-min-width)
|
||||
(define fs (send t-e find-first-snip))
|
||||
(define fs (send t-e find-first-snip))
|
||||
(define fs-e (send fs get-editor))
|
||||
(send fs-e find-first-snip)
|
||||
(send fs-e get-aligned-min-width)
|
||||
(send fs get-aligned-min-width)
|
||||
(define (margin snip)
|
||||
(let ([left (box 0)]
|
||||
[top (box 0)]
|
||||
[right (box 0)]
|
||||
[bottom (box 0)])
|
||||
(send snip get-margin left top right bottom)
|
||||
(list (cons 'left (unbox left))
|
||||
(cons 'right (unbox right))
|
||||
(cons 'top (unbox top))
|
||||
(cons 'bottom (unbox bottom)))))
|
|
@ -0,0 +1,42 @@
|
|||
;; Note this test case fails when the snip 'y' is stretchable. There is lots of extra space. Finding out
|
||||
;; why will probably fix the test case's extra space.
|
||||
(require
|
||||
"../aligned-editor-container.ss"
|
||||
"../aligned-pasteboard.ss")
|
||||
|
||||
(define editor (new vertical-pasteboard%))
|
||||
(define pb (new horizontal-pasteboard%))
|
||||
(define z (new editor-snip% (editor (new text%))))
|
||||
(send* pb
|
||||
(insert (make-object string-snip% "Call") #f)
|
||||
(insert z #f))
|
||||
(define y (new aligned-editor-snip%
|
||||
(editor pb)
|
||||
(stretchable-width #t)
|
||||
(stretchable-height #t)))
|
||||
(send editor insert y)
|
||||
(define f (new frame% (label "more-tests-text") (width 200) (height 200)))
|
||||
(define e (new pasteboard%))
|
||||
(define c (new editor-canvas% (editor e) (parent f)))
|
||||
(define t (new aligned-editor-snip%
|
||||
(editor editor)
|
||||
(stretchable-height #f)
|
||||
(stretchable-width #f)))
|
||||
(send e insert t)
|
||||
(send f show #t)
|
||||
|
||||
;;;;;;;;;;
|
||||
;; exploration
|
||||
(eq-hash-code y)
|
||||
(eq-hash-code t)
|
||||
(require "../snip-lib.ss")
|
||||
(define (margin snip)
|
||||
(let ([left (box 0)]
|
||||
[top (box 0)]
|
||||
[right (box 0)]
|
||||
[bottom (box 0)])
|
||||
(send snip get-margin left top right bottom)
|
||||
(list (cons 'left (unbox left))
|
||||
(cons 'right (unbox right))
|
||||
(cons 'top (unbox top))
|
||||
(cons 'bottom (unbox bottom)))))
|
Loading…
Reference in New Issue
Block a user