suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

The mrflow collection needs to be ported to v4, will be in the

Browse Source 
graveyard until its updated.

svn: r8795
This commit is contained in:
Eli Barzilay 2008-02-25 07:44:42 +00:00
parent e5473ecae2
commit da6014926d
24 changed files with 0 additions and 13147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/mrflow/assoc-set-exn.ss
View File

@ -1,33 +0,0 @@
; Exceptions for associative sets
; This file is required by both assoc-set-hash.ss and assoc-set-list.ss
; so we can't use contracts here because the assoc-sets are not always the same.
(module assoc-set-exn mzscheme
(provide
(struct exn:assoc-set:key-not-found (assoc-set key))
(struct exn:assoc-set:duplicate-key (assoc-set key))
exn:assoc-set
exn:assoc-set?
raise-key-not-found-exn
raise-duplicate-key-exn
)
(define-struct (exn:assoc-set exn) ())
(define-struct (exn:assoc-set:key-not-found exn:assoc-set) (assoc-set key))
(define-struct (exn:assoc-set:duplicate-key exn:assoc-set) (assoc-set key))
; string assoc-set value -> void
(define (raise-key-not-found-exn fct-name assoc-set key)
(raise (make-exn:assoc-set:key-not-found
(format "~a: key ~a not found in associative set ~a" fct-name key assoc-set)
(current-continuation-marks)
assoc-set key)))
; string assoc-set value -> void
(define (raise-duplicate-key-exn fct-name assoc-set key)
(raise (make-exn:assoc-set:duplicate-key
(format "~a: key ~a already in associative set ~a" fct-name key assoc-set)
(current-continuation-marks)
assoc-set key)))
)

274
collects/mrflow/assoc-set-hash.ss
View File

@ -1,274 +0,0 @@
; associative sets implementation, using hash tables.
; - key equality based on eq? by default, uses equal? if given the 'equal flag
; - raises exn:assoc-set:key-not-found if key not in associative set when trying
; to remove a key or when trying to get a value and no default thunk is given.
; - raise exn:assoc-set:duplicate-key by default when trying to add a key to a
; set where it already exists
; - strange things might happen if you use assoc-set-union, assoc-set-intersection,
; or assoc-set-difference with two sets that don't use the same comparaison
; function: you might end up with duplicate keys in some sets.
(module assoc-set-hash (lib "mrflow.ss" "mrflow")
(require
mzlib/etc ; for opt-lambda
"assoc-set-exn.ss" ; no prefix so we can re-provide
(prefix cst: "constants.ss")
)
; table = (hashtableof value value)
(define-struct assoc-set (cardinality table))
(provide/contract
(exn:assoc-set? (any/c . -> . boolean?))
(struct (exn:assoc-set:key-not-found exn:assoc-set) ((message (and/c string? immutable?))
(continuation-marks continuation-mark-set?)
(assoc-set assoc-set?)
(key any/c)))
(struct (exn:assoc-set:duplicate-key exn:assoc-set) ((message (and/c string? immutable?))
(continuation-marks continuation-mark-set?)
(assoc-set assoc-set?)
(key any/c)))
(assoc-set-make (() ((symbols 'equal)) . opt-> . assoc-set?))
(assoc-set-reset (assoc-set? . -> . assoc-set?))
(assoc-set? (any/c . -> . boolean?))
(assoc-set-set ((assoc-set? any/c any/c) (boolean?) . opt-> . assoc-set?))
(assoc-set-get ((assoc-set? any/c) ((-> any)) . opt-> . any))
(assoc-set-in? (assoc-set? any/c . -> . boolean?))
(assoc-set-remove ((assoc-set? any/c) (boolean?) . opt-> . assoc-set?))
(assoc-set-cardinality (assoc-set? . -> . non-negative-exact-integer?))
(assoc-set-empty? (assoc-set? . -> . boolean?))
(assoc-set-copy (assoc-set? . -> . assoc-set?))
(assoc-set-map (assoc-set? (any/c any/c . -> . any) . -> . (listof any/c)))
(assoc-set-fold (assoc-set? (any/c any/c any/c . -> . any) any/c . -> . any))
(assoc-set-for-each (assoc-set? (any/c any/c . -> . any) . -> . assoc-set?))
(assoc-set-for-each! (assoc-set? (any/c any/c . -> . any) . -> . assoc-set?))
(assoc-set-filter ((assoc-set? (any/c any/c . -> . boolean?)) ((symbols 'new 'same)) . opt-> . assoc-set?))
(assoc-set-union ((assoc-set? assoc-set? (any/c any/c . -> . any)) ((symbols 'new 'first 'second)) . opt-> . assoc-set?))
(assoc-set-intersection ((assoc-set? assoc-set? (any/c any/c . -> . any)) ((symbols 'new 'first 'second)) . opt-> . assoc-set?))
(assoc-set-difference ((assoc-set? assoc-set?) ((symbols 'new 'first 'second)) . opt-> . assoc-set?))
(assoc-set-subset? (assoc-set? assoc-set? . -> . boolean?))
)
; (opt 'equal) -> assoc-set
; we test the optional argument ourselves to preserve data abstraction even in the
; presence of an exception
(define assoc-set-make
(case-lambda
[() (make-assoc-set 0 (make-hash-table))]
[(flag) (make-assoc-set 0 (make-hash-table 'equal))]))
; assoc-set -> assoc-set
(define (assoc-set-reset assoc-set)
(set-assoc-set-table! assoc-set (make-hash-table))
(set-assoc-set-cardinality! assoc-set 0)
assoc-set)
; value -> boolean
; assoc-set? comes from the structure definition
; assoc-set value value (opt boolean) -> assoc-set
(define assoc-set-set
(opt-lambda (assoc-set key value (exn? #t))
(if (assoc-set-in? assoc-set key)
(if exn?
(raise-duplicate-key-exn "assoc-set-set" assoc-set key)
; silently replace
(hash-table-put! (assoc-set-table assoc-set) key value))
(begin
(set-assoc-set-cardinality! assoc-set (add1 (assoc-set-cardinality assoc-set)))
(hash-table-put! (assoc-set-table assoc-set) key value)))
assoc-set))
; assoc-set value (-> value) -> value
(define assoc-set-get
(opt-lambda (assoc-set key (not-found-thunk (lambda () (raise-key-not-found-exn "assoc-set-get" assoc-set key))))
(hash-table-get (assoc-set-table assoc-set) key not-found-thunk)))
; assoc-set value -> boolean
(define assoc-set-in?
(let ([sym (gensym)])
(lambda (assoc-set key)
(not (eq? sym (hash-table-get (assoc-set-table assoc-set) key (lambda () sym)))))))
; assoc-set value (opt boolean) -> assoc-set
(define assoc-set-remove
(opt-lambda (assoc-set key (exn? #t))
(if (assoc-set-in? assoc-set key)
(begin
(set-assoc-set-cardinality! assoc-set (sub1 (assoc-set-cardinality assoc-set)))
(hash-table-remove! (assoc-set-table assoc-set) key))
(when exn?
(raise-key-not-found-exn "assoc-set-remove" assoc-set key)))
assoc-set))
; assoc-set -> exact-non-negative-integer
; assoc-set-cardinality comes from the structure definition
; assoc-set -> boolean
(define (assoc-set-empty? assoc-set)
(= 0 (assoc-set-cardinality assoc-set)))
; assoc-set -> assoc-set
(define (assoc-set-copy assoc-set)
(let ([new-table (make-hash-table)])
(hash-table-for-each (assoc-set-table assoc-set)
(lambda (key value)
(hash-table-put! new-table key value)))
(make-assoc-set (assoc-set-cardinality assoc-set)
new-table)))
; assoc-set (value value -> value) -> (listof value)
(define (assoc-set-map assoc-set f)
(hash-table-map (assoc-set-table assoc-set) f))
; assoc-set (value value value -> value) value -> value
(define (assoc-set-fold assoc-set f acc)
(let ([acc acc])
(hash-table-for-each (assoc-set-table assoc-set)
(lambda (key value)
(set! acc (f key value acc))))
acc))
; assoc-set (value value -> value) -> assoc-set
(define (assoc-set-for-each assoc-set f)
(hash-table-for-each (assoc-set-table assoc-set) f)
assoc-set)
; assoc-set (value value -> value) -> assoc-set
; we need a new table because of the "Caveat concerning concurrent access" for hash tables
; in the help desk.
(define (assoc-set-for-each! assoc-set f)
(let ([new-table (make-hash-table)])
(hash-table-for-each (assoc-set-table assoc-set)
(lambda (key value)
(hash-table-put! new-table key (f key value))))
(set-assoc-set-table! assoc-set new-table))
assoc-set)
; assoc-set (value value -> boolean) (opt (union 'new 'same)) -> assoc-set
(define assoc-set-filter
(let (; assoc-set (value value -> boolean) -> assoc-set
[filter-set-into-new-assoc-set
(lambda (assoc-set tester)
(let ([table (make-hash-table)]
[count 0])
(hash-table-for-each (assoc-set-table assoc-set)
(lambda (key value)
(when (tester key value)
(hash-table-put! table key value)
(set! count (add1 count)))))
(make-assoc-set count table)))])
(opt-lambda (assoc-set tester (which-set 'new))
(let ([new-assoc-set (filter-set-into-new-assoc-set assoc-set tester)])
(case which-set
[(new) new-assoc-set]
[(same)
(set-assoc-set-table! assoc-set (assoc-set-table new-assoc-set))
(set-assoc-set-cardinality! assoc-set (assoc-set-cardinality new-assoc-set))
assoc-set]
;[else (argexn:raise-arg-mismatch-exn "assoc-set-filter" '(union new same) which-set)]
)))))
; assoc-set assoc-set (value value -> value) (opt (union 'new 'first 'second)) -> assoc-set
(define assoc-set-union
(let (; assoc-set assoc-set (value value -> value) -> assoc-set
[union-second-set-into-first
(lambda (assoc-set1 assoc-set2 merge-values)
(let ([table (assoc-set-table assoc-set1)]
[count (assoc-set-cardinality assoc-set1)])
(hash-table-for-each (assoc-set-table assoc-set2)
(lambda (key value)
(if (assoc-set-in? assoc-set1 key)
(hash-table-put! table key
(merge-values (hash-table-get table key cst:dummy)
value))
(begin
(set! count (add1 count))
(hash-table-put! table key value)))))
(set-assoc-set-cardinality! assoc-set1 count))
assoc-set1)])
(opt-lambda (assoc-set1 assoc-set2 merge-values (which-set 'new))
(case which-set
[(new)
; copying is presumably faster than testing
(if (< (assoc-set-cardinality assoc-set1) (assoc-set-cardinality assoc-set2))
(union-second-set-into-first (assoc-set-copy assoc-set2) assoc-set1)
(union-second-set-into-first (assoc-set-copy assoc-set1) assoc-set2))]
[(first) (union-second-set-into-first assoc-set1 assoc-set2)]
[(second) (union-second-set-into-first assoc-set2 assoc-set1)]
;[else (argexn:raise-arg-mismatch-exn "assoc-set-union" '(union new first second) which-set)]
))))
; assoc-set assoc-set (value value -> value) (opt (union 'new 'first 'second)) -> assoc-set
(define assoc-set-intersection
(let (; assoc-set assoc-set (value value -> value) -> assoc-set
[intersect-into-new-assoc-set
(lambda (assoc-set1 assoc-set2 merge-values)
(let ([assoc-set2-table (assoc-set-table assoc-set2)]
[table (make-hash-table)]
[count 0])
(hash-table-for-each (assoc-set-table assoc-set1)
(lambda (key value)
(when (assoc-set-in? assoc-set2 key)
(hash-table-put! table key
(merge-values value
(hash-table-get assoc-set2-table key cst:dummy)))
(set! count (add1 count)))))
(make-assoc-set count table)))])
(opt-lambda (assoc-set1 assoc-set2 merge-values (which-set 'new))
(let ([new-assoc-set
(if (< (assoc-set-cardinality assoc-set1) (assoc-set-cardinality assoc-set2))
(intersect-into-new-assoc-set assoc-set1 assoc-set2 merge-values)
(intersect-into-new-assoc-set assoc-set2 assoc-set1 merge-values))])
(case which-set
[(new) new-assoc-set]
[(first)
(set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set))
(set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set))
assoc-set1]
[(second)
(set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set))
(set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set))
assoc-set2]
;[else (argexn:raise-arg-mismatch-exn "assoc-set-intersection" '(union new first second) which-set)]
)))))
; assoc-set assoc-set (opt (union 'new 'first 'second)) -> assoc-set
(define assoc-set-difference
(let (; assoc-set assoc-set -> assoc-set
[difference-into-new-assoc-set
(lambda (assoc-set1 assoc-set2)
(let ([table (make-hash-table)]
[count 0])
(hash-table-for-each (assoc-set-table assoc-set1)
(lambda (key value)
(unless (assoc-set-in? assoc-set2 key)
(hash-table-put! table key value)
(set! count (add1 count)))))
(make-assoc-set count table)))])
(opt-lambda (assoc-set1 assoc-set2 (which-set 'new))
(let ([new-assoc-set (difference-into-new-assoc-set assoc-set1 assoc-set2)])
(case which-set
[(new) new-assoc-set]
[(first)
(set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set))
(set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set))
assoc-set1]
[(second)
(set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set))
(set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set))
assoc-set2]
;[else (argexn:raise-arg-mismatch-exn "assoc-set-difference" '(union new first second) which-set)]
)))))
; assoc-set assoc-set -> boolean
; compares keys only
(define (assoc-set-subset? assoc-set1 assoc-set2)
(let/ec k
(hash-table-for-each (assoc-set-table assoc-set1)
(lambda (key value)
(unless (assoc-set-in? assoc-set2 key)
(k #f))))
#t))
)

368
collects/mrflow/assoc-set-list.ss
View File

@ -1,368 +0,0 @@
; associative sets implementation, using lists.
; - key equality based on eq? by default, uses equal? if given the 'equal flag
; - raises exn:assoc-set:key-not-found if key not in associative set when trying
; to remove a key or when trying to get a value and no default thunk is given.
; - raise exn:assoc-set:duplicate-key by default when trying to add a key to a
; set where it already exists
; - strange things might happen if you use assoc-set-union, assoc-set-intersection,
; or assoc-set-difference with two sets that don't use the same comparaison
; function: you might end up with duplicate keys in some sets.
;
; Note: lots of set! and tail-recursive loops in this code, for speed
(module assoc-set-list (lib "mrflow.ss" "mrflow")
(require
mzlib/list ; for foldr
mzlib/etc ; for opt-lambda
"assoc-set-exn.ss" ; no prefix so we can re-provide
)
; table = (listof (cons value value))
(define-struct assoc-set (=? cardinality table))
(provide/contract
(exn:assoc-set? (any/c . -> . boolean?))
(struct (exn:assoc-set:key-not-found exn:assoc-set) ((message (and/c string? immutable?))
(continuation-marks continuation-mark-set?)
(assoc-set assoc-set?)
(key any/c)))
(struct (exn:assoc-set:duplicate-key exn:assoc-set) ((message (and/c string? immutable?))
(continuation-marks continuation-mark-set?)
(assoc-set assoc-set?)
(key any/c)))
(assoc-set-make (() ((symbols 'equal)) . opt-> . assoc-set?))
(assoc-set-reset (assoc-set? . -> . assoc-set?))
(assoc-set? (any/c . -> . boolean?))
(assoc-set-set ((assoc-set? any/c any/c) (boolean?) . opt-> . assoc-set?))
(assoc-set-get ((assoc-set? any/c) ((-> any)) . opt-> . any))
(assoc-set-in? (assoc-set? any/c . -> . boolean?))
(assoc-set-remove ((assoc-set? any/c) (boolean?) . opt-> . assoc-set?))
(assoc-set-cardinality (assoc-set? . -> . non-negative-exact-integer?))
(assoc-set-empty? (assoc-set? . -> . boolean?))
(assoc-set-copy (assoc-set? . -> . assoc-set?))
(assoc-set-map (assoc-set? (any/c any/c . -> . any) . -> . (listof any/c)))
(assoc-set-fold (assoc-set? (any/c any/c any/c . -> . any) any/c . -> . any))
(assoc-set-for-each (assoc-set? (any/c any/c . -> . any) . -> . assoc-set?))
(assoc-set-for-each! (assoc-set? (any/c any/c . -> . any) . -> . assoc-set?))
(assoc-set-filter ((assoc-set? (any/c any/c . -> . boolean?)) ((symbols 'new 'same)) . opt-> . assoc-set?))
(assoc-set-union ((assoc-set? assoc-set? (any/c any/c . -> . any)) ((symbols 'new 'first 'second)) . opt-> . assoc-set?))
(assoc-set-intersection ((assoc-set? assoc-set? (any/c any/c . -> . any)) ((symbols 'new 'first 'second)) . opt-> . assoc-set?))
(assoc-set-difference ((assoc-set? assoc-set?) ((symbols 'new 'first 'second)) . opt-> . assoc-set?))
(assoc-set-subset? (assoc-set? assoc-set? . -> . boolean?))
)
; (opt 'equal) -> assoc-set
; we test the optional argument ourselves to preserve data abstraction even in the
; presence of an exception
(define assoc-set-make
(case-lambda
[() (make-assoc-set eq? 0 '())]
[(flag) (make-assoc-set equal? 0 '())]))
; assoc-set -> assoc-set
; doesn't change =?
(define (assoc-set-reset assoc-set)
(set-assoc-set-table! assoc-set '())
(set-assoc-set-cardinality! assoc-set 0)
assoc-set)
; value -> boolean
; assoc-set? comes from the structure definition
; assoc-set value value (opt boolean) -> assoc-set
(define assoc-set-set
(opt-lambda (assoc-set key value (exn? #t))
(let ([=? (assoc-set-=? assoc-set)]
[original-table (assoc-set-table assoc-set)])
(set-assoc-set-table! assoc-set (let loop ([table original-table])
(if (null? table)
(begin
(set-assoc-set-cardinality! assoc-set (add1 (assoc-set-cardinality assoc-set)))
(cons (cons key value) original-table))
(let ([key-value-pair (car table)])
(if (=? (car key-value-pair) key)
(if exn?
(raise-duplicate-key-exn "assoc-set-set" assoc-set key)
(begin
; silently replace
(set-cdr! key-value-pair value)
original-table))
(loop (cdr table)))))))
assoc-set)))
; assoc-set value (-> value) -> value
(define assoc-set-get
(opt-lambda (assoc-set key (not-found-thunk (lambda () (raise-key-not-found-exn "assoc-set-get" assoc-set key))))
(let ([=? (assoc-set-=? assoc-set)])
(let loop ([table (assoc-set-table assoc-set)])
(if (null? table)
(not-found-thunk)
(let ([key-value-pair (car table)])
(if (=? (car key-value-pair) key)
(cdr key-value-pair)
(loop (cdr table)))))))))
; assoc-set value -> boolean
(define (assoc-set-in? assoc-set key)
(let ([=? (assoc-set-=? assoc-set)])
(ormap (lambda (key-value-pair)
(=? (car key-value-pair) key))
(assoc-set-table assoc-set))))
; assoc-set value (opt boolean) -> assoc-set
(define assoc-set-remove
(opt-lambda (assoc-set key (exn? #t))
(let ([=? (assoc-set-=? assoc-set)]
[original-table (assoc-set-table assoc-set)])
(set-assoc-set-table! assoc-set
(let loop ([table original-table]
[previous #f])
(if (null? table)
(if exn?
(raise-key-not-found-exn "assoc-set-remove" assoc-set key)
; silently ignore
original-table)
(let ([key-value-pair (car table)])
(if (=? (car key-value-pair) key)
(begin
(set-assoc-set-cardinality! assoc-set (sub1 (assoc-set-cardinality assoc-set)))
(if previous
(begin
; return shortened table
(set-cdr! previous (cdr table))
original-table)
(cdr original-table)))
(loop (cdr table) table)))))))
assoc-set))
; assoc-set -> exact-non-negative-integer
; assoc-set-cardinality comes from the structure definition
; assoc-set -> boolean
(define (assoc-set-empty? assoc-set)
(= 0 (assoc-set-cardinality assoc-set)))
; (listof (cons value value)) (listof (cons value value)) -> (listof (cons value value))
; creates a (reversed) copy of l1 (to prevent list sharing between sets) and prefixes l2 with it
(define (copy-reverse-and-prefix-assoc-lists l1 l2)
(let loop ([l1 l1]
[l2 l2])
(if (null? l1)
l2
(loop (cdr l1) (cons (cons (caar l1) (cdar l1)) l2)))))
; (listof (cons value value)) -> (listof (cons value value))
(define (copy-assoc-list l)
(copy-reverse-and-prefix-assoc-lists l '()))
; assoc-set -> assoc-set
(define (assoc-set-copy assoc-set)
(make-assoc-set (assoc-set-=? assoc-set)
(assoc-set-cardinality assoc-set)
(copy-assoc-list (assoc-set-table assoc-set))))
; assoc-set (value value -> value) -> (listof value)
(define (assoc-set-map assoc-set f)
(let ([unary-f (lambda (key-value-pair)
(f (car key-value-pair) (cdr key-value-pair)))])
(map unary-f (assoc-set-table assoc-set))))
; assoc-set (value value value -> value) value -> value
(define (assoc-set-fold assoc-set f acc)
(foldr (lambda (key-value-pair acc)
(f (car key-value-pair) (cdr key-value-pair) acc))
acc
(assoc-set-table assoc-set)))
; assoc-set (value value -> value) -> assoc-set
(define (assoc-set-for-each assoc-set f)
(let ([unary-f (lambda (key-value-pair)
(f (car key-value-pair) (cdr key-value-pair)))])
(for-each unary-f (assoc-set-table assoc-set)))
assoc-set)
; assoc-set (value value -> value) -> assoc-set
; we know lists are never shared between sets, so we can set-cdr!
(define (assoc-set-for-each! assoc-set f)
(for-each (lambda (key-value-pair)
(set-cdr! key-value-pair (f (car key-value-pair) (cdr key-value-pair))))
(assoc-set-table assoc-set))
assoc-set)
; assoc-set (value value -> boolean) (opt (union 'new 'same)) -> assoc-set
(define assoc-set-filter
(let (; assoc-set (value value -> boolean) -> assoc-set
[filter-into-new-assoc-set
(lambda (assoc-set tester)
(let ([table '()]
[count 0])
(for-each (lambda (key value)
(when (tester key value)
(set! table (cons (cons key value) table))
(set! count (add1 count))))
(assoc-set-table assoc-set))
(make-assoc-set (assoc-set-=? assoc-set) count table)))])
(opt-lambda (assoc-set tester (which-assoc-set 'new))
(let ([new-assoc-set (filter-into-new-assoc-set assoc-set tester)])
(case which-assoc-set
[(new) new-assoc-set]
[(same)
(set-assoc-set-table! assoc-set (assoc-set-table new-assoc-set))
(set-assoc-set-cardinality! assoc-set (assoc-set-cardinality new-assoc-set))
assoc-set])))))
; assoc-set assoc-set (value value -> value) (opt (union 'new 'first 'second)) -> assoc-set
(define assoc-set-union
(opt-lambda (assoc-set1 assoc-set2 merge-values (which-assoc-set 'new))
(let* ([=? (assoc-set-=? assoc-set1)]
[new-assoc-set
(let loop ([table1 (assoc-set-table assoc-set1)]
; we shouldn't modify the original list
[table2 (copy-assoc-list (assoc-set-table assoc-set2))]
[count1 (assoc-set-cardinality assoc-set1)]
[count2 (assoc-set-cardinality assoc-set2)]
[acc '()]
[count 0])
(if (null? table1)
; we have already copied table2, so we can destructively modify it
(make-assoc-set =? (+ count count2)
(append! table2 acc))
(if (null? table2)
(make-assoc-set =? (+ count count1)
(copy-reverse-and-prefix-assoc-lists table1 acc))
(let ([key1 (caar table1)])
; search table2 for same key
(let loop-assoc-set2 ([t2 table2]
[previous #f])
(if (null? t2)
(begin
(set! acc (cons (cons key1 (cdar table1)) acc))
(set! count (add1 count))
(set! table1 (cdr table1))
(set! count1 (sub1 count1)))
(if (=? key1 (caar t2))
(begin
(set! acc (cons (cons key1 (merge-values (cdar table1) (cdar t2))) acc))
(set! count (add1 count))
(set! table1 (cdr table1))
(set! count1 (sub1 count1))
(if previous
(set-cdr! previous (cdr t2))
(set! table2 (cdr table2)))
(set! count2 (sub1 count2)))
(loop-assoc-set2 (cdr t2) t2))))
(loop table1 table2 count1 count2 acc count)))))])
(case which-assoc-set
[(new) new-assoc-set]
[(first)
(set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set))
(set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set))
assoc-set1]
[(second)
(set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set))
(set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set))
assoc-set2]))))
; assoc-set assoc-set (value value -> value) (opt (union 'new 'first 'second)) -> assoc-set
(define assoc-set-intersection
(opt-lambda (assoc-set1 assoc-set2 merge-values (which-assoc-set 'new))
(let* ([=? (assoc-set-=? assoc-set1)]
[new-assoc-set
(let loop ([table1 (assoc-set-table assoc-set1)]
; we shouldn't modify the original list
[table2 (copy-assoc-list (assoc-set-table assoc-set2))]
[count1 (assoc-set-cardinality assoc-set1)]
[count2 (assoc-set-cardinality assoc-set2)]
[acc '()]
[count 0])
(if (null? table1)
(make-assoc-set =? count acc)
(if (null? table2)
(make-assoc-set =? count acc)
(let ([key1 (caar table1)])
; search table2 for same key
(let loop-assoc-set2 ([t2 table2]
[previous #f])
(if (null? t2)
(begin
(set! table1 (cdr table1))
(set! count1 (sub1 count1)))
(if (=? key1 (caar t2))
(begin
(set! acc (cons (cons key1 (merge-values (cdar table1) (cdar t2))) acc))
(set! count (add1 count))
(set! table1 (cdr table1))
(set! count1 (sub1 count1))
(if previous
(set-cdr! previous (cdr t2))
(set! table2 (cdr table2)))
(set! count2 (sub1 count2)))
(loop-assoc-set2 (cdr t2) t2))))
(loop table1 table2 count1 count2 acc count)))))])
(case which-assoc-set
[(new) new-assoc-set]
[(first)
(set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set))
(set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set))
assoc-set1]
[(second)
(set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set))
(set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set))
assoc-set2]))))
; assoc-set assoc-set (opt (union 'new 'first 'second)) -> assoc-set
(define assoc-set-difference
(opt-lambda (assoc-set1 assoc-set2 (which-assoc-set 'new))
(let* ([=? (assoc-set-=? assoc-set1)]
[new-assoc-set
(let loop ([table1 (assoc-set-table assoc-set1)]
; we shouldn't modify the original list
[table2 (copy-assoc-list (assoc-set-table assoc-set2))]
[count1 (assoc-set-cardinality assoc-set1)]
[count2 (assoc-set-cardinality assoc-set2)]
[acc '()]
[count 0])
(if (null? table1)
(make-assoc-set =? count acc)
(if (null? table2)
(make-assoc-set =? (+ count count1)
(copy-reverse-and-prefix-assoc-lists table1 acc))
(let ([key1 (caar table1)])
; search table2 for same key
(let loop-assoc-set2 ([t2 table2]
[previous #f])
(if (null? t2)
(begin
(set! acc (cons (cons key1 (cdar table1)) acc))
(set! count (add1 count))
(set! table1 (cdr table1))
(set! count1 (sub1 count1)))
(if (=? key1 (caar t2))
(begin
(set! table1 (cdr table1))
(set! count1 (sub1 count1))
(if previous
(set-cdr! previous (cdr t2))
(set! table2 (cdr table2)))
(set! count2 (sub1 count2)))
(loop-assoc-set2 (cdr t2) t2))))
(loop table1 table2 count1 count2 acc count)))))])
(case which-assoc-set
[(new) new-assoc-set]
[(first)
(set-assoc-set-cardinality! assoc-set1 (assoc-set-cardinality new-assoc-set))
(set-assoc-set-table! assoc-set1 (assoc-set-table new-assoc-set))
assoc-set1]
[(second)
(set-assoc-set-cardinality! assoc-set2 (assoc-set-cardinality new-assoc-set))
(set-assoc-set-table! assoc-set2 (assoc-set-table new-assoc-set))
assoc-set2]))))
; assoc-set assoc-set -> boolean
; compares keys only
(define (assoc-set-subset? assoc-set1 assoc-set2)
(andmap (lambda (key value)
(assoc-set-in? assoc-set2 key))
(assoc-set-table assoc-set1)))
)

36
collects/mrflow/constants.ss
View File

@ -1,36 +0,0 @@
(module constants mzscheme
(provide
dummy
dummy-thunk
undefined
thunk-empty
thunk-false
test-true
test-false
id
(rename void-cst void)
select-right
select-left
;car!
;cdr!
)
(define dummy (void))
(define dummy-thunk (lambda () dummy))
(define undefined (letrec ([x x]) x))
(define thunk-empty (lambda () '()))
(define thunk-false (lambda () #f))
(define test-true (lambda (x) #t))
(define test-false (lambda (x) #f))
(define id (lambda (x) x))
(define void-cst (void))
(define select-right (lambda (x y) y))
(define select-left (lambda (x y) x))
;(define car! (case-lambda
; [(pair) (car pair)]
; [(pair val) (set-car! pair val)]))
;(define cdr! (case-lambda
; [(pair) (cdr pair)]
; [(pair val) (set-cdr! pair val)]))
)

5018
collects/mrflow/constraints-gen-and-prop.ss
View File

File diff suppressed because it is too large Load Diff

1024
collects/mrflow/dfa.ss
View File

File diff suppressed because it is too large Load Diff

325
collects/mrflow/doc.txt
View File

@ -1,325 +0,0 @@
[index entries: _snip_ _arrow_ _label_ ]
_snips_ and _arrows_ library
============================
Collection: mrflow
Files: snips-and-arrows.ss snips-and-arrows-view.ss snips-and-arrows-model.ss
This library allows a programmer to display information about terms in
a DrScheme text editor and its embedded sub-editors. Textual
information about a given term can be displayed using snips inserted
in the editor next to the term. Each snip is colored according to a
programmer specified type. Several snips can exist for a given term
and type. A relation between two terms can be displayed by drawing an
arrow between the two terms. Each arrow is colored using a programmer
specified color. Arrows do not carry any textual information with
them.
The library is fundamentally based on terms. It is not possible to
display snips or arrows that are not directly related to terms.
However the library does not require terms to be represented by
MzScheme syntax objects. Terms can be represented by any user-defined
data structure, called hereafter _labels_. A label represents exactly
one term and the library user is responsible for keeping track of
which term is represented by a given label (by, say, keeping a
reference to the syntax object in the label's data structure), but a
term in an editor can be represented by one or more labels and the
user doesn't have to keep track of that. This asymmetry between terms
and labels is necessary because macro expansions might duplicate some
terms.
With each label can be associated a number of snips containing textual
information. Each snip has a user-defined type that determines the
color of the snip. A label can have several snips for a given type,
and snips of different types associated with it. Mouse menus are
available to show or hide all snips of a given type for all labels
corresponding to a given term. The snips are inserted on the left of
the corresponding term, in an order that is determined by the user
(see the snip-types-and-colors argument of the
init-snips-and-arrows-gui function below for details).
The library defines two mixins that augment the text editors with
various methods, and two functions that are used to initialize the
library. Both functions return one function to register labels with
the library and one function to change terms in the editors. A term
in an editor will be recognized and colored by the library only if at
least one of its corresponding labels has been registered with the
library.
All terms corresponding to registered labels must, either directly or
indirectly through embedded sub-editors, be contained in a single
editor called hereafter the top editor. In the case of the DrScheme
definitions window and its embedded sub-editors (if any), the top
editor will be the definitions window itself.
Usage
=====
(require (lib "snips-and-arrows.ss" "mrflow"))
This will import two mixins:
extend-all-editors-mixin and
extend-top-editor-mixin
and two functions:
init-snips-and-arrows-gui and
init-snips-and-arrows-gui-for-syntax-objects
See the example at the end of this document for a quick how-to.
All text% classes that will be used to create editors that will
contain, either directly or indirectly through embedded editors, terms
to be colored by the library, must be extended using the
_extend-all-editors-mixin_ mixin. In the case of the DrScheme
definitions window and its embedded sub-editors (if any) this is
simply done by giving this mixin as argument to the
drscheme:unit:add-to-program-editor-mixin function during phase1 of
DrScheme.
The text% class that will be used to create the top editor that will
contain, either directly or indirectly through embedded sub-editors,
all the terms to be colored must be extended using the
_extend-top-editor-mixin_ mixin. This must be done even if all the
terms to be colored are contained in embedded sub-editors and the top
editor doesn't itself directly contain any terms to be colored. The
mixin extends that text% class with two methods of no arguments:
- _color-registered-labels_, to be called once all labels have been
registered (see below) in order to color the corresponding terms, to
start the automatic display of arrows as well as to make the snips
and arrows related mouse menus available to the user.
- _remove-all-snips-and-arrows-and-colors_, to be called to terminate
the automatic display of arrows, make the snips and arrows related
mouse menus unavailable to the user, remove all inserted snips, and
optionally clear all colors (see below the last argument to
init-snips-and-arrows-gui and the last optional argument to
init-snips-and-arrows-gui-for-syntax-objects for details about this
last point).
In the case of the DrScheme definitions window, using this mixin is
simply done by giving it as argument to the
drscheme:get/extend:extend-definitions-text function.
The init-snips-and-arrows-gui and
init-snips-and-arrows-gui-for-syntax-objects functions are used to
initialize the library. Exactly one of them must be called before
trying to use the library. The
init-snips-and-arrows-gui-for-syntax-objects function is a simplified
version of init-snips-and-arrows-gui.
The _init-snips-and-arrows-gui_ function has eleven arguments in the
following order (with a mnemonic name and a type between parenthesis):
1) the top editor (top-editor: text%), the editor that, either
directly or indirectly through embedded sub-editors, contains all
terms that are to be colored by the library.
2) a function from label to editor (get-editor-from-label: label ->
text%) returning the editor that directly contains the term
corresponding to the label. This function must return the same
editor for all the labels corresponding to a given term.
3) a function from label to term position
(get-mzscheme-position-from-label: label ->
non-negative-exact-integer) returning the MzScheme position of the
term corresponding to the label in the editor that directly
contains it (the editor that would be returned by the
get-editor-from-label function described just above). This
function must return the same position for all the labels
corresponding to a given term.
4) a function from label to term color span (get-span-from-label:
label -> non-negative-exact-integer) indicating the number of
characters of the term corresponding to the label that should be
colored. Coloring of a term starts with the leftmost character of
the term and continues towards the right for that number of
characters. This applies to all terms for which at least one
label has been registered with the library, regardless of whether
they are atomic or not, so care must be exercised when computing
the span for a term containing sub-terms that also have to be
colored. Arrows starting or ending at a given term will be
anchored at half the span of the term, so again care must be taken
when specifying the span of non-atomic terms. This function must
return the same span for all labels corresponding to a given term.
5) a function from label to a list of arrows data
(get-arrows-from-label: label -> (listof (list label label
string))) indicating what arrows should be drawn when the mouse
pointer is placed over the term corresponding to the label. Each
sublist in the list represents one arrow, and must contain, in
that order, a label corresponding to the starting term for the
arrow, a label corresponding to the ending term for the arrow, and
a string representing the arrow color (see color-database<%> in
the help-desk for a list of color names).
6) a function from label to style delta (get-style-delta-from-label:
label -> style-delta%) indicating how the term corresponding to
the label should be colored. This function must return the same
style delta for all the labels corresponding to a given term.
7) a function from popup menu and a list of labels to void
(extend-menu-for-labels: popup-menu% (listof label) -> void) that
can be used to add menu-item% objects to the menu that pops up
when the user clicks with the right mouse button on a term. All
the labels in the list correspond to that term (there might be
several labels in the list because of macro expansions). The
callbacks for the added menu items must not directly modify the
content of any editor that directly contains colored terms but
must instead use a function like the first one returned by the
call to init-snips-and-arrows-gui (see below for details).
8) a function from snip type (see snip-types-and-colors below) and
action symbol to string (get-menu-text-from-snip-type: symbol
symbol -> string) that takes as input a snip type represented as a
symbol as well as one of the two symbols 'show or 'hide
representing a user command and returns a string that will be used
as the text for the menu entry that will allow the user to perform
said command for the snips of that given type.
9) a function from snip type and label to a list of strings
(get-snip-text-from-snip-type-and-label: symbol label -> (listof
string)) that returns the content of all the snips of the given
type that will be inserted next to the term corresponding to the
label when the user uses the snip-related mouse menu entries
described just above.
10) a list of snip types and colors (snip-types-and-colors: (listof
(cons symbol string))) that describes all possible types of snips
and their associated color. Each sub-list in the list must
contain two elements: a snip type name represented as a symbol,
and a corresponding snip color (see color-database<%> in the
help-desk for a list of color names). For a given term, snips of
different types will be inserted from left to right on the left of
the corresponding term in the order in which their types appear in
this list.
11) a boolean (clear-colors-immediately?: (union #t #f)) that
indicates whether, once the user starts modifying the content of
the editors, the terms colored by the library should be uncolored
immediately or should be uncolored only the next time a DrScheme
tool is run or the program executed.
The init-snips-and-arrows-gui then returns two values: a function to
change terms and a function to register a label. The function to
change terms has type ((listof (cons label string)) -> void). Each
pair in the function's argument consists of a label representing a
term to be changed and a string that will be used to replace that
term. It is only necessary to give one label per term to be changed.
It is an error to give two pairs with labels representing the same
term but with different strings. The function to register a label has
type (label -> void) and is used to indicate to the library that the
corresponding term has to be colored. The same label can safely be
registered several times. Unspeakable things involving nasty crawling
bugs will happen to you, and your descendants will be cursed to the
seventh generation if you dare to call this function after having
already called the color-registered-labels method described above.
The init-snips-and-arrows-gui-for-syntax-objects function is a
simplified (yes, really) version of init-snips-and-arrows-gui that
assumes labels are in fact MzScheme syntax objects, and also provides
default values for all the menu and snip related functions that simply
assume that no snips are used at all. Also, the terms represented by
the syntax objects are assumed to be atomic, meaning they will be
colored in whole and arrows will be anchored at half the terms' spans.
Seemingly unanchored arrows and overlapping colors may result if you
try to use this function with non-atomic terms (i.e. terms containing
sub-terms). The function has only three required arguments, and five
optional arguments. The three required arguments are, in that order,
using the mnemonic names from the description of
init-snips-and-arrows-gui above, and with updated types in
parenthesis:
- top-editor (text%)
- get-arrows-from-label (syntax-object -> (listof (list syntax-object
syntax-object string)))
- get-style-delta-from-label (syntax-object -> style-delta%)
The five optional arguments are as follows, in that order, with their
default value in brackets:
- extend-menu-for-labels (popup-menu% (listof syntax-object) -> void)
[(lambda (m l) (void)))]
- get-menu-text-from-snip-type (symbol symbol -> string) [internal
error function]
- get-snip-text-from-snip-type-and-label (symbol syntax-object ->
(listof string)) [internal error function]
- snip-types-and-colors (listof (cons symbol string)) ['()]
- clear-colors-immediately? (union #t #f) [#f]
The init-snips-and-arrows-gui-for-syntax-objects returns the same two
functions as the init-snips-and-arrows-gui function.
Example
=======
This example assumes that this library is used by a DrScheme tool.
The skeleton for the tool would then look like this:
(module my-tool
...
(require (lib "snips-and-arrows.ss" "mrflow"))
...
(define tool@
(unit/sig drscheme:tool-exports^
(import drscheme:tool^)
...
(define (phase1)
...
(drscheme:unit:add-to-program-editor-mixin extend-all-editors-mixin)
...)
...
(drscheme:get/extend:extend-definitions-text extend-top-editor-mixin)
...
(drscheme:get/extend:extend-unit-frame
(lambda (super%)
(class super%
(inherit get-definitions-text)
(rename [super-clear-annotations clear-annotations])
; -> void
(define/override (clear-annotations)
...
(super-clear-annotations)
(send (get-definitions-text) remove-all-snips-and-arrows-and-colors)
...)
...
(define my-tool-button
(instantiate button%
...
(callback
(lambda (button event)
...
(letrec-values ([(user-change-terms register-label-with-gui)
; use init-snips-and-arrows-gui-for-syntax-objects
; if you only deal with syntax objects
(init-snips-and-arrows-gui
(get-definitions-text)
...
; for extend-menu-for-labels, if necessary -
; basically a callback to library-user code
(lambda (popup-menu labels)
...
(make-object menu-item%
"change stuff"
popup-menu
; menu callback
(lambda (item event)
...
(let ([label-and-new-term-pairs
(my-tool-get-stuff-to-change labels)])
...
; callback to the library from within callback to
; library-user code
(user-change-terms label-and-new-term-pairs)
...)
...)
...)
...)
...)])
...
; call to super's method to clean other tools' annotations
(super-clear-annotations)
...
(drscheme:eval:expand-program
...
(lambda (syntax-object-or-eof iter)
(if (eof-object? syntax-object-or-eof)
(begin
...
(send definitions-text color-registered-labels)
...)
(begin
...
(my-tool-process-syntax-object ... register-label-with-gui ...)
...
(iter)))))))))))))))
...)

56
collects/mrflow/env.ss
View File

@ -1,56 +0,0 @@
(module env (lib "mrflow.ss" "mrflow")
(require "util.ss")
(provide (all-defined))
(define create-env (lambda () '()))
(define create-tenv (lambda () '()))
(define (env-of? domain range)
(list-immutable/c (cons-immutable/c (list-immutable/c domain)
(vector-immutable/c range))))
(define tenv? (listof (cons/c (listof symbol?) (vectorof any/c))))
(define/contract extend-tenv
(tenv? (listof symbol?) (listof any/c) . ->d .
(lambda (env vars binders)
(unless (= (length vars) (length binders))
(error 'extend-tenv "Must have one handle for each var~n~a~n~a" vars binders))
tenv?))
(lambda (env vars binders)
(cons (cons vars (list->vector binders)) env)))
(define/contract extend-env
((env-of? symbol? any/c) (list-immutable/c symbol?) (list-immutable/c any/c) . ->d .
(lambda (env vars binders)
(unless (= (length vars) (length binders))
(error 'extend-tenv "Must have one handle for each var~n~a~n~a" vars binders))
tenv?))
(lambda (env vars binders)
(cons (cons vars (list->immutable-vector binders)) env)))
(define/contract generic-lookup-symbol
((any/c . -> . any) . -> . (tenv? any/c . -> . any))
(lambda (not-found-function)
(lambda (tenv var)
(let loop-env ([env tenv])
(if (null? env)
(not-found-function var)
(let* ([rib (car env)]
[syms (car rib)]
[types (cdr rib)])
(let loop-rib ([syms syms] [i 0])
(cond
[(null? syms) (loop-env (cdr env))]
[(equal? (car syms) var) (vector-ref types i)]
[else
(loop-rib (cdr syms) (+ i 1))]))))))))
(define/contract lookup-symbol (tenv? symbol? . -> . any)
(generic-lookup-symbol
(lambda (var)
(error 'get-state "Unknown type variable in environment: ~a " var))))
(define/contract maybe-lookup-symbol (tenv? symbol? . -> . any)
(generic-lookup-symbol (lambda (_) #f)))
)

323
collects/mrflow/gui.ss
View File

@ -1,323 +0,0 @@
(module gui mzscheme
(require
(lib "tool.ss" "drscheme")
mzlib/unit
mzlib/list
mzlib/class
mred
(prefix fw: framework)
(prefix strcst: string-constants)
(prefix bit: (lib "bitmap-label.ss" "mrlib"))
(prefix cst: "constants.ss")
(prefix sba: "constraints-gen-and-prop.ss")
(prefix err: "sba-errors.ss")
(prefix saa: "snips-and-arrows.ss")
)
(provide tool@)
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
; INTERFACE WITH LANGUAGES
(define mrflow-language-extension-interface<%>
(interface ()
render-value-set
get-mrflow-primitives-filename))
(define (mrflow-default-implementation-mixin super%)
(class* super% (mrflow-language-extension-interface<%>)
; type -> string
; Language implementors are responsible for providing a type pretty-printer.
; XXX NOT CURRENTLY USED
(define/public (render-value-set val) "render-value-set-mixin not implemented")
; -> string
; Language implementors are responsible for providing the name of the file
; that contains the types of the primitives for their language. If they don't,
; we give a warning, use R5RS, and hope for the best.
(define/public (get-mrflow-primitives-filename)
(message-box (strcst:string-constant mrflow-using-default-language-title)
(strcst:string-constant mrflow-using-default-language)
#f '(ok))
(build-path (collection-path "mrflow")
"primitives"
"r5rs.ss"))
(super-instantiate ())))
(define (phase1)
(drscheme:language:extend-language-interface mrflow-language-extension-interface<%>
mrflow-default-implementation-mixin)
(drscheme:unit:add-to-program-editor-mixin saa:extend-all-editors-mixin))
(define (phase2) cst:void)
(define mrflow-bitmap
(bit:bitmap-label-maker
(strcst:string-constant mrflow-button-title)
(build-path (collection-path "icons") "mrflow-small.bmp")))
; TERM AND SNIP STYLES
(define can-click-style-delta (make-object style-delta% 'change-weight 'bold))
(send can-click-style-delta set-delta-foreground "purple")
(define green-style-delta (make-object style-delta% 'change-weight 'bold))
(send green-style-delta set-delta-foreground "green")
(send green-style-delta set-underlined-on #t)
(define orange-style-delta (make-object style-delta% 'change-weight 'bold))
(send orange-style-delta set-delta-foreground "orange")
(send orange-style-delta set-underlined-on #t)
(define red-style-delta (make-object style-delta% 'change-weight 'bold))
(send red-style-delta set-delta-foreground "red")
(send red-style-delta set-underlined-on #t)
; symbol style-delta% -> style-delta%
; compares two style-deltas (one represented as a color/severity name, the other one as
; an actual style-delta) and returns the most "urgent" one.
; red > orange > green
(define (max-style-delta-by-name style-delta-name style-delta)
(case style-delta-name
[(red) red-style-delta]
[(orange) (if (eq? style-delta red-style-delta) style-delta orange-style-delta)]
[(green) style-delta]
[else (error 'max-style-delta-by-name
"MrFlow internal error; incomparable style-delta ~a"
style-delta-name)]))
; sba-state label -> style-delta%
; If the label has errors associated with it, we color the term with the color
; of the worst error, otherwise we color it with the normal clickable style-delta.
(define (get-style-delta-from-label sba-state label)
(let ([errors (sba:get-errors-from-label sba-state label)])
(if (null? errors)
can-click-style-delta
(foldl (lambda (sba-error current-max-style-delta)
(max-style-delta-by-name (err:sba-error-gravity sba-error) current-max-style-delta))
green-style-delta
errors))))
; sba-state label -> exact-non-negative-integer
; span conversation: for all graphical purposes, the span of a compound expression is 1,
; to highlight only the opening parenthesis. Otherwise we might highlight subexpressions
; with the wrong color.
(define (get-span-from-label sba-state label)
(if (or (sba:is-label-atom? label)
);(not (null? (sba:get-errors-from-label sba-state label))))
(sba:get-span-from-label label)
1))
; (listof (cons symbol string))
; Lists the possible snip types and their corresponding colors.
; For a given term that has snips of several different types, the snips will be
; ordered from left to right in the editor in the same order as their types appear
; in this list.
(define snip-types-and-colors
'((type . "blue")
(error . "red")))
; INTERFACE FOR MENUS
; symbol symbol -> string
; given a snip type and a menu action for snips (show/hide), return the corresponding
; menu text
(define (get-menu-text-from-snip-type type action)
(case type
[(type)
(case action
[(show) (strcst:string-constant mrflow-popup-menu-show-type)]
[(hide) (strcst:string-constant mrflow-popup-menu-hide-type)]
[else (error 'get-menu-text-from-type "MrFlow internal error; unknown type action: ~a" action)])]
[(error)
(case action
[(show) (strcst:string-constant mrflow-popup-menu-show-errors)]
[(hide) (strcst:string-constant mrflow-popup-menu-hide-errors)]
[else (error 'get-menu-text-from-type "MrFlow internal error; unknown error action: ~a" action)])]
[else (error 'get-menu-text-from-type "MrFlow internal error; unknown type: ~a" type)]))
; sba-state symbol label -> (listof string)
; given a snip type and a lable, returns the content of the snips to be
; added for that type and label.
(define (get-snip-text-from-snip-type sba-state type label)
(case type
[(type) (list (sba:pp-type sba-state (sba:get-type-from-label sba-state label) 'gui))]
[(error) (map err:sba-error-message (sba:get-errors-from-label sba-state label))]))
; DEFINITION WINDOW MIXIN
(drscheme:get/extend:extend-definitions-text saa:extend-top-editor-mixin)
(drscheme:get/extend:extend-tab
(mixin (drscheme:rep:context<%> drscheme:unit:tab<%>) ()
(inherit get-defs)
(define/augment (clear-annotations)
(inner (void) clear-annotations)
(send (get-defs) remove-all-snips-and-arrows-and-colors))
(super-new)))
; UNIT FRAME MIXIN
(drscheme:get/extend:extend-unit-frame
(lambda (super%)
(class super%
; -> void
(define/augment (enable-evaluation)
(inner cst:void enable-evaluation)
(send analyze-button enable #t))
; -> void
(define/augment (disable-evaluation)
(inner cst:void disable-evaluation)
(send analyze-button enable #f))
(super-instantiate ())
(inherit get-button-panel get-definitions-text get-interactions-text get-current-tab)
(define analyze-button
(instantiate
button% ()
(label (mrflow-bitmap this))
(parent (get-button-panel))
(callback
(lambda (button event)
(let ([start-time (current-milliseconds)]
[definitions-text (get-definitions-text)]
[current-tab (get-current-tab)]
[drs-eventspace (current-eventspace)]
[interactions-text (get-interactions-text)]
[language-settings
(fw:preferences:get
(drscheme:language-configuration:get-settings-preferences-symbol))])
(letrec-values
([(user-change-terms register-label-with-gui)
(saa:init-snips-and-arrows-gui
definitions-text
sba:get-source-from-label
sba:get-mzscheme-position-from-label
(lambda (label) (get-span-from-label sba-state label))
sba:get-arrows-from-labels
(lambda (label) (get-style-delta-from-label sba-state label))
(lambda (menu labels) cst:void)
get-menu-text-from-snip-type
(lambda (type label) (get-snip-text-from-snip-type sba-state type label))
snip-types-and-colors
#t)
; snips-and-arrows library testing...
; (saa:init-snips-and-arrows-gui
; definitions-text
; sba:get-source-from-label
; sba:get-mzscheme-position-from-label
; (lambda (label) (get-span-from-label sba-state label))
; sba:get-arrows-from-label
; (lambda (label) (get-style-delta-from-label sba-state label))
; (lambda (menu labels)
; (let* ([new-name-callback
; (lambda (item event)
; (let ([new-name
; (fw:keymap:call/text-keymap-initializer
; (lambda ()
; (get-text-from-user
; "rename"
; "rename")))]
; [terms (append
; (map
; (lambda (arrow-info)
; (cons (car arrow-info) "foo"))
; (sba:get-arrows-from-labels labels))
; (map
; (lambda (arrow-info)
; (cons (cadr arrow-info) "foo"))
; (sba:get-arrows-from-labels labels))
; )])
; (user-change-terms terms)))])
; (make-object menu-item%
; (strcst:string-constant cs-rename-id)
; menu
; new-name-callback)))
; get-menu-text-from-snip-type
; (lambda (type label) (get-snip-text-from-snip-type sba-state type label))
; snip-types-and-colors
; #f)
]
[(sba-state) (sba:make-sba-state register-label-with-gui)])
; disable-evaluation will lock the editor, so hopefully all the other tools
; unlock the editor to clear their crap (note that the second call below
; is a call to the superclass, so remove-all-snips-and-arrows-and-colors
; is not called here, but is called internally inside
; init-snips-and-arrows-gui
(disable-evaluation)
;(send current-tab clear-annotations)
; note: we have to do this each time, because the user might have changed
; the language between analyses.
(let* ([language-object (drscheme:language-configuration:language-settings-language
language-settings)]
[primitive-table-file (send language-object get-mrflow-primitives-filename)])
(if (file-exists? primitive-table-file)
(begin
(sba:initialize-primitive-type-schemes sba-state primitive-table-file)
(drscheme:eval:expand-program
(drscheme:language:make-text/pos definitions-text
0
(send definitions-text last-position))
language-settings
#t
; set current-directory and current-load-relative-directory before expansion
(lambda ()
(let* ([tmp-b (box #f)]
[fn (send definitions-text get-filename tmp-b)])
(unless (unbox tmp-b)
(when fn
(let-values ([(base name dir?) (split-path fn)])
(current-directory base)
(current-load-relative-directory base))))))
void
(lambda (syntax-object-or-eof iter)
(if (eof-object? syntax-object-or-eof)
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(lambda () ; =drs=
(let ([sba-end-time (current-milliseconds)])
;(printf "sba time: ~a ms~n" (- (current-milliseconds) start-time))
(sba:check-primitive-types sba-state)
;(printf "check time: ~a ms~n" (- (current-milliseconds) sba-end-time))
)
; color everything right before re-enabling buttons
(send definitions-text color-registered-labels)
(enable-evaluation)
)))
(begin
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(lambda () ; =drs=
;(printf "syntax: ~a~n" (syntax-object->datum syntax-object-or-eof))
(sba:create-label-from-term sba-state syntax-object-or-eof '() #f))))
; must be outside the parameterize so the next expansion occurs
; in the right eventspace...
(iter))))))
; get-mrflow-primitives-filename defaults to R5RS
; (see mrflow-default-implementation-mixin above), so if we arrive here,
; we know we are in trouble because it means no primitive table is
; defined for the current language and we couldn't even find the table
; for the R5RS primitives.
(error 'analyze-button-callback
"MrFlow internal error; R5RS primitive types file ~a doesn't exist."
primitive-table-file)))))))))
(send (get-button-panel) change-children
(lambda (button-list)
(cons analyze-button (remq analyze-button button-list))))
) ; class
)) ; drscheme:get/extend:extend-unit-frame
)) ; tool@ unit/sig
); module

1322
collects/mrflow/hashcons.ss
View File

File diff suppressed because it is too large Load Diff

91
collects/mrflow/labels.ss
View File

@ -1,91 +0,0 @@
(module labels mzscheme
; XXX labels contain types and types contain labels, so we will need another layer for
; the contracts once the types are extracted from cgp.ss
(provide
(struct label (parents children type-var trace prim? term set edges))
(struct label-cst (value))
(struct label-cons (car cdr))
(struct label-vector (element))
(struct label-promise (value))
(struct label-case-lambda (struct rest-arg?s req-args argss exps effects))
(struct label-values (label))
(struct label-struct-value (type fields))
(struct label-struct-type (name parent parent-fields-nbr total-fields-nbr error?))
)
; parents = children = (listof label)
; type-var = (union type-var #f), trace = boolean, prim? = boolean
; term = syntax-object, set = (hash-table-of label (make-arrows (listof label) (listof label) (listof label)),
; edges = (hashtableof symbol edge))
; a flow graph label/node type-var is a type variable name used when reconstructing recursive
; types.
; trace is used to detect cycles in the graph during type reconstruction.
; prim? tells whether the label was created during graph reconstruction from a primitive
; type. We need this to detect the entrance of a tunnel.
; Note that the only reason we need to have this tunneling stuff is to keep the GUI arrows right.
; term: the source program term (or a fake version of it, in the case of "null" when we have
; a rest argument)
; set: contains label structures (see below) for all the values that flow into this term.
; Each label in the set has two lists of in and out edges pointing back and forth to the nodes
; from which this label has flowed in (or '() if the label is the source of the label) and
; flowed out to. The in edges (which need to be checked each time a propagation is done, to
; revent cycles) are in a list, and not in an hash-table, because we assume that the same
; label is not going to flow very often into this term through several paths. The out-edge
; list is only used to draw arrows, so it doesn't have to be implemented very efficiently.
; Note that, since constants are represented by label structs, the same constant can appear
; several times in the set, even symbols.
; edges: functions that take two labels as argument and either propagate the second one to
; another label, using the first label as the source, or transform the graph accordingly (if
; the inflowing label is a function pseudo-label and the label into which it flows corresponds
; to the operator in an application, for example).
; parent and children are used to memoize the parent and children arrows for all the values
; in the label's value set. Computing these when the code contains huge amounts of macro-
; generated recurisve code is quite expensive.
(define-struct label (parents children type-var trace prim? term set edges))
; a constant...
(define-struct (label-cst label) (value))
; car = label, cdr = label
(define-struct (label-cons label) (car cdr))
(define-struct (label-vector label) (element))
(define-struct (label-promise label) (value))
; struct = label-struct
; rest-arg?s = (listof boolean), req-args = (listof number), argss = (listof (listof label)),
; exps = (listof label), app-thunks = (listof (-> void))
; Each "level" of the six lists represents the args and body labels of a given clause in the
; case-lambda. At a given level, rest-arg? tells whether this clause has a rest argument,
; and req-args gives the number of required arguments, so it only has to be computed once.
; top-free-varss are the labels of the top level free variables in the corresponding clause.
; This field is updated as a side effect when analyzing top level variable references inside
; the body of a lambda. Edges flowing into these free variables must be created when the
; clause is applied. app-thunk is a thunk that is used to delay the transformation of the
; graph when a function flows into an application, until the clause around the application
; is itself applied. The two are merged, because one of the delayed app could set! a top level
; variable, and the top level variable can be referenced both before and after the application,
; so lookups and applications have to be done in exactly the right order.
; struct is just a placeholder to tell the type of structure a given structure-processing
; function is supposed to deal with.
(define-struct (label-case-lambda label)
(struct rest-arg?s req-args argss exps effects))
; label = label (a label-cons based list of labels)
; used to simulate multiple values. So this label is going to flow around and work pretty
; much like a cons label. the problem is that multiple values are not first-class in Scheme,
; so we have to be careful to only propagate them through edges that correspond to the result
; of applications, never through edges that correspond to arguments of applications. Hence
; the reason for the complication in create-simple-edge. Note that define-struct expands
; into a define-values, so we need all that stuff.
(define-struct (label-values label) (label))
; symbol symbol label number (listof label)
(define-struct (label-struct-value label) (type fields))
(define-struct (label-struct-type label)
(name parent parent-fields-nbr total-fields-nbr error?))
)

49
collects/mrflow/mrflow.ss
View File

@ -1,49 +0,0 @@
(module mrflow mzscheme
(require mzlib/pretty
mzlib/contract
mred)
(provide (all-from mzscheme)
;(all-from-except mzscheme vector-ref)
;(rename dbg-vector-ref vector-ref)
(all-from-except mzlib/contract provide/contract define/contract)
; one or the other
provide/contract define/contract
;(rename dbg-provide/contract provide/contract)(rename dbg-define-contract define/contract)
non-negative-exact-integer?
text%?
style-delta%?
)
(define-syntax (dbg-provide/contract stx)
(syntax-case stx (struct)
[(_) #'(provide)]
[(_ (id contract) other ...)
#'(begin (provide id) (dbg-provide/contract other ...))]
[(_ (struct id ((field contract) ...)) other ...)
#'(begin (provide (struct id (field ...))) (dbg-provide/contract other ...))])
)
(define-syntax (dbg-define/contract stx)
(syntax-case stx ()
[(_ name contract body) #'(define name body)]))
(define-syntax dbg-vector-ref
(lambda (stx)
(syntax-case stx ()
[(_ args ...)
#`(begin
(printf "~a ~a ~a ~a~n"
#,(syntax-source stx)
#,(syntax-line stx)
#,(syntax-column stx)
#,(syntax-original? stx))
(#,#'vector-ref args ...))])))
(define non-negative-exact-integer? (and/c integer? exact? (>=/c 0)))
(define text%? (is-a?/c text%))
(define style-delta%? (is-a?/c style-delta%))
)

87
collects/mrflow/primitives/algol60.ss
View File

@ -1,87 +0,0 @@
; Algol 60 primitives and runtime support
(
; primitives
(!= (number number -> boolean))
(! (boolean -> boolean))
(& (boolean boolean -> boolean))
(\| (boolean boolean -> boolean))
(=> (boolean boolean -> boolean))
(== (boolean boolean -> boolean))
(sign (forall ([a top])
((real -> a) (-> real) -> a)))
(entier (forall ([a top])
((real -> a) (-> real) -> a)))
(a60:sin (forall ([a top])
((real -> a) (-> real) -> a)))
(a60:cos (forall ([a top])
((real -> a) (-> real) -> a)))
(a60:arctan (forall ([a top])
((real -> a) (-> real) -> a)))
(a60:sqrt (forall ([a top])
((real -> a) (-> real) -> a)))
(a60:abs (forall ([a top])
((real -> a) (-> real) -> a)))
(a60:ln (forall ([a top])
((real -> a) (-> real) -> a)))
(a60:exp (forall ([a top])
((real -> a) (-> real) -> a)))
(prints (forall ([a top])
((void -> a) (-> top) -> a)))
(printn (forall ([a top])
((void -> a) (-> top) -> a)))
(printsln (forall ([a top])
((void -> a) (-> top) -> a)))
(printnln (forall ([a top])
((void -> a) (-> top) -> a)))
; Algol60 runtime support
;(a60:array (struct a60:array (dependant type)))
;(a60:switch (struct a60:switch (choices))
(undefined undefined)
(check-boolean (forall ([a top]) (a -> a)))
(goto (forall ([a top]) ((-> a) -> a)))
(get-value (forall ([a top]) ((-> a) -> a)))
(set-target! (forall ([a top][b top])
((a -> b) a -> b)))
;make-array
;array-ref
;array-set!
;make-switch
;switch-ref
(coerce (forall ([a top])
(symbol a -> a)))
; R5RS runtime support
(void (-> void))
(= (real real -> boolean))
(< (real real -> boolean))
(> (real real -> boolean))
(<= (real real -> boolean))
(>= (real real -> boolean))
(+ (real real -> real))
(* (real real -> real))
(- (real real -> real))
(/ (real real -> real))
(quotient (integer integer -> integer))
(remainder (integer integer -> integer))
(modulo (integer integer -> integer))
(values (forall ([a_values top])
(case-lambda
[(rest a_values) (values a_values)]
)))
)

884
collects/mrflow/primitives/r5rs.ss
View File

@ -1,884 +0,0 @@
; R5RS
; When are we going to be able to compute all this directly from an S-exp version of R5RS ?
(
; 4.2.6 quasiquotation
; not part of r5rs, but the expansion of ,@ uses qq-append
(qq-append (forall ([b_append top][c_append top])
(case-lambda
[((listof b_append) c_append)
(union c_append
(rec-type
([improper-list
(union ()
(cons b_append
(union c_append improper-list)))])
improper-list))])))
; 6.1 Equivalence predicates
(eqv? (top top -> boolean))
(eq? (top top -> boolean))
(equal? (top top -> boolean))
; 6.2.5 Numerical operations
; in Scheme it seems that positive = strictly positive and
; negative = strictly negative
(number? (top -> boolean))
(complex? (top -> boolean))
(real? (top -> boolean))
(rational? (top -> boolean))
(integer? (top -> boolean))
(exact? (complex -> boolean))
(inexact? (complex -> boolean))
(= (complex complex complex *-> boolean))
(< (real real real *-> boolean))
(> (real real real *-> boolean))
(<= (real real real *-> boolean))
(>= (real real real *-> boolean))
(zero? (complex -> boolean))
(positive? (real -> boolean))
(negative? (real -> boolean))
(odd? (integer -> boolean))
(even? (integer -> boolean))
; if any arg inexact => result inexact
(max (forall ([x_max real])
(case-lambda
[(x_max) x_max]
[(rest real (listof real)) real])))
; if any arg inexact => result inexact
(min (forall ([x_min real])
(case-lambda
[(x_min) x_min]
[(rest real (listof real)) real])))
; no arg => 0
; z => z
(+ (forall ([z_+ complex])
(case-lambda
[(rest complex complex (listof complex)) complex]
[() 0]
[(z_+) z_+]
)))
; no arg => 1
; z => z
(* (forall ([z_* complex])
(case-lambda
[(rest complex complex (listof complex)) complex]
[() 1]
[(z_*) z_*]
)))
; z => -z
(- (complex complex *-> complex))
; z => 1/z
(/ (complex complex *-> complex))
; returns non-negative real
(abs (real -> real))
; second arg non-zero
(quotient (integer integer -> integer))
; second arg non-zero
; result has same sign as first arg
(remainder (integer integer -> integer))
; second arg non-zero
; result has same sign as second arg
(modulo (integer integer -> integer))
; no arg => 0
; n => n (from math)
; result is non-negative integer
(gcd (forall ([n_gcd integer])
(case-lambda
[(rest integer integer (listof integer)) integer]
[() 0]
[(n_gcd) n_gcd]
)))
; no arg => 1
; n => n (from math)
; result is non-negative integer
(lcm (forall ([n_lcm integer])
(case-lambda
[(rest integer integer (listof integer)) integer]
[() 1]
[(n_lcm) n_lcm]
)))
(numerator (rational -> integer))
; result always positive
; 0 => 1
(denominator (rational -> integer))
(floor (real -> integer))
(ceiling (real -> integer))
(truncate (real -> integer))
(round (real -> integer))
(rationalize (real real -> rational))
(exp (complex -> complex))
(log (complex -> complex))
(sin (complex -> complex))
(cos (complex -> complex))
(tan (complex -> complex))
(asin (complex -> complex))
(acos (complex -> complex))
(atan (case-lambda
[(complex) complex]
[(real real) complex]))
; positive real part, or zero real part and non-negative imaginary part
(sqrt (complex -> complex))
; (expt 0 0) = 1
; (expt 0 z) = 0
(expt (complex complex -> complex))
(make-rectangular (real real -> complex))
(make-polar (real real -> complex))
(real-part (complex -> real))
(imag-part (complex -> real))
; returns non-negative real
(magnitude (complex -> real))
(angle (complex -> real))
(exact->inexact (complex -> inexact-complex))
(inexact->exact (complex -> exact-complex))
; 6.2.6 Numerical input and output
; this really ougth to be called complex->string and string->complex,
; especially since R5RS explicitely uses a "z" as the first argument
; name... R5RS seems to actually confuse complex and number quite a lot,
; despite the second note in section 6.2.5, page 21.
; radix is either 2, 8, 10, or 16
(number->string (case-lambda
[(complex) string]
[(complex exact-integer) string]))
; radix is either 2, 8, 10, or 16
(string->number (case-lambda
[(string) (union complex #f)]
[(string exact-integer) (union complex #f)]))
; 6.3.1 Booleans
(not (boolean -> boolean))
(boolean? (top -> boolean))
; 6.3.2 Pairs and lists
(pair? (top -> boolean))
(cons (forall ([a_cons top]
[b_cons top])
(a_cons b_cons -> (cons a_cons b_cons))))
(car (forall ([a_car top])
((cons a_car top) -> a_car)))
(cdr (forall ([a_cdr top])
((cons top a_cdr) -> a_cdr)))
; b can't be twice in contra-variant position...
;(set-car! (forall ([a top][b top][c top])
; (cons (union a b) c) b -> void
;(set-cdr! (forall ([a top][b top][c top])
; (cons a (union b c)) b -> void
(caar (forall ([a_caar top])
((cons (cons a_caar top) top) -> a_caar)))
(cdar (forall ([a_cdar top])
((cons (cons top a_cdar) top) -> a_cdar)))
(cadr (forall ([a_cadr top])
((cons top (cons a_cadr top)) -> a_cadr)))
(cddr (forall ([a_cddr top])
((cons top (cons top a_cddr)) -> a_cddr)))
(caaar (forall ([a_caaar top])
((cons (cons (cons a_caaar top) top) top) -> a_caaar)))
(cdaar (forall ([a_cdaar top])
((cons (cons (cons top a_cdaar) top) top) -> a_cdaar)))
(cadar (forall ([a_cadar top])
((cons (cons top (cons a_cadar top)) top) -> a_cadar)))
(cddar (forall ([a_cddar top])
((cons (cons top (cons top a_cddar)) top) -> a_cddar)))
(caadr (forall ([a_caadr top])
((cons top (cons (cons a_caadr top) top)) -> a_caadr)))
(cdadr (forall ([a_cdadr top])
((cons top (cons (cons top a_cdadr) top)) -> a_cdadr)))
(caddr (forall ([a_caddr top])
((cons top (cons top (cons a_caddr top))) -> a_caddr)))
(cdddr (forall ([a_cdddr top])
((cons top (cons top (cons top a_cdddr))) -> a_cdddr)))
(caaaar (forall ([a_caaaar top])
((cons (cons (cons (cons a_caaaar top) top) top) top) -> a_caaaar)))
(cdaaar (forall ([a_cdaaar top])
((cons (cons (cons (cons top a_cdaaar) top) top) top) -> a_cdaaar)))
(cadaar (forall ([a_cadaar top])
((cons (cons (cons top (cons a_cadaar top)) top) top) -> a_cadaar)))
(cddaar (forall ([a_cddaar top])
((cons (cons (cons top (cons top a_cddaar)) top) top) -> a_cddaar)))
(caadar (forall ([a_caadar top])
((cons (cons top (cons (cons a_caadar top) top)) top) -> a_caadar)))
(cdadar (forall ([a_cdadar top])
((cons (cons top (cons (cons top a_cdadar) top)) top) -> a_cdadar)))
(caddar (forall ([a_caddar top])
((cons (cons top (cons top (cons a_caddar top))) top) -> a_caddar)))
(cdddar (forall ([a_cdddar top])
((cons (cons top (cons top (cons top a_cdddar))) top) -> a_cdddar)))
(caaadr (forall ([a_caaadr top])
((cons top (cons (cons (cons a_caaadr top) top) top)) -> a_caaadr)))
(cdaadr (forall ([a_cdaadr top])
((cons top (cons (cons (cons top a_cdaadr) top) top)) -> a_cdaadr)))
(cadadr (forall ([a_cadadr top])
((cons top (cons (cons top (cons a_cadadr top)) top)) -> a_cadadr)))
(cddadr (forall ([a_cddadr top])
((cons top (cons (cons top (cons top a_cddadr)) top)) -> a_cddadr)))
(caaddr (forall ([a_caaddr top])
((cons top (cons top (cons (cons a_caaddr top) top))) -> a_caaddr)))
(cdaddr (forall ([a_cdaddr top])
((cons top (cons top (cons (cons top a_cdaddr) top))) -> a_cdaddr)))
(cadddr (forall ([a_cadddr top])
((cons top (cons top (cons top (cons a_cadddr top)))) -> a_cadddr)))
(cddddr (forall ([a_cddddr top])
((cons top (cons top (cons top (cons top a_cddddr)))) -> a_cddddr)))
(null? (top -> boolean))
(list? (top -> boolean))
; the rest argument does all the work
(list (forall ([a_list top])
(case-lambda
[(rest a_list) a_list])))
(length ((listof top) -> exact-integer))
(append (forall ([a_append top]
[b_append top][c_append top]
[d_append top][e_append top][f_append top]
[g_append top][h_append top][i_append top][j_append top]
[k_append top][l_append top][m_append top][n_append top][o_append top]
[p_append top][q_append top][r_append top][s_append top][t_append top][u_append top])
(case-lambda
[() ()]
[(a_append) a_append]
[((listof b_append) c_append)
(union c_append
(rec-type
([improper-list
(union ()
(cons b_append
(union c_append improper-list)))])
improper-list))]
[((listof d_append) (listof e_append) f_append)
(union f_append
(rec-type
([improper-list
(union ()
(cons (union d_append e_append)
(union f_append improper-list)))])
improper-list))]
[((listof g_append) (listof h_append) (listof i_append) j_append)
(union j_append
(rec-type
([improper-list
(union ()
(cons (union g_append h_append i_append)
(union j_append improper-list)))])
improper-list))]
[((listof k_append) (listof l_append) (listof m_append) (listof n_append) o_append)
(union o_append
(rec-type
([improper-list
(union ()
(cons (union k_append l_append m_append n_append)
(union o_append improper-list)))])
improper-list))]
[((listof p_append) (listof q_append) (listof r_append) (listof s_append) (listof t_append) u_append)
(union u_append
(rec-type
([improper-list
(union ()
(cons (union p_append q_append r_append s_append t_append)
(union u_append improper-list)))])
improper-list))])))
; the last element could be not a list => improper list
; this doesn't work because it doesn't enforce the listness of args beyond
; the first one but before the last one...
;[(rest (listof b_append) (listof c_append))
; (rec-type ([improper-list (union ()
; (cons (union b_append c_append)
; (union c_append improper-list)))])
; improper-list)]
;(union c_append (listof b_append))]
;)))
(reverse (forall ([a_reverse top])
((listof a_reverse) -> (listof a_reverse))))
; exact-integer should be non-negative...
(list-tail (forall ([a_list-tail top])
((listof a_list-tail) exact-integer -> (listof a_list-tail))))
(list-ref (forall ([a_list-ref top])
((listof a_list-ref) exact-integer -> a_list-ref)))
(memq (forall ([a_memq top]
[b_memq top])
(a_memq (listof b_memq) -> (union #f (cons a_memq (listof b_memq))))))
(memv (forall ([a_memv top]
[b_memv top])
(a_memv (listof b_memv) -> (union #f (cons a_memv (listof b_memv))))))
(member (forall ([a_member top]
[b_member top])
(a_member (listof b_member) -> (union #f (cons a_member (listof b_member))))))
(assq (forall ([a_assq top]
[b_assq top])
(a_assq (listof (cons top b_assq)) -> (union #f (cons a_assq b_assq)))))
(assv (forall ([a_assv top]
[b_assv top])
(a_assv (listof (cons top b_assv)) -> (union #f (cons a_assv b_assv)))))
(assoc (forall ([a_assoc top]
[b_assoc top])
(a_assoc (listof (cons top b_assoc)) -> (union #f (cons a_assoc b_assoc)))))
; 6.3.3. Symbols
(symbol? (top -> boolean))
(symbol->string (symbol -> string))
(string->symbol (string -> symbol))
; 6.3.4 Characters
(char? (top -> boolean))
(char=? (char char -> boolean))
(char<? (char char -> boolean))
(char>? (char char -> boolean))
(char<=? (char char -> boolean))
(char>=? (char char -> boolean))
(char-ci=? (char char -> boolean))
(char-ci<? (char char -> boolean))
(char-ci>? (char char -> boolean))
(char-ci<=? (char char -> boolean))
(char-ci>=? (char char -> boolean))
(char-alphabetic? (char -> boolean))
(char-numeric? (char -> boolean))
(char-whitespace? (char -> boolean))
(char-upper-case? (letter -> boolean))
(char-lower-case? (letter -> boolean))
; R5RS doesn't say the integer has to be positive...
(char->integer (char -> exact-integer))
(integer->char (exact-integer -> char))
(char-upcase (char -> char))
(char-downcase (char -> char))
; 6.3.5 Strings
(string? (top -> boolean))
; integer should be non-negative
(make-string (case-lambda
[(exact-integer) string]
[(exact-integer char) string]))
(string (case-lambda
[(rest char (listof char)) string]
[() ""]
))
; exact positive integer ? exact integer ? integer ?
(string-length (string -> exact-integer))
(string-ref (string exact-integer -> char))
; should inject string into the first arg
;(string-set! (string exact-integer char -> void))
(string=? (string string -> boolean))
(string-ci=? (string string -> boolean))
(string<? (string string -> boolean))
(string>? (string string -> boolean))
(string<=? (string string -> boolean))
(string>=? (string string -> boolean))
(string-ci<? (string string -> boolean))
(string-ci>? (string string -> boolean))
(string-ci<=? (string string -> boolean))
(string-ci>=? (string string -> boolean))
(substring (string exact-integer exact-integer -> string))
(string-append (forall ([a_string-append string])
(case-lambda
[(rest string string (listof string)) string]
[() ""]
[(a_string-append) a_string-append]
)))
(string->list (string -> (listof char)))
(list->string ((listof char) -> string))
; (string-copy (forall ([a string]) (a -> a))) works only if we don't have string-set!
(string-copy (string -> string))
; should inject string into first arg
;(string-fill! (string char -> void))
; 6.3.6 Vectors
(vector? (top -> boolean))
; integer should be non-negative
(make-vector (forall ([a_make-vector top])
(case-lambda
[(exact-integer) (vector top)]
[(exact-integer a_make-vector) (vector a_make-vector)])))
(vector (forall ([a_vector top])
(a_vector *-> (vector a_vector))))
(vector-length ((vector top) -> exact-integer))
(vector-ref (forall ([a_vector-ref top])
((vector a_vector-ref) exact-integer -> a_vector-ref)))
; should inject third arg into first
;(vector-set! (vector exact-integer top -> void))
(vector->list (forall ([a_vector->list top])
((vector a_vector->list) -> (listof a_vector->list))))
(list->vector (forall ([a_list->vector top])
((listof a_list->vector) -> (vector a_list->vector))))
; second arg shoould flow into first
;(vector-fill! (vector top -> void))
; 6.4 Control features
(procedure? (top -> boolean))
(apply (forall ([a_apply top][b_apply top]
[c_apply top][d_apply top][e_apply top]
[f_apply top][g_apply top][h_apply top][i_apply top]
[j_apply top][k_apply top][l_apply top][m_apply top][n_apply top]
[o_apply top][p_apply top][q_apply top][r_apply top][s_apply top][t_apply top]
[u_apply top][v_apply top][w_apply top][x_apply top][y_apply top][z_apply top][aa_apply top]
;[ab_apply top][ac_apply top]
)
(case-lambda
[((case-lambda [(rest (listof a_apply)) b_apply])
(listof a_apply)) b_apply]
[((case-lambda [(rest (listof (union c_apply d_apply))) e_apply])
c_apply (listof d_apply)) e_apply]
[((case-lambda [(rest (listof (union f_apply g_apply h_apply))) i_apply])
f_apply g_apply (listof h_apply)) i_apply]
[((case-lambda [(rest (listof (union j_apply k_apply l_apply m_apply))) n_apply])
j_apply k_apply l_apply (listof m_apply)) n_apply]
[((case-lambda [(rest (listof (union o_apply p_apply q_apply r_apply s_apply))) t_apply])
o_apply p_apply q_apply r_apply (listof s_apply)) t_apply]
[((case-lambda [(rest (listof (union u_apply v_apply w_apply x_apply y_apply z_apply))) aa_apply])
u_apply v_apply w_apply x_apply y_apply (listof z_apply)) aa_apply]
; this would almost work, except for the last argument, that would
; show up as a list in the result
;[(rest (case-lambda
; [(rest a) b])
; a)
; b])))
; so we have to deconstruct everything, and be *very* conservative.
; This *will* raise errors about possible infinite lists, but that's the
; best we can if we want to cover all the possible cases.
; this will not work because it doesn't allow for the first args to not
; be lists
;[(rest (case-lambda
; [(rest (listof ab_apply)) ac_apply])
; (listof (listof ab_apply)))
; ac_apply])))
; and this doesn't work either because it allows for the last arg
; to not be a list
;[(rest (case-lambda
; [(rest (listof (union a_apply (listof b_apply)))) c_apply])
; (listof (union a_apply (listof b_apply))))
; c_apply])))
)))
(map (forall ([a_map top][b_map top]
[c_map top][d_map top][e_map top]
[f_map top][g_map top][h_map top][i_map top]
[j_map top][k_map top][l_map top][m_map top][n_map top]
[o_map top][p_map top][q_map top][r_map top][s_map top][t_map top]
)
(case-lambda
[((a_map -> b_map) (listof a_map))
(listof b_map)]
[((c_map d_map -> e_map) (listof c_map) (listof d_map))
(listof e_map)]
[((f_map g_map h_map -> i_map) (listof f_map) (listof g_map) (listof h_map))
(listof i_map)]
[((j_map k_map l_map m_map -> n_map) (listof j_map) (listof k_map) (listof l_map) (listof m_map))
(listof n_map)]
[((o_map p_map q_map r_map s_map -> t_map) (listof o_map) (listof p_map) (listof q_map) (listof r_map) (listof s_map))
(listof t_map)]
; use at your own risks: you'll loose arity checking and get spurious errors
; about '() not being a pair or about infinite lists (but the result of map
; will be properly conservative, so if you ignore the errors for map itself
; and make sure the arity of the function given to map is correct, then you
; might be able to use the output of map to detect errors down the flow - except
; that the output of map will be a list => using car on it or stuff like that
; will trigger another error...)
; The whole problem is that map needs a dependent type...
;[(rest
; (case-lambda
; [(rest o p q r (listof s)) t])
; (listof o) (listof p) (listof q) (listof r) (listof (listof s)))
; (listof t)]
)))
(for-each (forall ([a_for-each top];[b top]
[c_for-each top][d_for-each top];[e top]
[f_for-each top][g_for-each top][h_for-each top];[i top]
[j_for-each top][k_for-each top][l_for-each top][m_for-each top];[n top]
[o_for-each top][p_for-each top][q_for-each top][r_for-each top][s_for-each top];[t top]
)
(case-lambda
[((a_for-each -> top) (listof a_for-each))
void]
[((c_for-each d_for-each -> top) (listof c_for-each) (listof d_for-each))
void]
[((f_for-each g_for-each h_for-each -> top) (listof f_for-each) (listof g_for-each) (listof h_for-each))
void]
[((j_for-each k_for-each l_for-each m_for-each -> top) (listof j_for-each) (listof k_for-each) (listof l_for-each) (listof m_for-each))
void]
[((o_for-each p_for-each q_for-each r_for-each s_for-each -> top) (listof o_for-each) (listof p_for-each) (listof q_for-each) (listof r_for-each) (listof s_for-each))
void]
; use at your own risks: you'll loose arity checking and get spurious errors
; about '() not being a pair or about infinite lists (but the result of for-each
; will be properly conservative)
; The whole problem is that for-each needs a dependent type...
;[(rest
; (case-lambda
; [(rest o p q r (listof s)) top])
; (listof o) (listof p) (listof q) (listof r) (listof (listof s)))
; void]
)))
; (delay expr) => (#%app make-promise (lambda () expr))
; if we have the arrow type in the argument of make-promise, then the application
; will happen immediately, which we don't want. So instead
; a will be the thunk, and having the arrow type for this thunk in the type for force
; will force the application of the thunk inside force.
; pp-type for promises just "forgets" to show the enclosing thunk part of the type.
; It's ugly, but it works, and it works well enough to approximate memoization.
(make-promise (forall ([a_make-promise top])
(a_make-promise -> (promise a_make-promise))))
(force (forall ([a_force top])
((promise (-> a_force)) -> a_force)))
(call-with-current-continuation (forall ([a_call/cc top]
[b_call/cc top])
(((a_call/cc -> bottom) -> b_call/cc)
-> (union a_call/cc b_call/cc))))
; correct, but currently triggers a bug.
;(call-with-current-continuation (forall ([a top]
; [b top])
; ((; continuation
; (case-lambda [(rest a) bottom])
; ;result of body of lambda that
; ;receives the continuation
; -> b)
; ; result of call/cc
; -> (union (values a) b))))
; multiple values are simulated internally as a list...
(values (forall ([a_values top])
(case-lambda
[(rest a_values) (values a_values)]
)))
(call-with-values (forall ([a_call/vals top] ; one or multiple values
[b_call/vals top])
(case-lambda
[((case-lambda
[() (values a_call/vals)])
(case-lambda
[(rest a_call/vals) b_call/vals]))
b_call/vals])))
; this limited values works fine, but then call-with-values doesnt', because all the clauses
; in call-with-values would have only two arguments, making discrimination between the different
; cases impossible.
;(values (forall ([a top]
; [b top][c top]
; [d top][e top][f top]
; [g top][h top][i top][j top]
; [k top][l top][m top][n top][o top])
; (case-lambda
; [() (values)]
; [(a) (values a)]
; [(b c) (values b c)]
; [(d e f) (values d e f)]
; [(g h i j) (values g h i j)]
; [(k l m n o) (values k l m n o)])))
;
;(call-with-values (forall ([a top][b top]
; [c top][d top][e top])
; (case-lambda
; [((case-lambda [() (values a)]) (case-lambda [(a) b])) b]
; [((case-lambda [() (values c d)]) (case-lambda [(c d) e])) e]
; )))
(dynamic-wind (forall ([a_dyn/w top])
((-> top) (-> a_dyn/w) (-> top) -> a_dyn/w)))
; 6.5 Eval
; letter is a subtype of char, all the number types are subtypes of number
; see section 7.1.2 of R5RS for the complete definition of datum
(eval ((rec-type ([datum (union simple-datum compound-datum)]
[simple-datum (union boolean number char string symbol)]
;[compound-datum (union list-datum vector-datum)]
[compound-datum (union list-datum (vector datum))]
[list-datum (union ()
(cons datum list-datum)
(cons datum datum))]
;[vector-datum (vector datum)]
)
datum) env -> (union top #f)))
(scheme-report-environment (5 -> env))
(null-environment (5 -> env))
(interaction-environment (-> env))
; 6.6.1 Ports
; R5RS doesn't always explicitely differentiate between input and output ports...
(call-with-input-file (forall ([a_call/if top])
(string (input-port -> a_call/if) -> a_call/if)))
(call-with-output-file (forall ([a_call/of top])
(string (output-port -> a_call/of) -> a_call/of)))
(input-port? (top -> boolean))
(output-port? (top -> boolean))
(current-input-port (-> input-port))
(current-output-port (-> output-port))
(with-input-from-file (forall ([a_with/if top])
(string (-> a_with/if) -> a_with/if)))
(with-output-to-file (forall ([a_with/of top])
(string (-> a_with/of) -> a_with/of)))
(open-input-file (string -> input-port))
(open-output-file (string -> output-port))
(close-input-port (input-port -> void))
(close-output-port (output-port -> void))
; 6.6.2 Input
; eof is included in top, but #f needs to be included explicitely
; because of the simplistic way if-dependency is done
(read (case-lambda
[() (union top #f)]
[(input-port) (union top #f)]))
(read-char (case-lambda
[() char]
[(input-port) char]))
(peek-char (case-lambda
[() char]
[(input-port) char]))
(eof-object? (top -> boolean))
(char-ready? (case-lambda
[() boolean]
[(input-port) boolean]))
; 6.6.3 Output
(write (case-lambda
[(top) void]
[(top output-port) void]))
(display (case-lambda
[(top) void]
[(top output-port) void]))
(newline (case-lambda
[() void]
[(output-port) void]))
(write-char (case-lambda
[(char) void]
[(char output-port) void]))
; 6.6.4 System interface
(load (string -> (union top #f)))
(transcript-on (string -> void))
(transcript-off (-> void))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; not R5RS, just for testing
; (if test then) macro-expanded into (if test then (void))
(void (-> void))
(null ())
; (id (forall ([a_id top]) (a_id -> a_id)))
; (make-func (-> (-> 1)))
; (foo (cons 1 2))
; (pi 3.1)
; ; one required argument that has to be a list, the elements are then extracted
; (gather-one1 (forall ([a_go1 top])
; ((listof a_go1) -> a_go1)))
; (gather-one2 (forall ([a_go2 top])
; (case-lambda
; [((listof a_go2)) a_go2])))
; ; unknown number of arguments that are converted into a list by the rest argument,
; ; then extracted
; (gather-many1 (forall ([a_gm1 top])
; (a_gm1 *-> a_gm1)))
; (gather-many2 (forall ([a_gm2 top])
; (case-lambda
; [(rest (listof a_gm2)) a_gm2])))
; ; don't try this at home
; ;(gather-other (forall ([a top])
; ; ((a) *-> a)))
;
; (gen-nums (-> (listof number)))
;
; (apply-gen (forall ([a_app/gen top]
; [b_app/gen top])
; (case-lambda
; [((case-lambda [(rest a_app/gen) b_app/gen]) a_app/gen) b_app/gen])))
;
; (lnum (forall ([a_lnum top])
; ((listof a_lnum) -> a_lnum)))
; ; ALGOL60 primitives and runtime, to be able to analyze the expanded version
;
; (!= (number number -> boolean))
; (! (boolean -> boolean))
; (& (boolean boolean -> boolean))
; (\| (boolean boolean -> boolean))
; (=> (boolean boolean -> boolean))
; (== (boolean boolean -> boolean))
;
; (sign (forall ([a top])
; ((real -> a) (-> real) -> a)))
; (entier (forall ([a top])
; ((real -> a) (-> real) -> a)))
;
; (a60:sin (forall ([a top])
; ((real -> a) (-> real) -> a)))
; (a60:cos (forall ([a top])
; ((real -> a) (-> real) -> a)))
; (a60:arctan (forall ([a top])
; ((real -> a) (-> real) -> a)))
; (a60:sqrt (forall ([a top])
; ((real -> a) (-> real) -> a)))
; (a60:abs (forall ([a top])
; ((real -> a) (-> real) -> a)))
; (a60:ln (forall ([a top])
; ((real -> a) (-> real) -> a)))
; (a60:exp (forall ([a top])
; ((real -> a) (-> real) -> a)))
;
; (prints (forall ([a top])
; ((void -> a) (-> top) -> a)))
; (printn (forall ([a top])
; ((void -> a) (-> top) -> a)))
; (printsln (forall ([a top])
; ((void -> a) (-> top) -> a)))
; (printnln (forall ([a top])
; ((void -> a) (-> top) -> a)))
;
; ; Algol60 runtime support
;
; ;(a60:array (struct a60:array (dependant type)))
; ;(a60:switch (struct a60:switch (choices))
;
; (undefined undefined)
;
; (check-boolean (forall ([a top]) (a -> a)))
; (goto (forall ([a top]) ((-> a) -> a)))
; (get-value (forall ([a top]) ((-> a) -> a)))
; (set-target! (forall ([a top][b top])
; ((a -> b) a -> b)))
; ;make-array
; ;array-ref
; ;array-set!
; ;make-switch
; ;switch-ref
;
; (coerce (forall ([a top])
; (symbol a -> a)))
;
;
; ; R5RS runtime support
;
; (void (-> void))
;
; (= (real real -> boolean))
; (< (real real -> boolean))
; (> (real real -> boolean))
; (<= (real real -> boolean))
; (>= (real real -> boolean))
;
; (+ (real real -> real))
; (* (real real -> real))
; (- (real real -> real))
; (/ (real real -> real))
;
; (quotient (integer integer -> integer))
; (remainder (integer integer -> integer))
; (modulo (integer integer -> integer))
;
; (values (forall ([a_values top])
; (case-lambda
; [(rest a_values) (values a_values)]
; )))
)

61
collects/mrflow/sba-errors.ss
View File

@ -1,61 +0,0 @@
(module sba-errors (lib "mrflow.ss" "mrflow")
(require
(prefix cst: "constants.ss")
(prefix lab: "labels.ss")
;"assoc-set-list.ss"
"assoc-set-hash.ss"
)
; (listof label) symbol string
; need this before the contracts because of sba-error?
(define-struct sba-error (labels gravity message) (make-inspector))
; (assoc-setof label (listof sba-error))
; we use a list instead of a set for the sba-errors, because that's what error-table-get
; has to return anyway
(define-struct error-table (assoc-set))
(provide/contract
(sba-error-gravity (sba-error? . -> . (symbols 'red 'orange 'green)))
(sba-error-message (sba-error? . -> . string?))
(error-table-make (-> error-table?))
(error-table? (any/c . -> . boolean?))
(error-table-set (error-table? (listof lab:label?) (symbols 'red 'orange 'green) string? . -> . void?))
(error-table-get (error-table? lab:label? . -> . (listof sba-error?)))
)
; -> error-table
(define (error-table-make)
(make-error-table (assoc-set-make)))
; top -> boolean
; error-table? comes from the structure definition
; error-table (listof label) (union 'red 'orange 'green) string -> void
; adds error to the error list for each label
; we use terms instead of labels as the key, because a primitive will have several labels
; associated with it (one created from the program text, and at least one created from the
; type for that primitive), so we need to use as key something unique about the primitive.
(define (error-table-set error-table labels gravity message)
(let ([assoc-set (error-table-assoc-set error-table)]
[error (make-sba-error labels gravity message)])
(for-each (lambda (label)
(let ([term (lab:label-term label)])
(if (syntax-position term)
(assoc-set-set
assoc-set
term
(cons error (assoc-set-get assoc-set term cst:thunk-empty))
#f)
(printf "~a error detected for term ~a: ~a~n"
gravity
(syntax-object->datum term)
message))))
labels)))
; error-table label -> (listof sba-error)
(define (error-table-get error-table label)
(assoc-set-get (error-table-assoc-set error-table) (lab:label-term label) cst:thunk-empty))
)

33
collects/mrflow/set-exn.ss
View File

@ -1,33 +0,0 @@
; exceptions for sets
; This file is required by both set-hash.ss and set-list.ss
; so we can't use contracts here because the sets are not always the same.
(module set-exn mzscheme
(provide
(struct exn:set:value-not-found (set value))
(struct exn:set:duplicate-value (set value))
exn:set
exn:set?
raise-value-not-found-exn
raise-duplicate-value-exn
)
(define-struct (exn:set exn) ())
(define-struct (exn:set:value-not-found exn:set) (set value))
(define-struct (exn:set:duplicate-value exn:set) (set value))
; string set value -> void
(define (raise-value-not-found-exn fct-name set value)
(raise (make-exn:set:value-not-found
(format "~a: value ~a not found in set ~a" fct-name value set)
(current-continuation-marks)
set value)))
; string set value -> void
(define (raise-duplicate-value-exn fct-name set value)
(raise (make-exn:set:duplicate-value
(format "~a: value ~a already in set ~a" fct-name value set)
(current-continuation-marks)
set value)))
)

255
collects/mrflow/set-hash.ss
View File

@ -1,255 +0,0 @@
; sets implementation, using hash tables.
; - value equality based on eq? by default, uses equal? if given the 'equal flag
; - raises exn:set:value-not-found if value not in set when trying
; to remove a value.
; - raise exn:set:duplicate-value by default when trying to add a value to a
; set where it already exists
; - strange things might happen if you use set-union, set-intersection,
; or set-difference with two sets that don't use the same comparaison
; function: you might end up with duplicate values in some sets.
(module set-hash (lib "mrflow.ss" "mrflow")
(require
mzlib/etc ; for opt-lambda
"set-exn.ss" ; no prefix so we can re-provide
)
; table = (hashtableof value value)
(define-struct set (cardinality table))
(provide/contract
(exn:set? (any/c . -> . boolean?))
(struct (exn:set:value-not-found exn:set) ((message (and/c string? immutable?))
(continuation-marks continuation-mark-set?)
(set set?)
(value any/c)))
(struct (exn:set:duplicate-value exn:set) ((message (and/c string? immutable?))
(continuation-marks continuation-mark-set?)
(set set?)
(value any/c)))
(set-make (() ((symbols 'equal)) . opt-> . set?))
(set-reset (set? . -> . set?))
(set? (any/c . -> . boolean?))
(set-set ((set? any/c) (boolean?) . opt-> . set?))
(set-in? (set? any/c . -> . boolean?))
(set-remove ((set? any/c) (boolean?) . opt-> . set?))
(set-cardinality (set? . -> . non-negative-exact-integer?))
(set-empty? (set? . -> . boolean?))
(set-copy (set? . -> . set?))
(set-map (set? (any/c . -> . any) . -> . (listof any/c)))
(set-fold (set? (any/c any/c . -> . any) any/c . -> . any))
(set-for-each (set? (any/c . -> . any) . -> . set?))
(set-for-each! (set? (any/c . -> . any) . -> . set?))
(set-filter ((set? (any/c . -> . boolean?)) ((symbols 'new 'same)) . opt-> . set?))
(set-union ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?))
(set-intersection ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?))
(set-difference ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?))
(set-subset? (set? set? . -> . boolean?))
)
; (opt 'equal) -> set
; we test the optional argument ourselves to preserve data abstraction even in the
; presence of an exception
(define set-make
(case-lambda
[() (make-set 0 (make-hash-table))]
[(flag) (make-set 0 (make-hash-table 'equal))]))
; set -> set
(define (set-reset set)
(set-set-table! set (make-hash-table))
(set-set-cardinality! set 0)
set)
; value -> boolean
; set? comes from the structure definition
; set value (opt boolean) -> set
(define set-set
(let ([dummy (gensym)])
(opt-lambda (set value (exn? #t))
(if (set-in? set value)
(when exn?
(raise-duplicate-value-exn "set-set" set value))
(begin
(set-set-cardinality! set (add1 (set-cardinality set)))
(hash-table-put! (set-table set) value dummy)))
set)))
; set value -> boolean
(define set-in?
(let* ([sym (gensym)]
[sym-thunk (lambda () sym)])
(lambda (set value)
(not (eq? sym (hash-table-get (set-table set) value sym-thunk))))))
; set value (opt boolean) -> set
(define set-remove
(opt-lambda (set value (exn? #t))
(if (set-in? set value)
(begin
(set-set-cardinality! set (sub1 (set-cardinality set)))
(hash-table-remove! (set-table set) value))
(when exn?
(raise-value-not-found-exn "set-remove" set value)))
set))
; set -> exact-non-negative-integer
; set-cardinality comes from the structure definition
; set -> boolean
(define (set-empty? set)
(= 0 (set-cardinality set)))
; set -> set
(define (set-copy set)
(let ([new-table (make-hash-table)])
(hash-table-for-each (set-table set)
(lambda (key value)
(hash-table-put! new-table key value)))
(make-set (set-cardinality set)
new-table)))
; set (value -> value) -> (listof value)
(define (set-map set f)
(let ([binary-f (lambda (value dummy)
(f value))])
(hash-table-map (set-table set) binary-f)))
; set (value value -> value) value -> value
(define (set-fold set f acc)
(let ([acc acc])
(hash-table-for-each (set-table set)
(lambda (value dummy)
(set! acc (f value acc))))
acc))
; set (value -> value) -> set
(define (set-for-each set f)
(let ([binary-f (lambda (value dummy)
(f value))])
(hash-table-for-each (set-table set) binary-f))
set)
; set (value -> value) -> set
; it's up to the user to make sure f is injective. Otherwise we might end up with
; a smaller set and the wrong cardinality.
(define (set-for-each! set f)
(let ([new-table (make-hash-table)])
(hash-table-for-each (set-table set)
(lambda (value dummy)
(hash-table-put! new-table (f value) dummy)))
(set-set-table! set new-table))
set)
; set (value -> boolean) (opt (union 'new 'same)) -> set
(define set-filter
(let (; set (value -> boolean) -> set
[filter-into-new-set
(lambda (set tester)
(let ([table (make-hash-table)]
[count 0])
(hash-table-for-each (set-table set)
(lambda (value dummy)
(when (tester value)
(hash-table-put! table value dummy)
(set! count (add1 count)))))
(make-set count table)))])
(opt-lambda (set tester (which-set 'new))
(let ([new-set (filter-into-new-set set tester)])
(case which-set
[(new) new-set]
[(same)
(set-set-table! set (set-table new-set))
(set-set-cardinality! set (set-cardinality new-set))
set])))))
; set set (opt (union 'new 'first 'second)) -> set
(define set-union
(let (; set set -> set
[union-second-set-into-first
(lambda (set1 set2)
(let ([table (set-table set1)]
[count (set-cardinality set1)])
(hash-table-for-each (set-table set2)
(lambda (value dummy)
(unless (set-in? set1 value)
(hash-table-put! table value dummy)
(set! count (add1 count)))))
(set-set-cardinality! set1 count))
set1)])
(opt-lambda (set1 set2 (which-set 'new))
(case which-set
[(new)
; copying is presumably faster than testing
(if (< (set-cardinality set1) (set-cardinality set2))
(union-second-set-into-first (set-copy set2) set1)
(union-second-set-into-first (set-copy set1) set2))]
[(first) (union-second-set-into-first set1 set2)]
[(second) (union-second-set-into-first set2 set1)]))))
; set set (opt (union 'new 'first 'second)) -> set
(define set-intersection
(let (; set set -> set
[intersect-into-new-set
(lambda (set1 set2)
(let ([table (make-hash-table)]
[count 0])
(hash-table-for-each (set-table set1)
(lambda (value dummy)
(when (set-in? set2 value)
(hash-table-put! table value dummy)
(set! count (add1 count)))))
(make-set count table)))])
(opt-lambda (set1 set2 (which-set 'new))
(let ([new-set
(if (< (set-cardinality set1) (set-cardinality set2))
(intersect-into-new-set set1 set2)
(intersect-into-new-set set2 set1))])
(case which-set
[(new) new-set]
[(first)
(set-set-table! set1 (set-table new-set))
(set-set-cardinality! set1 (set-cardinality new-set))
set1]
[(second)
(set-set-table! set2 (set-table new-set))
(set-set-cardinality! set2 (set-cardinality new-set))
set2])))))
; set set (opt (union 'new 'first 'second)) -> set
(define set-difference
(let (; set set -> set
[difference-into-new-set
(lambda (set1 set2)
(let ([table (make-hash-table)]
[count 0])
(hash-table-for-each (set-table set1)
(lambda (value dummy)
(unless (set-in? set2 value)
(hash-table-put! table value dummy)
(set! count (add1 count)))))
(make-set count table)))])
(opt-lambda (set1 set2 (which-set 'new))
(let ([new-set (difference-into-new-set set1 set2)])
(case which-set
[(new) new-set]
[(first)
(set-set-table! set1 (set-table new-set))
(set-set-cardinality! set1 (set-cardinality new-set))
set1]
[(second)
(set-set-table! set2 (set-table new-set))
(set-set-cardinality! set2 (set-cardinality new-set))
set2])))))
; set set -> boolean
(define (set-subset? set1 set2)
(let/ec k
(hash-table-for-each (set-table set1)
(lambda (value dummy)
(unless (set-in? set2 value)
(k #f))))
#t))
)

347
collects/mrflow/set-list.ss
View File

@ -1,347 +0,0 @@
; sets implementation, using lists.
; - value equality based on eq? by default, uses equal? if given the 'equal flag
; - raises exn:set:value-not-found if value not in set when trying
; to remove a value.
; - raise exn:set:duplicate-value by default when trying to add a value to a
; set where it already exists
; - strange things might happen if you use set-union, set-intersection,
; or set-difference with two sets that don't use the same comparaison
; function: you might end up with duplicate values in some sets.
;
; Note: lots of set! and tail-recursive loops in this code, for speed
(module set-list (lib "mrflow.ss" "mrflow")
(require
mzlib/list ; for foldr
mzlib/etc ; for opt-lambda
"set-exn.ss" ; no prefix so we can re-provide
)
; table = (listof (cons value value))
(define-struct set (=? cardinality table))
(provide/contract
(exn:set? (any/c . -> . boolean?))
(struct (exn:set:value-not-found exn:set) ((message (and/c string? immutable?))
(continuation-marks continuation-mark-set?)
(set set?)
(value any/c)))
(struct (exn:set:duplicate-value exn:set) ((message (and/c string? immutable?))
(continuation-marks continuation-mark-set?)
(set set?)
(value any/c)))
(set-make (() ((symbols 'equal)) . opt-> . set?))
(set-reset (set? . -> . set?))
(set? (any/c . -> . boolean?))
(set-set ((set? any/c) (boolean?) . opt-> . set?))
(set-in? (set? any/c . -> . boolean?))
(set-remove ((set? any/c) (boolean?) . opt-> . set?))
(set-cardinality (set? . -> . non-negative-exact-integer?))
(set-empty? (set? . -> . boolean?))
(set-copy (set? . -> . set?))
(set-map (set? (any/c . -> . any) . -> . (listof any/c)))
(set-fold (set? (any/c any/c . -> . any) any/c . -> . any))
(set-for-each (set? (any/c . -> . any) . -> . set?))
(set-for-each! (set? (any/c . -> . any) . -> . set?))
(set-filter ((set? (any/c . -> . boolean?)) ((symbols 'new 'same)) . opt-> . set?))
(set-union ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?))
(set-intersection ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?))
(set-difference ((set? set?) ((symbols 'new 'first 'second)) . opt-> . set?))
(set-subset? (set? set? . -> . boolean?))
)
; (opt 'equal) -> set
; we test the optional argument ourselves to preserve data abstraction even in the
; presence of an exception
(define set-make
(case-lambda
[() (make-set eq? 0 '())]
[(flag) (make-set equal? 0 '())]))
; set -> set
; doesn't change =?
(define (set-reset set)
(set-set-table! set '())
(set-set-cardinality! set 0)
set)
; value -> boolean
; set? comes from the structure definition
; set value (opt boolean) -> set
(define set-set
(opt-lambda (set value (exn? #t))
(let ([=? (set-=? set)]
[original-table (set-table set)])
(set-set-table! set (let loop ([table original-table])
(if (null? table)
(begin
(set-set-cardinality! set (add1 (set-cardinality set)))
(cons value original-table))
(if (=? (car table) value)
(if exn?
(raise-duplicate-value-exn "set-set" set value)
; silently ignore
original-table)
(loop (cdr table)))))))
set))
; set value -> boolean
(define (set-in? set value)
(let ([=? (set-=? set)])
(ormap (lambda (current-value)
(=? current-value value))
(set-table set))))
; set value (opt boolean) -> set
(define set-remove
(opt-lambda (set value (exn? #t))
(let ([=? (set-=? set)]
[original-table (set-table set)])
(set-set-table! set
(let loop ([table original-table]
[previous #f])
(if (null? table)
(if exn?
(raise-value-not-found-exn "set-remove" set value)
; silently ignore
original-table)
(if (=? (car table) value)
(begin
(set-set-cardinality! set (sub1 (set-cardinality set)))
(if previous
(begin
; return shortened table
(set-cdr! previous (cdr table))
original-table)
(cdr original-table)))
(loop (cdr table) table))))))
set))
; set -> exact-non-negative-integer
; set-cardinality comes from the structure definition
; set -> boolean
(define (set-empty? set)
(= 0 (set-cardinality set)))
; (listof value) (listof value) -> (listof value)
; creates a (reversed) copy of l1 (to prevent list sharing between sets) and prefixes l2 with it
(define (copy-reverse-and-prefix-lists l1 l2)
(let loop ([l1 l1]
[l2 l2])
(if (null? l1)
l2
(loop (cdr l1) (cons (car l1) l2)))))
; (listof value) -> (listof value)
(define (copy-list l)
(copy-reverse-and-prefix-lists l '()))
; set -> set
(define (set-copy set)
(make-set (set-=? set)
(set-cardinality set)
(copy-list (set-table set))))
; set (value -> value) -> (listof value)
(define (set-map set f)
(map f (set-table set)))
; set (value value -> value) value -> value
(define (set-fold set f acc)
(foldr f acc (set-table set)))
; set (value -> value) -> set
(define (set-for-each set f)
(for-each f (set-table set))
set)
; set (value -> value) -> set
; it's up to the user to make sure f is injective. Otherwise we might end up with
; duplicates in the set.
; we know lists are never shared between sets, so we can set-cdr!
(define (set-for-each! set f)
(let loop ([table (set-table set)])
(unless (null? table)
(set-car! table (f (car table)))
(loop (cdr table))))
set)
; set (value -> boolean) (opt (union 'new 'same)) -> set
(define set-filter
(let (; set (value -> boolean) -> set
[filter-into-new-set
(lambda (set tester)
(let loop ([table (set-table set)]
[new-table '()]
[count 0])
(if (null? table)
(make-set (set-=? set) count new-table)
(let ([value (car table)])
(if (tester value)
(loop (cdr table) (cons value new-table) (add1 count))
(loop (cdr table) new-table count))))))])
(opt-lambda (set tester (which-set 'new))
(let ([new-set (filter-into-new-set set tester)])
(case which-set
[(new) new-set]
[(same)
(set-set-table! set (set-table new-set))
(set-set-cardinality! set (set-cardinality new-set))
set])))))
; set set (opt (union 'new 'first 'second)) -> set
(define set-union
(opt-lambda (set1 set2 (which-set 'new))
(let* ([=? (set-=? set1)]
[new-set
(let loop ([table1 (set-table set1)]
; we shouldn't modify the original list
[table2 (copy-list (set-table set2))]
[count1 (set-cardinality set1)]
[count2 (set-cardinality set2)]
[acc '()]
[count 0])
(if (null? table1)
; we have already copied table2, so we can destructively modify it
(make-set =? (+ count count2)
(append! table2 acc))
(if (null? table2)
(make-set =? (+ count count1)
(copy-reverse-and-prefix-lists table1 acc))
(let ([value1 (car table1)])
; search table2 for same value
(let loop-set2 ([t2 table2]
[previous #f])
(if (null? t2)
(begin
(set! acc (cons value1 acc))
(set! count (add1 count))
(set! table1 (cdr table1))
(set! count1 (sub1 count1)))
(if (=? value1 (car t2))
(begin
(set! acc (cons value1 acc))
(set! count (add1 count))
(set! table1 (cdr table1))
(set! count1 (sub1 count1))
(if previous
(set-cdr! previous (cdr t2))
(set! table2 (cdr table2)))
(set! count2 (sub1 count2)))
(loop-set2 (cdr t2) t2))))
(loop table1 table2 count1 count2 acc count)))))])
(case which-set
[(new) new-set]
[(first)
(set-set-cardinality! set1 (set-cardinality new-set))
(set-set-table! set1 (set-table new-set))
set1]
[(second)
(set-set-cardinality! set2 (set-cardinality new-set))
(set-set-table! set2 (set-table new-set))
set2]))))
; set set (opt (union 'new 'first 'second)) -> set
(define set-intersection
(opt-lambda (set1 set2 (which-set 'new))
(let* ([=? (set-=? set1)]
[new-set
(let loop ([table1 (set-table set1)]
; we shouldn't modify the original list
[table2 (copy-list (set-table set2))]
[count1 (set-cardinality set1)]
[count2 (set-cardinality set2)]
[acc '()]
[count 0])
(if (null? table1)
(make-set =? count acc)
(if (null? table2)
(make-set =? count acc)
(let ([value1 (car table1)])
; search table2 for same value
(let loop-set2 ([t2 table2]
[previous #f])
(if (null? t2)
(begin
(set! table1 (cdr table1))
(set! count1 (sub1 count1)))
(if (=? value1 (car t2))
(begin
(set! acc (cons value1 acc))
(set! count (add1 count))
(set! table1 (cdr table1))
(set! count1 (sub1 count1))
(if previous
(set-cdr! previous (cdr t2))
(set! table2 (cdr table2)))
(set! count2 (sub1 count2)))
(loop-set2 (cdr t2) t2))))
(loop table1 table2 count1 count2 acc count)))))])
(case which-set
[(new) new-set]
[(first)
(set-set-cardinality! set1 (set-cardinality new-set))
(set-set-table! set1 (set-table new-set))
set1]
[(second)
(set-set-cardinality! set2 (set-cardinality new-set))
(set-set-table! set2 (set-table new-set))
set2]))))
; set set (opt (union 'new 'first 'second)) -> set
(define set-difference
(opt-lambda (set1 set2 (which-set 'new))
(let* ([=? (set-=? set1)]
[new-set
(let loop ([table1 (set-table set1)]
; we shouldn't modify the original list
[table2 (copy-list (set-table set2))]
[count1 (set-cardinality set1)]
[count2 (set-cardinality set2)]
[acc '()]
[count 0])
(if (null? table1)
(make-set =? count acc)
(if (null? table2)
(make-set =? (+ count count1)
(copy-reverse-and-prefix-lists table1 acc))
(let ([value1 (car table1)])
; search table2 for same value
(let loop-set2 ([t2 table2]
[previous #f])
(if (null? t2)
(begin
(set! acc (cons value1 acc))
(set! count (add1 count))
(set! table1 (cdr table1))
(set! count1 (sub1 count1)))
(if (=? value1 (car t2))
(begin
(set! table1 (cdr table1))
(set! count1 (sub1 count1))
(if previous
(set-cdr! previous (cdr t2))
(set! table2 (cdr table2)))
(set! count2 (sub1 count2)))
(loop-set2 (cdr t2) t2))))
(loop table1 table2 count1 count2 acc count)))))])
(case which-set
[(new) new-set]
[(first)
(set-set-cardinality! set1 (set-cardinality new-set))
(set-set-table! set1 (set-table new-set))
set1]
[(second)
(set-set-cardinality! set2 (set-cardinality new-set))
(set-set-table! set2 (set-table new-set))
set2]))))
; set set -> boolean
(define (set-subset? set1 set2)
(andmap (lambda (value)
(set-in? set2 value))
(set-table set1)))
)

842
collects/mrflow/snips-and-arrows-model.ss
View File

@ -1,842 +0,0 @@
; DrScheme starts counting positions at 0, MzScheme starts counting positions at 1.
; Syntax objects use MzScheme positions, all the positions in this file use DrScheme
; positions. In all cases positions are exact non-negative integer.
; Among DrScheme positions, some are so-called new positions "new-pos" and some are
; old positions "old-pos". An old position is a position in the editor before any snip
; was inserted. A new position is the same position in the editor, but after snips
; might have been inserted.
; (define-type position exact-non-negative-integer)
; DrScheme also has locations, which are real x and y coordinates in the editor.
; (define-type location real) these are not used here but are used in the view part.
;
; This whole module can only deal with snips that are on the left of the label (see
; new-pos->old-pos and old-pos->new-pos for example).
(module snips-and-arrows-model (lib "mrflow.ss" "mrflow")
(require
(prefix lst: mzlib/list)
(prefix cst: "constants.ss")
;"set-list.ss"
"set-hash.ss"
;"assoc-set-list.ss"
"assoc-set-hash.ss"
"labels.ss"
)
; DATA STRUCTURES
; label label boolean
(define-struct arrow (start-label end-label tacked? color))
; exact-non-negative-integer
(define-struct snip-group (size))
; We could recompute left-new-pos on the fly (from the MzScheme
; pos from the label itself and old-pos->new-pos) each time we needed to repaint,
; but in practice we repaint much more often then we add snips, so we keep the pos
; here as a cache which is computed once from scratch when we add the label to
; displayed-arrows and which is then just updated each time we add a new snip.
; Likewise, total-number-of-snips could be recomputed on the fly from snip-groups-by-type,
; but is used as a cache to speed up old-pos->new-pos and new-pos->old-pos, which are used
; pretty often.
; Note that the data structure for a single arrow will be shared between two
; label-gui-data structures: it will appear once in the "starting-arrows"
; set for its start label, and once in the "ending-arrows" set for its end label.
; We need this because we need to be able to click at the end of an arrow and
; remove it if necessary.
(define-struct label-gui-data (; position
left-new-pos
; exact-integer
span-change
; exact-non-negative-integer
total-number-of-snips
; (assoc-setof symbol snip-group)
snip-groups-by-type
; (setof arrow)
starting-arrows
; (setof arrow)
ending-arrows))
; Note that several labels might have a given position (due to macros) and we use a list
; instead of a set because we expect the sets to be very small (i.e. only one label is
; normally registered for a given position, maybe two or three if there are macros, so
; we do expect the list to be very short) but we expect a great number of them (i.e. we
; expect pretty much all terms in a program to be registered). Sets have an better asymptotic
; access time but onyl for big sets compared to lists, and they consumme much more memory than
; lists (since we usually use the hash-table-based implementation of sets), so using lists
; here for labels-by-mzscheme-position is probably the fastest and most memory efficient
; solution here given our assumptions.
(define-struct source-gui-data (; (assoc-setof label label-gui-data)
label-gui-data-by-label
; (assoc-setof non-negative-exact-integer (non-empty-listof label))
labels-by-mzscheme-position
; exact-non-negative-integer
total-number-of-snips))
(define-struct gui-model-state (; (assoc-setof source source-gui-data)
source-gui-data-by-source
; (label -> top)
get-source-from-label
; (label -> non-negative-exact-integer)
get-mzscheme-position-from-label
; (label -> non-negative-exact-integer)
get-original-span-from-label
; (label -> non-negative-exact-integer)
get-span-from-label
; (listof symbol)
snip-type-list
))
(provide/contract
(make-gui-model-state ((label? . -> . any)
(label? . -> . non-negative-exact-integer?)
(label? . -> . non-negative-exact-integer?)
(listof symbol?)
. -> . gui-model-state?))
(rename get-related-labels-from-drscheme-new-pos-and-source
get-related-labels-from-drscheme-pos-and-source
(gui-model-state? non-negative-exact-integer? any/c . -> . (listof label?)))
(rename gui-model-state-get-span-from-label
make-get-span-from-label-from-model-state
(gui-model-state? . -> . (label? . -> . non-negative-exact-integer?)))
(for-each-source (gui-model-state? (any/c . -> . void?) . -> . void?))
(register-source-with-gui (gui-model-state? any/c . -> . any))
(is-source-registered? (gui-model-state? any/c . -> . boolean?))
(register-label-with-gui (gui-model-state? label? . -> . any))
(get-position-from-label (gui-model-state? label? . -> . non-negative-exact-integer?))
(user-change-terms (gui-model-state?
(listof label?)
any/c
non-negative-exact-integer?
. -> . (values non-negative-exact-integer? non-negative-exact-integer?)))
(for-each-label-in-source (gui-model-state? any/c (label? . -> . void?) . -> . void?))
(add-arrow (gui-model-state? (list/c label? label? string?) boolean? . -> . void?))
(remove-arrows (gui-model-state? label? (or/c symbol? boolean?) boolean? . -> . void?))
(remove-all-arrows (gui-model-state? . -> . void?))
(for-each-arrow (gui-model-state? (non-negative-exact-integer? non-negative-exact-integer? non-negative-exact-integer? non-negative-exact-integer? any/c any/c boolean? string? . -> . void?) . -> . void?))
(get-tacked-arrows-from-label (gui-model-state? label? . -> . non-negative-exact-integer?))
(for-each-snip-type (gui-model-state? (symbol? . -> . void?) . -> . void?))
(label-has-snips-of-this-type? (gui-model-state? label? symbol? . -> . boolean?))
(snips-currently-displayed-in-source? (gui-model-state? any/c . -> . boolean?))
(add-snips (gui-model-state? label? symbol? any/c non-negative-exact-integer? . -> . non-negative-exact-integer?))
(remove-inserted-snips (gui-model-state? label? symbol? any/c . -> . (values non-negative-exact-integer? non-negative-exact-integer?)))
)
; (label -> top)
; (label -> non-negative-exact-integer)
; (label -> non-negative-exact-integer)
; (listof symbol)
; -> gui-model-state
(set! make-gui-model-state
(let ([real-make-gui-model-state make-gui-model-state])
(lambda (get-source-from-label
get-mzscheme-position-from-label
get-span-from-label
snip-type-list)
(let ([source-gui-data-by-source (assoc-set-make)])
(real-make-gui-model-state
source-gui-data-by-source
get-source-from-label
get-mzscheme-position-from-label
get-span-from-label
(lambda (label)
(let* ([span (get-span-from-label label)]
[source-gui-data
(assoc-set-get source-gui-data-by-source (get-source-from-label label))]
[label-gui-data
(assoc-set-get (source-gui-data-label-gui-data-by-label source-gui-data)
label cst:thunk-false)])
(if label-gui-data
(+ span (label-gui-data-span-change label-gui-data))
span)))
snip-type-list)))))
; DRSCHEME / MZSCHEME CONVERSIONS
; non-negative-exact-integer -> non-negative-exact-integer
(define drscheme-pos->mzscheme-pos add1)
; non-negative-exact-integer -> non-negative-exact-integer
(define mzscheme-pos->drscheme-pos sub1)
; SOURCES
; gui-model-state top -> top
(define (register-source-with-gui gui-model-state source)
(assoc-set-set (gui-model-state-source-gui-data-by-source gui-model-state)
source
(make-source-gui-data (assoc-set-make)
(assoc-set-make)
0))
source)
; gui-model-state top -> boolean
(define (is-source-registered? gui-model-state source)
(assoc-set-in? (gui-model-state-source-gui-data-by-source gui-model-state) source))
; gui-model-state (top -> void) -> void
; applies f to each source
(define (for-each-source gui-model-state f)
(assoc-set-for-each (gui-model-state-source-gui-data-by-source gui-model-state)
(lambda (source source-gui-data)
(f source)))
cst:void)
; gui-model-state top -> boolean
; are we currently displaying some snips in the source?
(define (snips-currently-displayed-in-source? gui-model-state source)
(let ([source-gui-data
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
source cst:thunk-false)])
(if source-gui-data
(< 0 (source-gui-data-total-number-of-snips source-gui-data))
#f)))
; LABELS
; gui-model-state label -> exact-non-negative-integer
; returns the left position of the expression. The computation is done from scratch,
; so only use this function if the position hasn't been yet cached in the label's gui data.
(define (get-new-pos-from-label gui-model-state label)
(old-pos->new-pos
gui-model-state
(mzscheme-pos->drscheme-pos
((gui-model-state-get-mzscheme-position-from-label gui-model-state) label))
((gui-model-state-get-source-from-label gui-model-state) label)))
; gui-model-state label -> exact-non-negative-integer
; returns the left position of the expression represented by the label
(define (get-position-from-label gui-model-state label)
(let* ([source ((gui-model-state-get-source-from-label gui-model-state) label)]
[source-gui-data
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) source)]
[label-gui-data-by-label
(source-gui-data-label-gui-data-by-label source-gui-data)]
[label-gui-data
(assoc-set-get label-gui-data-by-label label cst:thunk-false)])
(if label-gui-data
(label-gui-data-left-new-pos label-gui-data)
(get-new-pos-from-label gui-model-state label))))
; gui-model-state label -> (or/c top #f)
; we register the source of the label and the label by its position,
; but we don't associate any label-gui-data with it yet, to save memory.
; We'll associate some label-gui-data with it on the fly, as needed (when
; needing to remember some arrows or snips for that label, not before).
; We return the source only the first time a label is registered for it
; (the view part uses this to initialize the state of the source).
(define (register-label-with-gui gui-model-state label)
(let* ([source-gui-data-by-source
(gui-model-state-source-gui-data-by-source gui-model-state)]
[source
((gui-model-state-get-source-from-label gui-model-state) label)]
[source-gui-data
(assoc-set-get source-gui-data-by-source source cst:thunk-false)]
[mzscheme-pos
((gui-model-state-get-mzscheme-position-from-label gui-model-state) label)])
(if source-gui-data
(let ([labels-by-mzscheme-position
(source-gui-data-labels-by-mzscheme-position source-gui-data)])
; So, in the good old days I used to check whether a given label was already registered
; for the given position, and gave an error when such was the case. But macros can
; duplicate terms, so in the good not-so-old days I added a test such that an error
; would show up only if the labels didn't represent the same original term. But Matthew
; then told me that a given term that's duplicated by a macro might be represented by
; two syntax objects that are not eq?. So at that point I had the choice between
; converting the two syntax-objects into sexprs and using equal? to check whether
; they actually represented the same term (and that would have been only a heurisitc,
; since it would not have detected bugs in a macro that gave the same position to
; two identical source terms), or what I do now: just register all the labels no
; matter what. This solution also means I don't have to have a get-term-from-label
; function in my interface.
; Note that we still make sure the exact same label is not already registered with
; the gui, otherwise we'll try to add the same arrows twice which will lead to error
; messages in add-one-arrow-end
(let ([currently-registered-labels-for-this-position
(assoc-set-get labels-by-mzscheme-position
mzscheme-pos
cst:thunk-empty)])
(unless (memq label currently-registered-labels-for-this-position)
(assoc-set-set labels-by-mzscheme-position
mzscheme-pos
(cons label currently-registered-labels-for-this-position)
#f))
#f))
(begin
; source unknown: register it and try again
(register-source-with-gui gui-model-state source)
(register-label-with-gui gui-model-state label)
source))))
; gui-model-state (listof label) text% exact-integer -> (values non-negative-exact-integer non-negative-exact-integer)
; Modify the span of the labels and move snips on the right, returning the interval
; that has to be deleted and the new interval that has to be colored (for a total of
; three numbers, since both intervals start at the same position)
; We know from saav:user-change-terms that all the labels represent the same term
(define (user-change-terms gui-model-state labels source new-span)
(let* ([source-gui-data-by-source (gui-model-state-source-gui-data-by-source gui-model-state)]
[source-gui-data (assoc-set-get source-gui-data-by-source source)]
[label-gui-data-by-label (source-gui-data-label-gui-data-by-label source-gui-data)]
[label (car labels)]
[old-span ((gui-model-state-get-span-from-label gui-model-state) label)]
[change (- new-span old-span)]
[left-new-pos (get-position-from-label gui-model-state label)])
(for-each
(lambda (label)
(let ([label-gui-data (assoc-set-get label-gui-data-by-label label cst:thunk-false)])
(if label-gui-data
(set-label-gui-data-span-change!
label-gui-data
(+ change (label-gui-data-span-change label-gui-data)))
(assoc-set-set label-gui-data-by-label
label
(make-label-gui-data left-new-pos
change
0
(assoc-set-make)
(set-make)
(set-make))))))
labels)
(move-poss gui-model-state source left-new-pos change + >)
(values (+ left-new-pos old-span) (+ left-new-pos new-span))))
; gui-model-state top (label -> void) -> void
; apply f to all registered labels
(define (for-each-label-in-source gui-model-state source f)
(let ([source-gui-data
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) source)])
(when source-gui-data
(assoc-set-for-each
(source-gui-data-labels-by-mzscheme-position source-gui-data)
(lambda (mzscheme-pos labels)
(for-each f labels)))))
cst:void)
; POS AND SOURCE TO LABEL CONVERSIONS
; gui-model-state non-negative-exact-integer top -> (listof label)
; finds the labels corresponding to a given new-pos in a given source
(define (get-related-labels-from-drscheme-new-pos-and-source gui-model-state new-pos source)
(get-related-labels-from-drscheme-old-pos-and-source
gui-model-state
(new-pos->old-pos gui-model-state new-pos source)
source))
; gui-model-state non-negative-exact-integer top -> (listof label)
; we loop down starting from old-pos, until we find a label. Then we have to check
; that the original old-pos falls within the original span of that label.
(define (get-related-labels-from-drscheme-old-pos-and-source gui-model-state old-pos source)
(let ([get-original-span-from-label
(gui-model-state-get-original-span-from-label gui-model-state)]
[source-gui-data
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
source cst:thunk-false)])
(if source-gui-data
(let ([labels-by-mzscheme-position (source-gui-data-labels-by-mzscheme-position source-gui-data)]
[starting-mzscheme-pos (drscheme-pos->mzscheme-pos old-pos)])
(let loop ([current-mzscheme-pos starting-mzscheme-pos])
(if (> 0 current-mzscheme-pos)
'()
(let ([labels (assoc-set-get labels-by-mzscheme-position current-mzscheme-pos cst:thunk-false)])
(if labels
; Note that if the label's span is too small, we stop looping.
; This means that in an expression like (abc def), if the mouse
; pointer points at the space character, #f will be returned,
; not the label for the whole expression.
(let ([mouse-distance (- starting-mzscheme-pos current-mzscheme-pos)])
(lst:filter (lambda (label)
(< mouse-distance (get-original-span-from-label label)))
labels))
(loop (sub1 current-mzscheme-pos)))))))
'())))
; OLD-POS / NEW-POS CONVERSIONS
; gui-model-state exact-non-negative-integer top -> exact-non-negative-integer
; converts an old position (before insertion of any snip) to a new position
; (after insertion of all the currently inserted snips).
; Note: the test is "<=", which means the new position is to the right of all
; the current snips that have positions corresponding to the same old position
; (i.e. to the right of all the snips that have already been inserted for that label).
(define (old-pos->new-pos gui-model-state old-pos source)
(let ([new-pos old-pos]
[get-mzscheme-position-from-label
(gui-model-state-get-mzscheme-position-from-label gui-model-state)]
[get-original-span-from-label
(gui-model-state-get-original-span-from-label gui-model-state)]
[get-span-from-label
(gui-model-state-get-span-from-label gui-model-state)]
[source-gui-data
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
source cst:thunk-false)])
(when source-gui-data
(assoc-set-for-each
(source-gui-data-label-gui-data-by-label source-gui-data)
(lambda (label label-gui-data)
(let ([label-left-old-pos (mzscheme-pos->drscheme-pos (get-mzscheme-position-from-label label))])
(cond
; the order of the clauses is important here
; old-pos is on the right of the original expression represented by the label
[(<= (+ label-left-old-pos (get-original-span-from-label label)) old-pos)
(set! new-pos (+ new-pos
(label-gui-data-span-change label-gui-data)
(label-gui-data-total-number-of-snips label-gui-data)))]
; old-pos is somewhere in the middle of the expression represented by the label
; then we have to take care of the case when the current expression is smaller than
; the original expression (because an identifier was changed)
[(<= label-left-old-pos old-pos)
(if (<= (+ label-left-old-pos (get-span-from-label label)) old-pos)
; expression has shrinked, and old-pos was in the part that disappeared,
; so we make sure the new-pos is at least within the current expression
; by acting as if old-pos were label-left-old-pos (i.e. moving old-pos
; to the left end of the expression). Note that this makes old-pos->new-pos
; not bijective anymore.
(set! new-pos (+ new-pos
(- label-left-old-pos old-pos)
(label-gui-data-total-number-of-snips label-gui-data)))
; either expression has not shrinked, or if it has, old-pos is sufficiently
; in the left part that we don't have to worry about it
(set! new-pos (+ new-pos
(label-gui-data-total-number-of-snips label-gui-data))))]
; old-pos is on the left of the expression => do nothing
)))))
new-pos))
; gui-model-state exact-non-negative-integer top -> exact-non-negative-integer
; Note: the test is "<", because there might a snip that has the exact same
; position as new-pos, so, since a snip at position n is shown graphically
; between position n and n+1, we don't want to take that snip into account
; (i.e. that snip is on the right of the cursor or mouse pointer, not on the
; left).
; Note also that we have to be carefull: in old-pos->new-pos we add all the snips
; to the new-pos when the label has an old-pos to the left of or at the cursor.
; But here the cursor might be between two snips. So we have to consider each snip
; separately, we can't consider them group by group anymore.
(define (new-pos->old-pos gui-model-state new-pos source)
(let ([old-pos new-pos]
[get-original-span-from-label
(gui-model-state-get-original-span-from-label gui-model-state)]
[get-span-from-label
(gui-model-state-get-span-from-label gui-model-state)]
[source-gui-data
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
source cst:thunk-false)])
(when source-gui-data
(assoc-set-for-each
(source-gui-data-label-gui-data-by-label source-gui-data)
(lambda (label label-gui-data)
(let ([label-left-new-pos (label-gui-data-left-new-pos label-gui-data)]
[total-number-of-snips (label-gui-data-total-number-of-snips label-gui-data)])
(cond
; the order of the clauses is important here
; new-pos is on the right of the expression represented by the label
[(<= (+ label-left-new-pos (get-span-from-label label)) new-pos)
(set! old-pos (- old-pos
(label-gui-data-span-change label-gui-data)
(label-gui-data-total-number-of-snips label-gui-data)))]
; new-pos is somewhere in the middle of the expression represented by the label
; then we have to take care of the case when the current expression is bigger than
; the original expression (because an identifier was changed)
[(<= label-left-new-pos new-pos)
(if (<= (+ label-left-new-pos (get-original-span-from-label label)) new-pos)
; expression has expanded, and new-pos was in the part that was added,
; so we make sure the old-pos is at least within the current expression
; by acting as if new-pos were label-left-new-pos (i.e. moving new-pos
; to the left end of the expression). Note that this makes new-pos->old-pos
; not bijective anymore.
(set! old-pos (- old-pos
(- new-pos label-left-new-pos)
(label-gui-data-total-number-of-snips label-gui-data)))
; either expression has not expanded, or if it has, new-pos is sufficiently
; in the left part that we don't have to worry about it
(set! old-pos (- old-pos
(label-gui-data-total-number-of-snips label-gui-data))))]
; new-pos is on the left of the expression but in the middle of the snips
; at that point we could either loop over the snips groups one by one and test
; them using their left-new-pos, or we can directly compute the total number of
; snips on the left of new-pos using the label's left-new-pos and
; total-number-of-snips. Since the second method is easier, we do it that way.
[(<= (- label-left-new-pos total-number-of-snips) new-pos)
(set! old-pos (- old-pos
(- total-number-of-snips (- label-left-new-pos new-pos))))]
; new-pos is on the left of the expression and the snips => do nothing
)))))
old-pos))
; gui-model-state top exact-non-negative-integer exact-integer
; (exact-non-negative-integer exact-integer -> exact-integer)
; (exact-non-negative-integer exact-integer -> boolean) -> void
; moves all snips and arrows that are after start, by len. start is a new position (i.e. after
; insertion of snips). We need to do all that so that old-pos->new-pos and new-pos->old-pos
; and the arrow display keep working correctly when we add new snips in the middle of others.
(define (move-poss gui-model-state source start len add comp)
(let ([move-pos (lambda (pos) (if (comp pos start) (add pos len) pos))]
[source-gui-data
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) source)])
(assoc-set-for-each
(source-gui-data-label-gui-data-by-label source-gui-data)
(lambda (label label-gui-data)
(set-label-gui-data-left-new-pos!
label-gui-data (move-pos (label-gui-data-left-new-pos label-gui-data))))))
cst:void)
; ARROWS
; gui-model-state (list label label string) boolean -> void
; add one arrow going from start-label to end-label, duh.
(define (add-arrow gui-model-state arrow-info tacked?)
(let* ([start-label (car arrow-info)]
[end-label (cadr arrow-info)]
[new-arrow (make-arrow start-label end-label tacked? (caddr arrow-info))])
(add-one-arrow-end gui-model-state
new-arrow
start-label
end-label
arrow-end-label
label-gui-data-starting-arrows
(lambda () (set-set (set-make) new-arrow))
set-make)
(add-one-arrow-end gui-model-state
new-arrow
end-label
start-label
arrow-start-label
label-gui-data-ending-arrows
set-make
(lambda () (set-set (set-make) new-arrow)))))
; gui-model-state arrow label label (arrow -> label) (label-gui-data -> (setof arrow)
; (-> (setof arrow)) (-> (setof arrow)) -> void
; adds arrow structure to the label's gui data, for one end of the arrow
(define (add-one-arrow-end gui-model-state new-arrow this-end-label other-end-label
arrow-other-end-label-selector label-gui-data-this-end-arrow-set-selector
make-starting-arrow-set make-ending-arrow-set)
(let* ([this-end-source
((gui-model-state-get-source-from-label gui-model-state) this-end-label)]
[this-end-source-gui-data
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state) this-end-source)]
[this-end-label-gui-data-by-label
(source-gui-data-label-gui-data-by-label this-end-source-gui-data)]
[this-end-label-gui-data
(assoc-set-get this-end-label-gui-data-by-label this-end-label cst:thunk-false)])
(if this-end-label-gui-data
(let* ([this-end-arrow-set
(label-gui-data-this-end-arrow-set-selector this-end-label-gui-data)]
[same-arrow-set (set-filter this-end-arrow-set
(lambda (arrow)
(eq? other-end-label
(arrow-other-end-label-selector arrow))))])
(if (set-empty? same-arrow-set)
; the arrow doesn't already exist, so add the arrow to the start set
(set-set this-end-arrow-set new-arrow)
; the arrow already exists
(let* ([new-arrow-tacked? (arrow-tacked? new-arrow)]
[old-arrow (if (= (set-cardinality same-arrow-set) 1)
(car (set-map same-arrow-set cst:id))
(error 'add-one-arrow-end "duplicate arrows"))]
[old-arrow-tacked? (arrow-tacked? old-arrow)])
(if new-arrow-tacked?
(if old-arrow-tacked?
(error 'add-one-arrow-end "tacked arrow already exists")
(error 'add-one-arrow-end "can't tack arrow over untacked one"))
(if old-arrow-tacked?
cst:void ; happens when moving mouse over label with tacked arrows
(error 'add-one-arrow-end "untacked arrow already exists"))))))
(assoc-set-set this-end-label-gui-data-by-label
this-end-label
(make-label-gui-data (get-new-pos-from-label gui-model-state this-end-label)
0
0
(assoc-set-make)
(make-starting-arrow-set)
(make-ending-arrow-set)))))
cst:void)
; gui-model-state label (or/c symbol boolean) boolean -> void
; remove arrows starting at given label AND arrows ending at same given label
; Note that assoc-set-get will fail if we try to remove non-existant arrows...
(define (remove-arrows gui-model-state start-label tacked? exn?)
(let* ([source-gui-data-by-source
(gui-model-state-source-gui-data-by-source gui-model-state)]
[get-source-from-label (gui-model-state-get-source-from-label gui-model-state)]
[source (get-source-from-label start-label)]
[source-gui-data (assoc-set-get source-gui-data-by-source source)]
[label-gui-data-by-label
(source-gui-data-label-gui-data-by-label source-gui-data)]
[start-label-gui-data
(if exn?
(assoc-set-get label-gui-data-by-label start-label)
(assoc-set-get label-gui-data-by-label start-label cst:thunk-false))])
; at this point, if the key was not found, either exn? was true and an exception
; was raised, or it was false and start-label-gui-data is false
(when start-label-gui-data
(remove-both-ends source-gui-data-by-source
(label-gui-data-starting-arrows start-label-gui-data)
tacked?
arrow-end-label
label-gui-data-ending-arrows
get-source-from-label)
(remove-both-ends source-gui-data-by-source
(label-gui-data-ending-arrows start-label-gui-data)
tacked?
arrow-start-label
label-gui-data-starting-arrows
get-source-from-label)))
cst:void)
; (assoc-setof top source-gui-data) (setof arrow) (or/c symbol boolean)
; (arrow -> label) (label-gui-data -> (setof arrow))
; (label -> top)
; -> (setof arrow)
; remove arrows starting at given label OR arrows ending at given
; label (depending on selectors/settors)
; the result is thrown away by the caller...
(define (remove-both-ends source-gui-data-by-source set tacked?
arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector
get-source-from-label)
(if (eq? tacked? 'all)
; remove all the other ends and reset this end
; we could do without this case and use the set-filter way used in the "else" case
; of this if, but doing it that way here is faster because we don't bother testing
; and removing each arrow from the set one by one, we just reset the whole thing.
(begin
(set-for-each set (lambda (arrow)
(remove-other-end source-gui-data-by-source arrow
arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector
get-source-from-label)))
(set-reset set))
; remove other end while filtering this set
(set-filter set
(lambda (arrow)
(if (eq? tacked? (arrow-tacked? arrow))
(begin
(remove-other-end source-gui-data-by-source arrow
arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector
get-source-from-label)
#f)
#t))
'same)))
; (assoc-setof top source-gui-data) arrow (arrow -> label) (label-gui-data -> (setof arrow))
; (label -> top) -> (setof arrow)
; removes one arrow structure reference corresponding to the remote end of the arrow we
; are removing in remove-both-ends above. We know the arrow is there, so no need to test
; whether label-gui-data-by-source-and-label and label-gui-data-by-label are false or not.
; the result is thrown away by the caller...
(define (remove-other-end source-gui-data-by-source arrow
arrow-other-end-label-selector label-gui-data-other-end-arrow-set-selector
get-source-from-label)
(let* ([other-end-label (arrow-other-end-label-selector arrow)]
[other-end-source (get-source-from-label other-end-label)]
[other-end-source-gui-data
(assoc-set-get source-gui-data-by-source other-end-source)]
[other-end-label-gui-data
(assoc-set-get (source-gui-data-label-gui-data-by-label other-end-source-gui-data)
other-end-label)]
[other-end-arrow-set (label-gui-data-other-end-arrow-set-selector other-end-label-gui-data)])
(set-remove other-end-arrow-set arrow)))
; gui-model-state -> void
; remove all arrows in all sources
; This is faster than looping over each source and then each label in each source and
; then removing each arrow one by one for each label using remove-arrows.
(define (remove-all-arrows gui-model-state)
(let ([source-gui-data-by-source (gui-model-state-source-gui-data-by-source gui-model-state)])
(assoc-set-for-each
source-gui-data-by-source
(lambda (source source-gui-data)
(assoc-set-for-each
(source-gui-data-label-gui-data-by-label source-gui-data)
(lambda (label label-gui-data)
(set-reset (label-gui-data-starting-arrows label-gui-data))
(set-reset (label-gui-data-ending-arrows label-gui-data)))))))
cst:void)
; gui-model-state
; (non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer top top boolean string -> void)
; -> void
; applies f to each arrow. The args for f are: the left new-pos of the start label, the
; left new-pos of the end label, the corresponding spans, the start and end sources,
; whether the arrow is tacked or not, and the color.
(define (for-each-arrow gui-model-state f)
(let ([get-span-from-label (gui-model-state-get-span-from-label gui-model-state)]
[get-source-from-label (gui-model-state-get-source-from-label gui-model-state)]
[source-gui-data-by-source (gui-model-state-source-gui-data-by-source gui-model-state)])
(assoc-set-for-each
source-gui-data-by-source
(lambda (start-source start-source-gui-data)
(let ([label-gui-data-by-label (source-gui-data-label-gui-data-by-label start-source-gui-data)])
(assoc-set-for-each
label-gui-data-by-label
(lambda (start-label start-label-gui-data)
(set-for-each (label-gui-data-starting-arrows start-label-gui-data)
(lambda (arrow)
(let* ([end-label (arrow-end-label arrow)]
[end-source (get-source-from-label end-label)]
[end-source-gui-data ; the arrow exists, so this is not #f
(assoc-set-get source-gui-data-by-source end-source)]
[end-label-gui-data-by-label
(source-gui-data-label-gui-data-by-label end-source-gui-data)]
[end-label-gui-data
(assoc-set-get end-label-gui-data-by-label end-label)])
(f (label-gui-data-left-new-pos start-label-gui-data)
(label-gui-data-left-new-pos end-label-gui-data)
(get-span-from-label start-label)
(get-span-from-label end-label)
start-source
end-source
(arrow-tacked? arrow)
(arrow-color arrow)))))))))))
cst:void)
; (gui-model-state label -> non-negative-exact-integer)
; counts how many arrows starting or ending at a given label are tacked
(define (get-tacked-arrows-from-label gui-model-state label)
(let ([source-gui-data
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
((gui-model-state-get-source-from-label gui-model-state) label)
cst:thunk-false)])
(if source-gui-data
(let* ([label-gui-data-by-label (source-gui-data-label-gui-data-by-label source-gui-data)]
[label-gui-data (assoc-set-get label-gui-data-by-label label cst:thunk-false)])
(if label-gui-data
(+ (set-cardinality (set-filter (label-gui-data-starting-arrows label-gui-data) arrow-tacked?))
(set-cardinality (set-filter (label-gui-data-ending-arrows label-gui-data) arrow-tacked?)))
0))
0)))
; SNIPS
; gui-model-state (symbol -> void) -> void
; applies f to each type of snips (not the snips themselves, just the types).
(define (for-each-snip-type gui-model-state f)
(for-each f (gui-model-state-snip-type-list gui-model-state)))
; gui-model-state label symbol -> boolean
; does the label have snips of a given type currently displayed by the gui?
(define (label-has-snips-of-this-type? gui-model-state label type)
(let ([source-gui-data
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
((gui-model-state-get-source-from-label gui-model-state) label)
cst:thunk-false)])
(if source-gui-data
(let ([label-gui-data
(assoc-set-get (source-gui-data-label-gui-data-by-label source-gui-data)
label cst:thunk-false)])
(if label-gui-data
(assoc-set-in? (label-gui-data-snip-groups-by-type label-gui-data) type)
#f))
#f)))
; (assoc-setof symbol snip-group) symbol (listof symbol) -> non-negative-exact-integer
; counts how many snips are currently displayed on the right of the position where
; the snips of the given type currently are or would be displayed
(define (get-number-of-snips-on-right-from-type snip-groups-by-type type snip-type-list)
(let ([snip-types-on-right
(let ([types (memq type snip-type-list)])
(if types
types
(error 'get-number-of-snips-on-right-from-type
"unknown snip type: ~a" type)))])
(let loop ([snip-types-on-right (cdr snip-types-on-right)]
[number-of-snips-on-right 0])
(if (null? snip-types-on-right)
number-of-snips-on-right
(loop (cdr snip-types-on-right)
(+ number-of-snips-on-right
(let ([snip-group (assoc-set-get snip-groups-by-type (car snip-types-on-right) cst:thunk-false)])
(if snip-group
(snip-group-size snip-group)
0))))))))
; gui-model-state label symbol top non-negative-exact-integer -> non-negative-exact-integer
; updates state (move existing snips and add new ones) and returns the position where
; the snips should be inserted in the text
(define (add-snips gui-model-state label type source number-of-snips)
(let* ([source-gui-data
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
source cst:thunk-false)]
[label-gui-data-by-label (source-gui-data-label-gui-data-by-label source-gui-data)]
[label-gui-data (assoc-set-get label-gui-data-by-label label cst:thunk-false)])
(set-source-gui-data-total-number-of-snips!
source-gui-data (+ (source-gui-data-total-number-of-snips source-gui-data) number-of-snips))
(if label-gui-data
; the label might already have some snips attached to it.
(let* ([snip-groups-by-type (label-gui-data-snip-groups-by-type label-gui-data)]
[label-starting-pos (label-gui-data-left-new-pos label-gui-data)]
[insertion-starting-pos
(- label-starting-pos
(get-number-of-snips-on-right-from-type
snip-groups-by-type type (gui-model-state-snip-type-list gui-model-state)))])
(move-poss gui-model-state source insertion-starting-pos number-of-snips + >=)
(if (assoc-set-in? snip-groups-by-type type)
; type already present, but, for a given label and type, we can have only one
; group of snips
(error 'add-snips gui-model-state
"snips-and-arrows internal error; label ~a has already a snip group of type ~a"
label type)
; new snip type for this label
(begin
(assoc-set-set snip-groups-by-type type (make-snip-group number-of-snips))
(set-label-gui-data-total-number-of-snips!
label-gui-data
(+ (label-gui-data-total-number-of-snips label-gui-data) number-of-snips))))
insertion-starting-pos)
; create new label-gui-data for that label
(let ([label-starting-pos (get-new-pos-from-label gui-model-state label)])
(move-poss gui-model-state source label-starting-pos number-of-snips + >=)
(assoc-set-set label-gui-data-by-label
label
(make-label-gui-data (+ label-starting-pos number-of-snips)
0
number-of-snips
(assoc-set-set (assoc-set-make)
type
(make-snip-group number-of-snips))
(set-make)
(set-make)))
label-starting-pos))))
; gui-model-state label symbol top -> (value non-negative-exact-integer non-negative-exact-integer)
; removes all snips for a given label and type, move remaining snips, and returns the interval
; to delete in the editor
(define (remove-inserted-snips gui-model-state label type source)
(let* ([source-gui-data
(assoc-set-get (gui-model-state-source-gui-data-by-source gui-model-state)
source cst:thunk-false)]
[label-gui-data
(assoc-set-get (source-gui-data-label-gui-data-by-label source-gui-data)
label cst:thunk-false)])
(if label-gui-data
(let* ([snip-groups-by-type (label-gui-data-snip-groups-by-type label-gui-data)]
[snip-group (assoc-set-get snip-groups-by-type type cst:thunk-false)])
(if snip-group
(let* ([size (snip-group-size snip-group)]
[label-starting-pos (label-gui-data-left-new-pos label-gui-data)]
[deletion-ending-pos
(- label-starting-pos
(get-number-of-snips-on-right-from-type
snip-groups-by-type type (gui-model-state-snip-type-list gui-model-state)))])
(assoc-set-remove snip-groups-by-type type)
(move-poss gui-model-state source deletion-ending-pos size - >=)
(set-label-gui-data-total-number-of-snips!
label-gui-data
(- (label-gui-data-total-number-of-snips label-gui-data)
size))
(set-source-gui-data-total-number-of-snips!
source-gui-data
(- (source-gui-data-total-number-of-snips source-gui-data)
size))
(values (- deletion-ending-pos size) deletion-ending-pos))
(error 'remove-inserted-snips
"label ~a has no snip group of type ~a"
label type)))
(error 'remove-inserted-snips
"label ~a has no snip groups at all, let alone of type ~a"
label type))))
)

588
collects/mrflow/snips-and-arrows-view.ss
View File

@ -1,588 +0,0 @@
(module snips-and-arrows-view (lib "mrflow.ss" "mrflow")
(require
mzlib/class
mred
(prefix arrow: (lib "arrow.ss" "drscheme"))
(only mzlib/list sort)
(prefix strcst: string-constants)
(prefix cst: "constants.ss")
(prefix saam: "snips-and-arrows-model.ss")
;"set-list.ss"
"set-hash.ss"
;"assoc-set-list.ss"
"assoc-set-hash.ss"
"labels.ss"
)
(define-struct gui-view-state (; gui-model-state
gui-model-state
; test%
top-editor
; (label -> text%)
get-editor-from-label
; boolean
; so we can differenciate between actions done by the analysis and actions
; done by the user. Also prevents an infinite loop when deleting: if the user
; deletes something, it triggers a call to after-delete, which deletes all the
; snips, which triggers calls to after-delete, etc... so after-delete needs to
; be wrapped to prevent an infinite loop.
analysis-currently-modifying?
; (symbol label -> (listof string))
get-snip-text-from-snip-type-and-label
; (label -> style-delta%)
get-style-delta-from-label
; (listof (cons symbol style-delta%))
snip-types-and-colors
; boolean
clear-colors-immediately?
))
(provide/contract
(make-gui-view-state (text%?
(label? . -> . text%?)
(label? . -> . non-negative-exact-integer?)
(label? . -> . non-negative-exact-integer?)
(symbol? label? . -> . (listof string?))
(label? . -> . style-delta%?)
(listof (cons/c symbol? string?))
boolean?
. -> . gui-view-state?))
(rename gui-view-state-analysis-currently-modifying?
analysis-currently-modifying?
(gui-view-state? . -> . boolean?))
(color-registered-labels (gui-view-state? (box/c (listof text%?)) . -> . void?))
(after-user-action (gui-view-state? . -> . void?))
(register-label-with-gui (gui-view-state? label? (text%? . -> . void?) . -> . void?))
(register-editor-with-gui (gui-view-state? text%? (text%? . -> . void?) . -> . void?))
(is-editor-registered? (gui-view-state? text%? . -> . boolean?))
(get-related-labels-from-drscheme-pos-and-editor (gui-view-state? non-negative-exact-integer? text%? . -> . (listof label?)))
(user-change-terms (gui-view-state? (listof (cons/c label? string?)) . -> . void?))
(add-arrow (gui-view-state? (list/c label? label? string?) boolean? . -> . void?))
(get-tacked-arrows-from-label (gui-view-state? label? . -> . non-negative-exact-integer?))
(remove-arrows (gui-view-state? label? (or/c symbol? boolean?) boolean? . -> . void?))
(redraw-arrows (gui-view-state? (is-a?/c dc<%>) real? real? . -> . void?))
(invalidate-bitmap-cache (gui-view-state? . -> . void?))
(label-has-snips-of-this-type? (gui-view-state? label? symbol? . -> . boolean?))
(snips-currently-displayed-in-editor? (gui-view-state? text%? . -> . boolean?))
(for-each-snip-type (gui-view-state? (symbol? . -> . void?) . -> . void?))
(run-thunk-without-snips (gui-view-state? (-> any) . -> . any))
(add-snips (gui-view-state? label? symbol? text%? . -> . void?))
(remove-inserted-snips (gui-view-state? label? symbol? text%? . -> . void?))
(remove-all-snips-in-editor (gui-view-state? text%? . -> . void?))
(remove-all-snips-in-all-editors (gui-view-state? . -> . void?))
(remove-all-colors ((box/c (listof text%?)) . -> . void?))
(remove-all-snips-and-arrows-and-colors (gui-view-state? . -> . void?))
)
; text%
; (label -> text%)
; (label -> non-negative-exact-integer)
; (label -> non-negative-exact-integer)
; (symbol label -> (listof string))
; (label -> style-delta%)
; (listof (cons symbol style-delta%))
; boolean
; -> gui-view-state
(set! make-gui-view-state
(let ([real-make-gui-view-state make-gui-view-state])
(lambda (top-editor
get-editor-from-label
get-mzscheme-position-from-label
get-span-from-label
get-snip-text-from-snip-type-and-label
get-style-delta-from-label
snip-types-and-colors
clear-colors-immediately?)
(real-make-gui-view-state (saam:make-gui-model-state get-editor-from-label
get-mzscheme-position-from-label
get-span-from-label
(map car snip-types-and-colors))
top-editor
get-editor-from-label
#f
get-snip-text-from-snip-type-and-label
get-style-delta-from-label
(map (lambda (snip-type-and-color)
(cons (car snip-type-and-color)
(send (make-object style-delta%) set-delta-foreground (cdr snip-type-and-color))))
snip-types-and-colors)
clear-colors-immediately?))))
; INTERFACE BETWEEN MODEL AND TOP MODULE
; gui-view-state non-negative-exact-integer text% -> (listof label)
(define (get-related-labels-from-drscheme-pos-and-editor gui-view-state pos editor)
(saam:get-related-labels-from-drscheme-pos-and-source
(gui-view-state-gui-model-state gui-view-state) pos editor))
; gui-view-state label (text% -> void) -> void
; registers a label with the gui. We also need to initialize the editor's state the first time
; we see that editor, to make sure all editors are sharing the same state.
; Note that we could color the label as we go, thereby having incremental coloring as we
; analyze terms, but that turns out to be *very* slow, because the editor has to be unlocked
; (because of disable-evalution), the style changed, the editor re-lock and the bitmap cache
; invalidated for each label in turn. It would also possibly not show all the arrows for a
; given label while the analysis is still going on.
(define (register-label-with-gui gui-view-state label init-editor)
(let ([editor (saam:register-label-with-gui (gui-view-state-gui-model-state gui-view-state) label)])
(when editor (init-editor editor)))
cst:void)
; gui-view-state text% (text% -> void) -> void
; Same as above, except that we register an editor instead of a label. We use this to always
; register the top editor (see comment in make-register-label-with-gui in
; snips-and-arrows.ss).
(define (register-editor-with-gui gui-view-state editor init-editor)
(let ([editor (saam:register-source-with-gui (gui-view-state-gui-model-state gui-view-state) editor)])
(when editor (init-editor editor)))
cst:void)
; gui-view-state text% -> boolean
(define (is-editor-registered? gui-view-state editor)
(saam:is-source-registered? (gui-view-state-gui-model-state gui-view-state) editor))
; gui-view-state (symbol -> void) -> void
(define (for-each-snip-type gui-view-state f)
(saam:for-each-snip-type (gui-view-state-gui-model-state gui-view-state) f))
; gui-view-state label symbol -> boolean
(define (label-has-snips-of-this-type? gui-view-state label type)
(saam:label-has-snips-of-this-type? (gui-view-state-gui-model-state gui-view-state) label type))
; gui-view-state text% -> boolean
(define (snips-currently-displayed-in-editor? gui-view-state editor)
(saam:snips-currently-displayed-in-source? (gui-view-state-gui-model-state gui-view-state) editor))
; gui-view-state label -> non-negative-exact-integer
(define (get-tacked-arrows-from-label gui-view-state label)
(saam:get-tacked-arrows-from-label (gui-view-state-gui-model-state gui-view-state) label))
; gui-view-state (list label label string) boolean -> void
(define (add-arrow gui-view-state arrow-info tacked?)
(saam:add-arrow (gui-view-state-gui-model-state gui-view-state) arrow-info tacked?))
; gui-view-state label (or/c symbol boolean) boolean -> void
(define (remove-arrows gui-view-state start-label tacked? exn?)
(saam:remove-arrows (gui-view-state-gui-model-state gui-view-state) start-label tacked? exn?))
; COLORING / CLEARING
; gui-view-state (box (listof text%)) -> void
; Color all registered labels. Note that we know that no user modifications will be
; possible while we color (snips-and-arrows.ss takes care of that through can-insert?
; can-delete?) so there's no need to lock the editors.
; We remember all the editors in known-editors, because we might need that later, once
; the state has been resetted, to correctly clear the colors in all editors.
(define (color-registered-labels gui-view-state known-editors)
(let* ([gui-model-state (gui-view-state-gui-model-state gui-view-state)]
[get-span-from-label (saam:make-get-span-from-label-from-model-state gui-model-state)]
[get-style-delta-from-label (gui-view-state-get-style-delta-from-label gui-view-state)])
(saam:for-each-source
gui-model-state
(lambda (editor)
(when editor
(set-box! known-editors (cons editor (unbox known-editors)))
(let ([locked? (send editor is-locked?)])
(send editor begin-edit-sequence #f)
(send editor lock #f)
(saam:for-each-label-in-source
gui-model-state
editor
(lambda (label)
(let ([label-left-pos (saam:get-position-from-label gui-model-state label)])
(send editor change-style (get-style-delta-from-label label)
label-left-pos (+ label-left-pos (get-span-from-label label)) #f))))
(send editor lock locked?)
(send editor end-edit-sequence)))))
(invalidate-bitmap-cache gui-view-state)))
; text% -> void
; resets all colors to original style
(define (reset-editor-style editor)
(when editor
(let ([locked? (send editor is-locked?)])
(send editor begin-edit-sequence #f)
(send editor lock #f)
; comment this out if you want to keep all the pretty colors
(let* ([style-list (send editor get-style-list)]
[standard-style (send style-list find-named-style "Standard")])
(when standard-style
(send editor change-style
standard-style
0 (send editor last-position) #f)))
(send editor lock locked?)
(send editor end-edit-sequence))))
; (box (listof text%)) -> void
(define (remove-all-colors known-editors)
(for-each reset-editor-style (unbox known-editors))
(set-box! known-editors '()))
; gui-view-state -> void
(define (remove-all-colors-using-state gui-view-state)
(saam:for-each-source (gui-view-state-gui-model-state gui-view-state) reset-editor-style))
; gui-view-state -> void
; remove arrows and all snips, editor by editor.
(define (remove-all-snips-and-arrows gui-view-state)
(set-gui-view-state-analysis-currently-modifying?! gui-view-state #t)
(saam:remove-all-arrows (gui-view-state-gui-model-state gui-view-state))
(invalidate-bitmap-cache gui-view-state)
(remove-all-snips-in-all-editors gui-view-state)
(set-gui-view-state-analysis-currently-modifying?! gui-view-state #f))
; gui-view-state text% -> void
; Remove all snips in a given editor. We loop over each label and then loop over each
; snip type and remove the corresponding snip group. It would probably be much faster
; to first get the positions of the groups of all snips for each label (since for a given
; label all the groups of snips of different types are next to each other), sort them
; by decreasing position (so that removing a group of snip doesn't require recomputing
; the positions of the remaining groups), then remove them in that order. I might do
; that one day if people complain of slowness...
(define (remove-all-snips-in-editor gui-view-state editor)
(let ([gui-model-state (gui-view-state-gui-model-state gui-view-state)])
(saam:for-each-label-in-source
gui-model-state
editor
(lambda (label)
(saam:for-each-snip-type
gui-model-state
(lambda (type)
(when (saam:label-has-snips-of-this-type? gui-model-state label type)
(remove-inserted-snips gui-view-state label type editor))))))))
; gui-view-state -> void
; remove all snips
(define (remove-all-snips-in-all-editors gui-view-state)
(saam:for-each-source (gui-view-state-gui-model-state gui-view-state)
(lambda (editor)
(remove-all-snips-in-editor gui-view-state editor))))
; gui-view-state -> void
; clear all and reset all
(define (remove-all-snips-and-arrows-and-colors gui-view-state)
(remove-all-snips-and-arrows gui-view-state)
(remove-all-colors-using-state gui-view-state)
(reset-all-editors-state gui-view-state))
; gui-view-state -> void
; invalidates the bitmap cache of the top editor, which will call the overridden
; on-paint method of the top editor and redraw the arrows.
(define (invalidate-bitmap-cache gui-view-state)
(send (gui-view-state-top-editor gui-view-state) invalidate-bitmap-cache))
; gui-view-state -> void
; Resets the state of all editors we know about. Last nail in the coffin for
; this analysis round.
(define (reset-all-editors-state gui-view-state)
(saam:for-each-source (gui-view-state-gui-model-state gui-view-state)
(lambda (editor)
(send editor reset-snips-and-arrows-state))))
; EDITOR EVENTS INTERACTION
; gui-view-state -> void
; the user has started modifying stuff, so we just remove all snips (in other editors only,
; since we know a user modification is only allowed if the current editor doesn't have
; any snips - the current editor is currently locked anyway) and all arrows (in all editors),
(define (after-user-action gui-view-state)
(remove-all-snips-and-arrows gui-view-state)
(when (gui-view-state-clear-colors-immediately? gui-view-state)
(remove-all-colors-using-state gui-view-state))
(reset-all-editors-state gui-view-state))
; gui-view-state dc% real real -> void
; redraws arrows during on-paint
(define (redraw-arrows gui-view-state dc dx dy)
(let ([top-editor (gui-view-state-top-editor gui-view-state)]
[untacked-arrow-brush (send the-brush-list find-or-create-brush "white" 'solid)]
[old-pen (send dc get-pen)]
[old-brush (send dc get-brush)])
(saam:for-each-arrow (gui-view-state-gui-model-state gui-view-state)
(lambda (start-label-pos-left end-label-pos-left
start-label-span end-label-span
start-editor end-editor
tacked? color)
(send dc set-pen (send the-pen-list find-or-create-pen color 1 'solid))
(if tacked?
(send dc set-brush (send the-brush-list find-or-create-brush color 'solid))
(send dc set-brush untacked-arrow-brush))
(draw-arrow start-label-pos-left
(+ start-label-pos-left start-label-span)
end-label-pos-left
(+ end-label-pos-left end-label-span)
top-editor
start-editor
end-editor
dc dx dy)))
(send dc set-pen old-pen)
(send dc set-brush old-brush)))
; TEXT
; gui-view-state (listof (cons label string)) -> void
; Resize and re-color the terms corresponding to all the labels.
; We know there's at least one label in the list for each term to be changed,
; but there might be several labels in the list for the same term. We need
; to update *all* known labels for all term to be changed, and modify the
; corresponding term only once. So we do it in two steps:
; - we sort the new terms by editor and position, throwing away all the labels
; (we only needed them to get the positions)
; - from the positions and the editors, get all the labels (sounds redundant?
; the idea is that we then know that we have *all* the labels for all the
; terms to be changed, and we know that we have each label only once) and
; actually do the changes, modifying all the labels for a given term and
; modifying the content of the corresponding editor only once for a given
; term, for all terms, by decreasing position in each editor.
; At least we know that all labels for a given term have the same editor (unless
; the user of this library really screwed up get-editor-from-label but then it's
; not our problem if the user can't read the docs...)
(define (user-change-terms gui-view-state labels-and-new-terms)
(if (null? labels-and-new-terms)
(error 'user-change-terms "internal error: can't resize no labels~n")
(let ([get-editor-from-label (gui-view-state-get-editor-from-label gui-view-state)]
[get-style-delta-from-label (gui-view-state-get-style-delta-from-label gui-view-state)]
[new-terms-by-positions-by-editor (assoc-set-make)]
[gui-model-state (gui-view-state-gui-model-state gui-view-state)])
(set-gui-view-state-analysis-currently-modifying?! gui-view-state #t)
; first we sort the terms to be modified by editor and by position
; at the end we throw away the labels, because we don't know whether we have
; all of them, so since we'll have to get all of them ourselves, we might just
; as well throw away all the onces the user gave us, at least we won't have to
; do any sorting to make sure we don't have duplicates.
(for-each
(lambda (label-and-new-term)
(let* ([label (car label-and-new-term)]
[new-term (cdr label-and-new-term)]
[editor (get-editor-from-label label)]
[new-terms-by-position
(assoc-set-get new-terms-by-positions-by-editor
editor
(lambda ()
(let ([new-terms-by-position (assoc-set-make)])
(assoc-set-set new-terms-by-positions-by-editor
editor
new-terms-by-position)
new-terms-by-position)))]
[position (saam:get-position-from-label gui-model-state label)]
[current-new-term
(assoc-set-get new-terms-by-position
position
(lambda ()
(assoc-set-set new-terms-by-position
position
new-term)
new-term))])
(unless (string=? new-term current-new-term)
(error 'user-change-terms "two different terms specified for same position: ~a and ~a"
new-term current-new-term))))
labels-and-new-terms)
; then for each editor and each position we have found, we update all the labels
; by changing their span in the model, and modify the editor at the right place (note
; that we need to sort the positions of the labels in decreasing order for a given
; editor, otherwise modifying one term would change the actual positions of the
; remaining terms to change...)
;
; These changes can be undone only when the editor doesn't contain any snips,
; otherwise the undo will undo at the wrong place. Even if we were to force
; the change without undo, it would still not work because any previous action
; could later be undone at the wrong place. The only way out it to put the
; whole thing inside run-thunk-without-snips (which will make it undoable
; from DrScheme's point of view) and provide our own undoer to undo the change.
; XXX to be done later... same thing with user modifications (insert / delete):
; use run-thunk-without-snips and provide our own undoer with add-undo.
; In the meantime we just forbid the change. Note that we must test all the editors
; for snips before doing any change, because otherwise we might change terms in one
; editor and not in another and break the semantics of the change.
(let ([abort? #f])
(assoc-set-for-each
new-terms-by-positions-by-editor
(lambda (editor new-terms-by-positions)
(when (snips-currently-displayed-in-editor? gui-view-state editor)
(set! abort? #t))))
(if abort?
(message-box (strcst:string-constant snips-and-arrows-user-action-disallowed-title)
(strcst:string-constant snips-and-arrows-user-action-disallowed)
#f '(ok caution))
; the "save" button will show up...
(assoc-set-for-each
new-terms-by-positions-by-editor
(lambda (editor new-terms-by-positions)
(when editor
(let ([locked? (send editor is-locked?)])
(send editor begin-edit-sequence #t)
(send editor lock #f)
(for-each
(lambda (position-and-new-term-pair)
(let* ([position (car position-and-new-term-pair)]
[new-term (cdr position-and-new-term-pair)]
[labels (get-related-labels-from-drscheme-pos-and-editor gui-view-state position editor)])
(let-values ([(old-ending-pos new-ending-pos)
(saam:user-change-terms gui-model-state
labels editor
(string-length new-term))])
(send editor insert new-term position old-ending-pos)
; the styles for the different labels are hopefully the same...
(send editor change-style
(get-style-delta-from-label (car labels))
position new-ending-pos #f))))
(sort (assoc-set-map new-terms-by-positions cons)
(lambda (pos&term-pair1 pos&term-pair2)
(> (car pos&term-pair1) (car pos&term-pair2)))))
(send editor lock locked?)
(send editor end-edit-sequence)))))))
(set-gui-view-state-analysis-currently-modifying?! gui-view-state #f))))
; SNIPS
; gui-view-state label symbol text% -> void
; Adds snips of given type to given label.
; We could get the editor from the label, but there's no reason to bother...
(define (add-snips gui-view-state label type editor)
(when editor
(let ([snips-content
((gui-view-state-get-snip-text-from-snip-type-and-label gui-view-state) type label)])
(unless (null? snips-content)
(set-gui-view-state-analysis-currently-modifying?! gui-view-state #t)
(let ([snip-style
(cdr (assq type (gui-view-state-snip-types-and-colors gui-view-state)))]
[starting-pos (saam:add-snips (gui-view-state-gui-model-state gui-view-state)
label type editor (length snips-content))]
[locked? (send editor is-locked?)]
[modified? (send editor is-modified?)])
(send editor begin-edit-sequence #f)
(send editor lock #f)
(for-each (lambda (snip-content)
(let* ([snip-text (make-object text%)]
[snip (make-object editor-snip% snip-text)])
(send snip-text insert snip-content)
(send snip-text lock #t)
(send editor insert snip starting-pos starting-pos)
; XXX bug here on Solaris, can be worked around
; (invalidate-bitmap-cache gui-view-state)
; see collects/test/tool2.ss
(send editor change-style snip-style
starting-pos (add1 starting-pos) #f)))
snips-content)
(send editor set-modified modified?)
(send editor lock locked?)
(send editor end-edit-sequence))
(invalidate-bitmap-cache gui-view-state)
(set-gui-view-state-analysis-currently-modifying?! gui-view-state #f)))))
; gui-view-state label symbol text% -> void
; Remove snips for a given label and type.
; We could get the editor from the label, but there's no reason to bother...
(define (remove-inserted-snips gui-view-state label type editor)
(when editor
(set-gui-view-state-analysis-currently-modifying?! gui-view-state #t)
(let-values ([(starting-pos ending-pos)
(saam:remove-inserted-snips (gui-view-state-gui-model-state gui-view-state)
label type editor)]
[(locked?) (send editor is-locked?)]
[(modified?) (send editor is-modified?)])
; all the snips for a given label and type are contiguous and deleted at once.
(send editor begin-edit-sequence #f)
(send editor lock #f)
(send editor delete starting-pos ending-pos #f)
(send editor set-modified modified?)
(send editor lock locked?)
(send editor end-edit-sequence))
(invalidate-bitmap-cache gui-view-state)
(set-gui-view-state-analysis-currently-modifying?! gui-view-state #f)))
; gui-view-state (-> top) -> top
; removes all the snips (and remembers them), runs the thunk, then puts all the snips back in...
; remove-inserted-snips and add-snips take care of is-locked? and is-modified?, but even
; though they also take care of begin/end-edit-sequence, we still need to wrap everything
; in a sequence here otherwise the user would see the snips suddenly disappear and reappear...
(define (run-thunk-without-snips gui-view-state thunk)
(let ([gui-model-state (gui-view-state-gui-model-state gui-view-state)]
[snip-types-by-label-by-editor (assoc-set-make)])
(saam:for-each-source
gui-model-state
(lambda (editor)
(send editor begin-edit-sequence #f)
(let ([snip-types-by-label (assoc-set-make)])
(assoc-set-set snip-types-by-label-by-editor editor snip-types-by-label)
(saam:for-each-label-in-source
gui-model-state
editor
(lambda (label)
(saam:for-each-snip-type
gui-model-state
(lambda (type)
(when (saam:label-has-snips-of-this-type? gui-model-state label type)
(set-set (assoc-set-get snip-types-by-label label
(lambda ()
(let ([set (set-make)])
(assoc-set-set snip-types-by-label label set)
set)))
type)
(remove-inserted-snips gui-view-state label type editor)))))))))
(let ([result (thunk)])
(assoc-set-for-each
snip-types-by-label-by-editor
(lambda (editor snip-types-by-label)
(assoc-set-for-each
snip-types-by-label
(lambda (label types-set)
(set-for-each
types-set
(lambda (type)
(add-snips gui-view-state label type editor)))))
(send editor end-edit-sequence)))
result)))
; ARROWS
; (box number) (box number) -> number
(define (average box1 box2)
(/ (+ (unbox box1) (unbox box2)) 2))
; non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer non-negative-exact-integer
; text% text% text% dc% real real -> void
; Computes actual locations for arrow and draws it.
; Note that we don't do anything to prevent arrows of length zero from being drawn - these
; might show up when using macros that duplicate terms, so arrows of length zero are then
; the correct thing to do as far as I am concerned).
(define (draw-arrow start-label-pos-left start-label-pos-right
end-label-pos-left end-label-pos-right
top-editor start-editor end-editor
dc dx dy)
(let ([start-sub-ed-left-x-loc (box 0)]
[start-sub-ed-top-y-loc (box 0)]
[start-sub-ed-right-x-loc (box 0)]
[start-sub-ed-bot-y-loc (box 0)]
[end-sub-ed-left-x-loc (box 0)]
[end-sub-ed-top-y-loc (box 0)]
[end-sub-ed-right-x-loc (box 0)]
[end-sub-ed-bot-y-loc (box 0)])
(send start-editor position-location start-label-pos-left start-sub-ed-left-x-loc start-sub-ed-top-y-loc #t)
(send start-editor position-location start-label-pos-right start-sub-ed-right-x-loc #f #f)
(send start-editor position-location (sub1 start-label-pos-right) #f start-sub-ed-bot-y-loc #f)
(send end-editor position-location end-label-pos-left end-sub-ed-left-x-loc end-sub-ed-top-y-loc #t)
(send end-editor position-location end-label-pos-right end-sub-ed-right-x-loc #f #f)
(send end-editor position-location (sub1 end-label-pos-right) #f end-sub-ed-bot-y-loc #f)
(let*-values
([(start-sub-ed-x-loc) (average start-sub-ed-left-x-loc start-sub-ed-right-x-loc)]
[(start-sub-ed-y-loc) (average start-sub-ed-top-y-loc start-sub-ed-bot-y-loc)]
[(end-sub-ed-x-loc) (average end-sub-ed-left-x-loc end-sub-ed-right-x-loc)]
[(end-sub-ed-y-loc) (average end-sub-ed-top-y-loc end-sub-ed-bot-y-loc)]
[(start-dc-x-loc start-dc-y-loc)
(send start-editor editor-location-to-dc-location start-sub-ed-x-loc start-sub-ed-y-loc)]
[(end-dc-x-loc end-dc-y-loc)
(send end-editor editor-location-to-dc-location end-sub-ed-x-loc end-sub-ed-y-loc)]
[(start-top-ed-x-loc start-top-ed-y-loc)
(send top-editor dc-location-to-editor-location start-dc-x-loc start-dc-y-loc)]
[(end-top-ed-x-loc end-top-ed-y-loc)
(send top-editor dc-location-to-editor-location end-dc-x-loc end-dc-y-loc)])
(arrow:draw-arrow
dc start-top-ed-x-loc start-top-ed-y-loc end-top-ed-x-loc end-top-ed-y-loc dx dy))))
)

616
collects/mrflow/snips-and-arrows.ss
View File

@ -1,616 +0,0 @@
(module snips-and-arrows (lib "mrflow.ss" "mrflow")
(require
mzlib/etc
mzlib/class
mred
(prefix strcst: string-constants)
(prefix cst: "constants.ss")
(prefix saav: "snips-and-arrows-view.ss")
"labels.ss"
)
(provide/contract
(extend-all-editors-mixin mixin-contract)
(extend-top-editor-mixin mixin-contract)
(init-snips-and-arrows-gui (text%?
(label? . -> . text%?)
(label? . -> . non-negative-exact-integer?)
(label? . -> . non-negative-exact-integer?)
((listof label?) . -> . (listof (list/c label? label? string?)))
(label? . -> . style-delta%?)
((is-a?/c popup-menu%) (listof label?) . -> . void?)
(symbol? symbol? . -> . string?)
(symbol? label? . -> . (listof string?))
(listof (cons/c symbol? string?))
boolean?
. -> .
(values ((listof (cons/c label? string?)) . -> . void?)
(label? . -> . void?))))
(init-snips-and-arrows-gui-for-syntax-objects (text%?
((listof syntax?) . -> . (listof (list/c syntax? syntax? string?)))
(syntax? . -> . style-delta%?)
((is-a?/c popup-menu%) (listof syntax?) . -> . void?)
(symbol? symbol? . -> . string?)
(symbol? syntax? . -> . (listof string?))
(listof (cons/c symbol? string?))
boolean?
. -> .
(values ((listof (cons/c syntax? string?)) . -> . void?)
(syntax? . -> . void?))))
)
(define-struct gui-state (; gui-view-state
gui-view-state
; ((listof label) -> (listof (list label label string)))
get-arrows-from-labels
; (symbol symbol -> string)
get-menu-text-from-snip-type
; (symbol label -> (listof string))
get-snip-text-from-snip-type-and-label
; (popup-menu% (listof label) -> void)
extend-menu-for-labels
; (union #f (listof label))
previous-labels
; boolean
; we need this one to prevent arrows and menus to show up
; before the real analysis part is over, because as long as
; the analysis is not finished we might not have all arrows
; and not all errors (so wrong menus).
term-analysis-done?
))
; MENUS
; gui-state menu% (listof labels) symbol text% -> void
; creates a menu entry for a given snip type
; all labels correspond to the same term (because of macros)
(define (create-snips-menu-item-by-type gui-state menu labels type editor)
(let ([gui-view-state (gui-state-gui-view-state gui-state)]
[get-menu-text-from-snip-type (gui-state-get-menu-text-from-snip-type gui-state)]
[get-snip-text-from-snip-type-and-label
(gui-state-get-snip-text-from-snip-type-and-label gui-state)])
(if (ormap (lambda (label)
(saav:label-has-snips-of-this-type? gui-view-state label type))
labels)
; at least one label has snips displayed => delete menu entry
(make-object menu-item%
(get-menu-text-from-snip-type type 'hide)
menu
(lambda (item event)
(for-each (lambda (label)
(when (saav:label-has-snips-of-this-type? gui-view-state label type)
(saav:remove-inserted-snips gui-view-state label type editor)))
labels)))
; no label has snips displayed => show menu entry if one of them has snips associated
; with it
(unless (andmap (lambda (label)
(null? (get-snip-text-from-snip-type-and-label type label)))
labels)
(make-object menu-item%
(get-menu-text-from-snip-type type 'show)
menu
(lambda (item event)
(for-each (lambda (label)
(saav:add-snips gui-view-state label type editor))
labels))))))
cst:void)
; gui-state menu% (listof label) -> menu-item%
; create menu entries for arrows
; all labels correspond to the same term (because of macros)
(define (create-arrow-menu-items gui-state menu labels)
(let* ([gui-view-state (gui-state-gui-view-state gui-state)]
[arrows-info ((gui-state-get-arrows-from-labels gui-state) labels)]
[max-arrows (length arrows-info)]
[tacked-arrows (apply + (map (lambda (label)
(saav:get-tacked-arrows-from-label gui-view-state label))
labels))])
(when (< tacked-arrows max-arrows)
(make-object menu-item%
(strcst:string-constant snips-and-arrows-popup-menu-tack-all-arrows)
menu
(lambda (item event)
; remove all (possibly untacked) arrows and add all arrows, tacked.
; we could just add the untacked ones, but what we do here is simple
; and efficient enough
(for-each (lambda (label)
(saav:remove-arrows gui-view-state label 'all #t))
labels)
(for-each
(lambda (arrow-info)
(saav:add-arrow gui-view-state arrow-info #t))
arrows-info)
(saav:invalidate-bitmap-cache gui-view-state))))
(when (> tacked-arrows 0)
(make-object menu-item%
(strcst:string-constant snips-and-arrows-popup-menu-untack-all-arrows)
menu
(lambda (item event)
(for-each (lambda (label)
(saav:remove-arrows gui-view-state label 'all #t))
labels)
(saav:invalidate-bitmap-cache gui-view-state))))))
; gui-view-state -> boolean
; User insertions cause problems: a user might insert something while our snips
; are present. That would force us to remove all the snips, since as soon as
; the user changes the program the results of the analysis become invalid. So
; we would have to keep track of the user insertion (which is possible), update
; the position of all our snips accordingly (which is possible too), then delete
; all the snips because they would not be valid anymore (which is very possible).
; In fact we used to do all that. The reason we got rid of it is because it does
; not interact well with the undo feature: if, after the user insertion and the
; automatic removal of snips, the user does an undo, the undo might delete random
; stuff at the position where the user insertion initially occured, but that might
; not be the position where that user-inserted stuff currently is, because removing
; the snips between the insertion and the undo might have moved around the stuff
; that was inserted...
;
; Note that it's not possible to delete our snips just right before the user action
; is effected in the window (e.g. during a call to the on-insert method),
; because the editor is locked at that time (and with reason: if we were to remove
; the snips right after the user acts (which is the thing that decides we must
; get rid of all our snips) but just before the action actually takes place in the
; editor, then after removing the snips the user action would actually be effected
; at the wrong position in the editor - i.e. we can't sweep the rug under DrScheme's
; own insertion mechanism, and I don't think Matthew would be willing to add a mechanism
; whereby one could notify DrScheme that the rug is being swept...)
;
; Same problem with trying to remove the snips inside can-insert? : the editor is
; locked.
;
; Note also that things get even worse if the user tries to delete stuff instead of
; inserting stuff: the user might try to delete one of our own snips! We could
; check the stuff the user wants to delete and only allow the delete if the stuff
; didn't contain one of our snips, but this still wouldn't solve the undo problem
; (which exists in reverse: deleting and undoing would re-insert the deleted stuff
; at the wrong place - I tried it!).
;
; Conclusion: it's impossible to solve the problem of user insertion and deletion
; while snips are present, because the undo then becomes buggy. So we simply
; completely disallow user insertions and deletions while snips are present (in
; this editor - there's no problem with undo if the user action happens in another
; editor that doesn't contain snips, and then we just use that as a signal to delete
; all snips in all editors using the after-user-action fucntion).
;
; So this is what this function is doing: disallow user modifications to an editor
; when the editor contains snips (or while the analysis is still running).
(define (is-action-allowed? gui-view-state editor)
(or (saav:analysis-currently-modifying? gui-view-state)
(if (saav:snips-currently-displayed-in-editor? gui-view-state editor)
(begin
(message-box (strcst:string-constant snips-and-arrows-user-action-disallowed-title)
(strcst:string-constant snips-and-arrows-user-action-disallowed)
#f '(ok caution))
#f)
#t)))
; MIXINS
; to be applied to all editors and sub-editors containing registered labels
(define extend-all-editors-mixin
(lambda (super%)
(class super%
; State initialization and resetting
; The state is created by the call to init-snips-and-arrows-gui in the callback
; of the tool's button. The state is hidden inside the register-label-with-gui function
; returned by the call. That means a new instance of the state is created each time
; the user uses the tool. Then, each time the user uses register-label-with-gui,
; the function checks whether the editor has been seen before or not, and if it hasn't
; it calls the editor's initialize-snips-and-arrows-gui-state method to initialize the
; editor's state. That ensures that all editors where coloring has to happen share the
; same state. Note that the top editor has both extend-all-editors-mixin and
; extend-top-editor-mixin applied to it, so the initialize-snips-and-arrows-gui-state
; method is define/public in one case and define/override in the other case.
; Note also that the initialization of the top editor is always done
; as a special case inside init-snips-and-arrows-gui (see this function below)
; because that editor still needs to have access to the state to redraw arrows even if
; no label is registered for it.
;
; The state is reset in two cases:
; - the user inserts or deletes something in an editor (see the comment for
; is-action-allowed? above for details about when this is allowed), and
; clear-colors-immediately? is true
; - the gui makes a direct call to remove-all-snips-and-arrows-and-colors (probably inside
; the clear-annotations method for the unit frame)
; The state is reseted by calling the reset-snips-and-arrows-state method of each editor
; for which a label has been registred. Since the unit frame has no direct reference to
; the state but only through the register-label-with-gui function, and since the editors
; don't have any reference to the state after their reset-snips-and-arrows-state method
; is called, the state can be garbage collected as soon as the register-label-with-gui
; function is not referenced by the unit frame anymore.
; Note that it would be possible for the unit frame to re-use the state (and indeed that's
; how it was working for a while) but it makes testing whether the analysis is currently
; running a bit more difficult and doesn't make anything else any simpler. Besides, it
; might also be a source of subtle errors if everything is not correctly reseted from one
; run of the analysis to the next one.
; (union gui-state symbol)
(define gui-state 'uninitialized-gui-state-in-extend-all-editors-mixin)
; (union gui-view-state 'symbol)
(define gui-view-state 'uninitialized-gui-view-state-in-extend-all-editors-mixin)
; gui-state -> void
; see the same method below for explanation
(define/public (initialize-snips-and-arrows-gui-state new-gui-state)
(set! gui-state new-gui-state)
(set! gui-view-state (gui-state-gui-view-state new-gui-state)))
; -> void
(define/public (reset-snips-and-arrows-state)
(set! gui-state 'reinitialized-gui-state-in-extend-all-editors-mixin)
(set! gui-view-state 'reinitialized-gui-view-state-in-extend-all-editors-mixin))
; exact-non-negative-integer exact-non-negative-integer -> boolean
(define/augment (can-insert? start len)
(and (or (symbol? gui-state)
(and (gui-state-term-analysis-done? gui-state)
(is-action-allowed? gui-view-state this)))
(inner #t can-insert? start len)))
; exact-non-negative-integer exact-non-negative-integer -> boolean
(define/augment (can-delete? start len)
(and (or (symbol? gui-state)
(and (gui-state-term-analysis-done? gui-state)
(is-action-allowed? gui-view-state this)))
(inner #t can-delete? start len)))
; exact-non-negative-integer exact-non-negative-integer -> void
(define/augment (after-insert start len)
(unless (or (symbol? gui-state)
(saav:analysis-currently-modifying? gui-view-state))
(saav:after-user-action gui-view-state))
(inner cst:void after-insert start len))
; exact-non-negative-integer exact-non-negative-integer -> void
(define/augment (after-delete start len)
(unless (or (symbol? gui-state)
(saav:analysis-currently-modifying? gui-view-state))
(saav:after-user-action gui-view-state))
(inner cst:void after-delete start len))
(super-instantiate ()))))
; to apply to the top editor
(define extend-top-editor-mixin
(lambda (super%)
(class super%
; (union gui-state symbol)
(define gui-state 'uninitialized-gui-state-in-extend-top-editor-mixin)
; (union gui-view-state symbol)
(define gui-view-state 'uninitialized-gui-view-state-in-extend-top-editor-mixin)
; (box (listof text%))
(define known-editors (box '()))
; gui-state -> void
; init-snips-and-arrows-gui creates register-label-with-gui, which will call
; saav:register-label-with-gui, which will in turn find the editor for the label
; and call this method (if necessary) to initialize the editor's state, thereby
; allowing all the editors for a single analysis to share the same state (see
; the same method above too).
(define/override (initialize-snips-and-arrows-gui-state new-gui-state)
(super initialize-snips-and-arrows-gui-state new-gui-state)
(set! gui-state new-gui-state)
(set! gui-view-state (gui-state-gui-view-state new-gui-state)))
; -> void
(define/override (reset-snips-and-arrows-state)
(super reset-snips-and-arrows-state)
(set! gui-state 'reinitialized-gui-state-in-extend-top-editor-mixin)
(set! gui-view-state 'reinitialized-gui-view-state-in-extend-top-editor-mixin))
; string symbol -> boolean
; We forbid saving if the analysis is in the middle of running or in the middle
; of modifying the content of the editor
(define/augment (can-save-file? filename format)
(if (symbol? gui-state)
(inner #t can-save-file? filename format)
(if (and (gui-state-term-analysis-done? gui-state)
(not (saav:analysis-currently-modifying? gui-view-state)))
(inner #t can-save-file? filename format)
#f)))
(define/override (save-file . args)
(if (symbol? gui-state)
(super save-file . args)
(saav:run-thunk-without-snips gui-view-state
(lambda () (super save-file . args)))))
; -> void
; colors all registered labels
; The analysis proper is only officially done after we've colored everything, otherwise
; user insertions might occur before we have time to finish coloring and we will color
; the wrong stuff...
(define/public (color-registered-labels)
(unless (symbol? gui-view-state)
(saav:color-registered-labels gui-view-state known-editors)
(set-gui-state-term-analysis-done?! gui-state #t)))
; -> void
; remove all snips and arrows, and resets text style in all editors
(define/public (remove-all-snips-and-arrows-and-colors)
(if (symbol? gui-view-state)
(saav:remove-all-colors known-editors)
(saav:remove-all-snips-and-arrows-and-colors gui-view-state)))
; boolean dc% real real real real real real symbol -> void
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(super on-paint before? dc left top right bottom dx dy draw-caret)
(when (and (not (symbol? gui-state))
(not before?)
(gui-state-term-analysis-done? gui-state))
(saav:redraw-arrows gui-view-state dc dx dy)))
(inherit find-position dc-location-to-editor-location)
; mouse-event% -> (values (union #f exact-non-negative-integer) (union #f text%))
; finds the editor in which a mouse-event% has occured, going down recursively
; if there are embedded editors, but not going down the embedded editors when they
; have been introduced by the analysis itself (e.g. type snips).
(define (get-drscheme-pos-and-editor event)
(let ([dc-x (send event get-x)]
[dc-y (send event get-y)]
[on-it? (box #f)])
(let loop ([previous-pos #f]
[previous-editor #f]
[editor this])
(let-values ([(ed-x ed-y) (send editor dc-location-to-editor-location dc-x dc-y)])
(let ([pos (send editor find-position ed-x ed-y #f on-it?)])
(if (not (unbox on-it?))
(values #f #f)
(let ([snip (send editor find-snip pos 'after-or-none)])
(if (and snip (is-a? snip editor-snip%))
(let ([sub-editor (send snip get-editor)])
(if (saav:is-editor-registered? gui-view-state sub-editor)
(loop pos editor sub-editor)
(values pos editor)))
(values pos editor)))))))))
(inherit get-admin)
; mouse-event% -> void
(define/override (on-event event)
(cond
[(or (symbol? gui-state)
(not (gui-state-term-analysis-done? gui-state)))
(super on-event event)]
[(and (send event button-down? 'right)
(let-values ([(pos editor) (get-drscheme-pos-and-editor event)])
(if pos
(let ([labels (saav:get-related-labels-from-drscheme-pos-and-editor
gui-view-state pos editor)])
(if (null? labels)
#f
(cons labels editor))) ; no "=>-values" so use cons...
#f)))
=>
(lambda (labels&editor)
(let ([menu (make-object popup-menu%)]
[labels (car labels&editor)]
[editor (cdr labels&editor)])
; SNIPS
(let ([create-snips-menu-item
(lambda (snip-type)
(create-snips-menu-item-by-type gui-state menu labels snip-type editor))])
(saav:for-each-snip-type gui-view-state create-snips-menu-item))
; ARROWS
(create-arrow-menu-items gui-state menu labels)
; HIDE ALL SNIPS
(when (saav:snips-currently-displayed-in-editor? gui-view-state editor)
(make-object menu-item%
(strcst:string-constant snips-and-arrows-hide-all-snips-in-editor)
menu
(lambda (item event)
(saav:remove-all-snips-in-editor gui-view-state editor))))
; OTHER
((gui-state-extend-menu-for-labels gui-state) menu labels)
(when (not (null? (send menu get-items)))
(let-values ([(x y) (dc-location-to-editor-location (send event get-x) (send event get-y))])
(send (get-admin) popup-menu menu x y)))
))]
[(and (send event button-down? 'middle)
(let-values ([(pos editor) (get-drscheme-pos-and-editor event)])
(if pos
(let ([labels (saav:get-related-labels-from-drscheme-pos-and-editor
gui-view-state pos editor)])
(if (null? labels)
#f
(cons labels editor))) ; no "=>-values" so use cons...
#f)))
=>
(lambda (labels&editor)
(let ([menu (make-object popup-menu%)]
[labels (car labels&editor)]
[editor (cdr labels&editor)]
[get-snip-text-from-snip-type-and-label
(gui-state-get-snip-text-from-snip-type-and-label gui-state)])
(saav:for-each-snip-type
gui-view-state
(lambda (snip-type)
(unless (andmap (lambda (label)
(null? (get-snip-text-from-snip-type-and-label snip-type label)))
labels)
; at least one label has snips of this type
(for-each (lambda (label)
(let ([snip-strings (get-snip-text-from-snip-type-and-label snip-type label)])
(unless (null? snip-strings)
(for-each
(lambda (snip-string)
(make-object menu-item%
(if (<= (string-length snip-string) 200)
snip-string
(string-append
(substring snip-string 0 197)
"..."))
menu
(lambda (item event) cst:void)))
snip-strings))))
labels)
(make-object separator-menu-item% menu))))
(when (not (null? (send menu get-items)))
(let-values ([(x y) (dc-location-to-editor-location (send event get-x) (send event get-y))])
(send (get-admin) popup-menu menu x y)))
))]
[(send event leaving?)
(let ([previous-labels (gui-state-previous-labels gui-state)])
(when previous-labels
(for-each (lambda (previous-label)
(saav:remove-arrows gui-view-state previous-label #f #f))
previous-labels)
(set-gui-state-previous-labels! gui-state #f)
(saav:invalidate-bitmap-cache gui-view-state)))]
[(or (send event moving?)
(send event entering?))
(if (or (send event get-left-down)
(send event get-middle-down)
(send event get-right-down))
(super on-event event)
(let*-values ([(pos editor) (get-drscheme-pos-and-editor event)]
[(labels)
(if pos
(saav:get-related-labels-from-drscheme-pos-and-editor
gui-view-state pos editor)
#f)]
[(previous-labels) (gui-state-previous-labels gui-state)]
[(not-same-labels) (not (equal? labels previous-labels))])
(when (and previous-labels not-same-labels)
(for-each (lambda (previous-label)
(saav:remove-arrows gui-view-state previous-label #f #f))
previous-labels))
(when (and labels not-same-labels)
(for-each (lambda (arrow-info)
(saav:add-arrow gui-view-state arrow-info #f))
((gui-state-get-arrows-from-labels gui-state) labels)))
(when not-same-labels
(when (or (not (null? previous-labels))
(not (null? labels)))
; something has changed, and we might have either removed some arrows or
; added some (or both), so we redraw
(saav:invalidate-bitmap-cache gui-view-state))
(set-gui-state-previous-labels! gui-state labels))))]
[else (super on-event event)]))
(super-instantiate ()))))
; ... see below ... -> (label -> void)
; Ouch... The returned function can be used to register labels with this gui
(define (init-snips-and-arrows-gui
; % text%
top-editor
; (label -> text%)
get-editor-from-label
; (label -> non-negative-exact-integer)
get-mzscheme-position-from-label
; (label -> non-negative-exact-integer)
get-span-from-label
; ((listof label) -> (listof (list label label string)))
get-arrows-from-labels
; (label -> style-delta%)
get-style-delta-from-label
; (popup-menu% (listof label) -> void)
extend-menu-for-labels
; (symbol symbol -> string)
get-menu-text-from-snip-type
; (symbol label -> (listof string))
get-snip-text-from-snip-type-and-label
; (listof (cons symbol string))
snip-types-and-colors
; boolean
clear-colors-immediately?)
(let* ([gui-view-state (saav:make-gui-view-state
top-editor
get-editor-from-label
get-mzscheme-position-from-label
get-span-from-label
get-snip-text-from-snip-type-and-label
get-style-delta-from-label
snip-types-and-colors
clear-colors-immediately?)]
[gui-state (make-gui-state
gui-view-state
get-arrows-from-labels
get-menu-text-from-snip-type
get-snip-text-from-snip-type-and-label
extend-menu-for-labels
#f
#f)])
; just make sure everything is clear before assigning a new state
(send top-editor remove-all-snips-and-arrows-and-colors)
; we need this to force the registration of the top editor, to make sure
; on-paint and on-event work correctly even when no label has been registered for
; the top editor itself.
(saav:register-editor-with-gui
gui-view-state top-editor
(lambda (editor)
(send editor initialize-snips-and-arrows-gui-state gui-state)))
(values
; (listof (cons label string)) -> void
(lambda (labels-and-new-terms)
(saav:user-change-terms gui-view-state labels-and-new-terms))
; label -> void
; to register a label with the gui
(lambda (label)
(saav:register-label-with-gui
gui-view-state label
(lambda (editor)
(send editor initialize-snips-and-arrows-gui-state gui-state))))
)))
; SIMPLIFIED INTERFACE
; symbol -> void
; default function for snip handling
(define error-no-snips
(case-lambda
[(_) (error-no-snips 'dummy 'dummy)]
[(_1 _2) (error 'snips-and-arrows "no snip info was provided when snips-and-arrows library was initialized")]))
; ... see below ... -> (values gui-state (label -> void))
; simplified version of make-snips-and-arrows-state, specialized for syntax objects,
; and with default handling of snips
(define init-snips-and-arrows-gui-for-syntax-objects
(opt-lambda (; text%
top-editor
; ((listof syntax-object) -> (listof (list syntax-object syntax-object string)))
get-arrows-from-syntax-objects
; (syntax-object -> style-delta%)
get-style-delta-from-syntax-object
; OPTIONAL menu stuff
; (popup-menu% (listof syntax-object) -> void)
(extand-menu-for-syntax-objects (lambda (menu stxs) cst:void))
; OPTIONAL snip stuff
; (symbol symbol -> string)
(get-menu-text-from-snip-type error-no-snips)
; (symbol syntax-object -> (listof string))
(get-snip-text-from-snip-type-and-syntax-object error-no-snips)
; (listof (cons symbol string))
(snip-types-and-colors '())
; boolean
(clear-colors-immediately? #f))
(init-snips-and-arrows-gui
top-editor
syntax-source
syntax-position
syntax-span
get-arrows-from-syntax-objects
get-style-delta-from-syntax-object
extand-menu-for-syntax-objects
get-menu-text-from-snip-type
get-snip-text-from-snip-type-and-syntax-object
snip-types-and-colors
clear-colors-immediately?)))
)

124
collects/mrflow/trie.ss
View File

@ -1,124 +0,0 @@
(module trie (lib "mrflow.ss" "mrflow")
(require (prefix list: mzlib/list)
(prefix cst: "constants.ss")
"dfa.ss"
"types.ss"
"util.ss")
;; DFA Tries - Allows for testing of a DFA being previously hashconsed
;; in Theta(|DFA|) time.
(provide (struct trie ())
add-dfa-states
dfa-present?)
; DFA states are analogous to letters and at a node we have map of handles
; indexed by the DFA representative (the handle of the last DFA state in a DFA
; canonically ordered by minimization).
;
; Two equivalent (minimal, strongly connected) DFAs will yield the same
; canonically ordered DFAs regardless of the start state picked.
;
; An association list and hash-table are used to store the maps, but perhaps
; there is a better choice of data structures.
(define-struct trie (dfa-representative->handle dfa-state->trie))
(set! make-trie
(let ([old-make-trie make-trie])
(lambda ()
(old-make-trie '() (make-hash-table 'equal)))))
; Get the trie on the edge labeled by the DFA state
(define/contract get-trie-child (trie? state? . -> . (or/c trie? false/c))
(lambda (trie letter)
(hash-table-get (trie-dfa-state->trie trie) letter cst:thunk-false)))
; Each DFA state added to the trie must map to a unique handle.
(define/contract add-trie-state-handle!
(trie? handle? handle? . ->d .
(lambda (trie representative-handle state-handle)
(let ([dfa->handle (trie-dfa-representative->handle trie)])
(when (assq representative-handle dfa->handle)
(error 'add-trie-state-handle!
"Mapping ~a to ~a, but trie already has mapping from DFA representative ~a to handle ~a"
representative-handle state-handle
representative-handle (cdr (assq representative-handle dfa->handle))))
trie?)))
(lambda (trie representative-handle state-handle)
(let ([dfa->handle (trie-dfa-representative->handle trie)])
(set-trie-dfa-representative->handle! trie (cons (cons representative-handle state-handle) dfa->handle))
trie)))
(define/contract get-state-handle (trie? handle? . -> . handle?)
(lambda (trie representative-handle)
(let ([dfa-representative->handle (trie-dfa-representative->handle trie)])
(cdr (assq representative-handle dfa-representative->handle)))))
(define/contract get-handle-from-representative
(trie? . ->d .
(lambda (trie)
(let ([dfa->handle (trie-dfa-representative->handle trie)])
(unless (length-one? dfa->handle)
(error 'get-handle-from-representative
"~a (!= 1) representatives present: ~a" (length dfa->handle) dfa->handle))
(unless (= (caar dfa->handle) (cdar dfa->handle))
(error 'get-handle-from-representative "Representative handle ~a not equal to representative handle ~a"
(caar dfa->handle) (cdar dfa->handle)))
handle?)))
(lambda (trie)
(caar (trie-dfa-representative->handle trie))))
; Return a handle of the DFAs start state if the DFA has already
; been hasconsed. For each of the ordered DFA states we descend one
; level in the trie until we reach the last state (the
; representative). As we are descending we note which of the tries
; contains the start state. Getting the representative handle, we
; can lookup the handle of the start state in this noted trie.
(define/contract dfa-present?
(trie? (nonempty-list-of? state?) . -> . (or/c false/c (listof handle?)))
(lambda (trie nstates)
(let/ec return-with
(let* ([rev-tries (list:foldl (lambda (state tries)
(let ([trie (get-trie-child (car tries) state)])
(if trie
(cons trie tries)
(return-with #f))))
(list trie)
nstates)]
[rep-handle (get-handle-from-representative (car rev-tries))])
;; get the handles for each state, in reverse order from the (reversed) list of tries
(list:foldr (lambda (trie states) (cons (get-state-handle trie rep-handle) states))
'() (cdr (reverse rev-tries)))))))
; Add a list of DFA states and their corresponding handles to the trie
(define/contract add-dfa-states
(trie? (nonempty-list-of? state?) (listof handle?) . ->d .
(lambda (trie states handles)
(unless (= (length states) (length handles))
(error 'add "length of list of types ~a != length of DFA handle list ~a"
(length states) (length handles)))
(lambda (_)
(let loop ([trie trie] [states states])
(if (null? states)
(begin
(unless (hash-table-empty? (trie-dfa-state->trie trie))
(error 'add-dfa-states "Representative node has a child node"))
(unless (length-one? (trie-dfa-representative->handle trie))
(error 'add-dfa-states "Representative node has more than one representative handle")))
(loop (get-trie-child trie (car states)) (cdr states)))))))
(lambda (trie states handles)
(let ([add-child (lambda (trie letter representative-handle dfa-handle)
(add-trie-state-handle!
(if (get-trie-child trie letter) (get-trie-child trie letter)
(let ([child-trie (make-trie)])
(hash-table-put! (trie-dfa-state->trie trie) letter child-trie)
child-trie))
representative-handle dfa-handle))]
[representative-handle (list-ref handles (sub1 (length handles)))])
(let loop ([trie trie] [states states] [handles handles])
(unless (null? states)
(loop (add-child trie (car states) representative-handle (car handles))
(cdr states)
(cdr handles)))))))
) ;; end module trie

122
collects/mrflow/types.ss
View File

@ -1,122 +0,0 @@
(module types mzscheme
(provide (all-defined))
(define-struct type () (make-inspector))
; (make-type-empty) is the same as (make-type-cst 'bottom) for now. The reason we
; *never* use (make-type-cst 'bottom) is because it would trigger the propagation of
; bottom everywhere, thus slowing down the analysis. There's two solutions to that:
; - not use initialize-label-set-for-value-source when using (make-type-cst 'bottom)
; - use a separate (make-type-empty), which is more correct anyway (note that there's
; currently no way to define the type for a primitive that returns the symbol 'bottom
; (or 'number, or 'null, etc...))
(define-struct (type-empty type) () (make-inspector))
(define-struct (type-cst type) (type) (make-inspector))
(define-struct (type-cons type) (car cdr) (make-inspector))
(define-struct (type-vector type) (element) (make-inspector))
(define-struct (type-case-lambda type) (rest-arg?s req-args argss exps) (make-inspector))
(define-struct (type-var type) (name reach handle) (make-inspector))
(define-struct (type-union type) (elements) (make-inspector))
(define-struct (type-rec type) (vars types body) (make-inspector))
(define-struct (type-values type) (type) (make-inspector))
(define-struct (type-promise type) (value) (make-inspector))
; note: we have to keep the type label around, because that's the only thing
; that allows us to differentiate structurally equivalent structure that have
; the same name (i.e. the only way to have subtyping work in the presence of generative
; structures). The reason for type-struct-type is because structure types are first
; class values in mzscheme. Also, by keeping the type-label around, we avoid the need
; to duplicate the type hierarchy all the way up to the root each time we compute the
; type of a structure.
(define-struct (type-struct-value type) (type-label types) (make-inspector))
(define-struct (type-struct-type type) (type-label) (make-inspector))
(define-struct (type-flow-var type) (name) (make-inspector))
(define-struct (type-scheme type) (flow-vars type^cs type) (make-inspector))
;;
;; Printing
;;
(require mzlib/match
(prefix string: mzlib/string)
"util.ss"
"labels.ss")
(define type->list
(lambda (type)
(letrec
([loop (lambda (type)
(match type
[($ type-empty) '_]
[($ type-cst type)
(if (null? type)
'null
(string->symbol (string:expr->string type)))]
[($ type-struct-type label)
(string->symbol (string-append "#<struct-type:"
(symbol->string (label-struct-type-name label))
">"))]
[($ type-cons hd tl)
(list 'cons (loop hd) (loop tl))]
[($ type-case-lambda rest-arg?s req-args argss exps)
(list 'case-lambda
(foldr-case-lambda-vector
(lambda (rest-arg? req-arg args exp acc)
(cons (list args (if rest-arg? '*-> '->) exp) acc))
null
rest-arg?s req-args argss exps))]
[($ type-promise value)
(list 'promise (loop value))]
[($ type-struct-value label types)
(list (string->symbol
(string-append "#(struct:"
(symbol->string (if (label-struct-type? label)
(label-struct-type-name label)
label))))
(map loop types))]
[($ type-values values-type)
(cond
[(type-empty? values-type)
(loop values-type)]
[(and (type-cst? values-type) (eq? (type-cst-type values-type) 'top))
(loop values-type)]
[else
(list 'values (loop values-type))])]
[($ type-vector element)
(list 'vector (loop element))]
[($ type-union elements)
(list 'union (map loop elements))]
[($ type-rec vars binders body)
(list 'rec-type
(map (lambda (v b)
(list (loop v) (loop b)))
vars binders)
(loop body))]
[($ type-var name r h)
name]
[(? natural?) (string->symbol (string-append "h:" (number->string type)))]))])
(loop type))))
(define handle? natural?)
;; Is there a better place for this?
(define foldr-case-lambda-vector
(lambda (f init rest-arg?s req-args argss exps)
(let* ([v-to-l (lambda (x) (if (list? x) (list->vector x) x))]
[rest-arg?s (v-to-l rest-arg?s)]
[req-args (v-to-l req-args)]
[argss (if (list? argss) (lol->vov argss) argss)]
[exps (v-to-l exps)]
[len (vector-length rest-arg?s)])
(let loop ([i 0])
(if (= i len) init
(f (vector-ref rest-arg?s i)
(vector-ref req-args i)
(vector-ref argss i)
(vector-ref exps i)
(loop (add1 i))))))))
)

269
collects/mrflow/util.ss
View File

@ -1,269 +0,0 @@
(module util (lib "mrflow.ss" "mrflow")
(require (prefix list: mzlib/list)
mzlib/pretty
mzlib/class
(prefix cst: "constants.ss"))
(provide (all-defined))
;;
;; Number functions
;;
(define natural? (lambda (n) (and (integer? n) (>= n 0))))
;;
;; List functions
;;
(define length-one?
(lambda (x) (and (pair? x) (null? (cdr x)))))
(define nonempty-list-of?
(lambda (p) (lambda (xs) (and (pair? xs) (andmap p xs)))))
(define unfold-onto
(lambda (p f g seed onto)
(if (p seed) onto
(cons (f seed) (unfold-onto p f g (g seed) onto)))))
(define unfold
(lambda (p f g seed)
(unfold-onto p f g seed '())))
;; int -> list int
(define iota
(lambda (n)
(unfold (lambda (x) (= x n)) (lambda (x) x) add1 0)))
(define min-list-numbers
(let ([remove-duplicates ;; remove duplicate numbers from a sorted list
(lambda (xs) ;; of numbers, returned list is reversed
(if (null? xs) '()
(let loop ((xs (cdr xs)) (acc (list (car xs))))
(if (null? xs) acc
(if (< (car xs) (car acc))
(loop (cdr xs) (cons (car xs) acc))
(loop (cdr xs) acc))))))])
(lambda (nums)
(remove-duplicates (list:sort nums >)))))
(define/contract lol->vov ((listof (listof any/c)) . -> . vector?)
(lambda (xss) (list->vector (map list->vector xss))))
(define map2deep
(lambda (f xss)
(map (lambda (xs) (map f xs)) xss)))
(define no-duplicates?/c
(flat-named-contract "List without duplicates"
(lambda (xs)
(let ([tbl (make-hash-table)])
(let/ec return-with
(for-each (lambda (x)
(when (hash-table-get tbl x cst:thunk-false)
(return-with #f))
(hash-table-put! tbl x #t))
xs)
#t)))))
;;
;; Vector functions
;;
(define foldr-vector
(lambda (f init v)
(let loop ([i 0])
(if (= i (vector-length v)) init
(f (vector-ref v i) (loop (add1 i)))))))
(define interval->list
(lambda (v lo hi)
(let loop ([i lo])
(if (= i hi) '()
(cons (vector-ref v i) (loop (add1 i)))))))
(define list->immutable-vector
(lambda xs
(apply vector-immutable xs)))
(define/contract map-vector ((any/c . -> . any) vector? . -> . vector?)
(lambda (f v)
(let* ([len (vector-length v)]
[new-v (make-vector len #f)])
(let loop ([i 0])
(when (< i len)
(vector-set! new-v i (f (vector-ref v i)))
(loop (add1 i))))
new-v)))
(define/contract map-vector-of-vector ((any/c . -> . any) (vectorof vector?) . -> . (vectorof vector?))
(lambda (f vov)
(map-vector (lambda (v) (map-vector f v)) vov)))
(define/contract for-each-vector ((any/c . -> . any) vector? . -> . void?)
(lambda (f v)
(let ([len (vector-length v)])
(let loop ([i 0])
(when (< i len)
(f (vector-ref v i))
(loop (add1 i)))))
cst:void))
; Replace each element e in a vector with (f e)
(define/contract for-each-vector! ((any/c . -> . any) vector? . -> . vector?)
(lambda (f v)
(let ([len (vector-length v)])
(let loop ([i 0])
(when (< i len)
(vector-set! v i (f (vector-ref v i)))
(loop (add1 i)))))
v))
(define/contract for-each-vov ((any/c . -> . any) (vectorof (vectorof any/c)) . -> . void?)
(lambda (f vov)
(for-each-vector (lambda (v) (for-each-vector f v) v) vov)))
; Replace each element in a vector of vectors with (f e)
(define/contract for-each-vov! ((any/c . -> . any) (vectorof (vectorof any/c)) . -> . any)
(lambda (f vov)
(for-each-vector! (lambda (v) (for-each-vector! f v) v) vov)
vov))
(define vector-of?
(lambda (pred v)
(let/ec escape
(let loop ([i 0])
(if (= i (vector-length v)) #t
(if (pred (vector-ref v i))
(loop (add1 i))
(escape #f)))))))
(define vector-of-vector-of?
(lambda (pred vov)
(vector-of? (lambda (v) (vector-of? pred v)) vov)))
(define vector-has?
(lambda (pred v)
(let/ec escape
(let loop ([i 0])
(if (= i (vector-length v)) #f
(if (pred (vector-ref v i))
(escape #t)
(loop (add1 i))))))))
(define vector-of-vector-has?
(lambda (pred vov)
(vector-has? (lambda (v) (vector-has? pred v)) vov)))
;;
;; Hash functions
;;
(define hash-table-size
(lambda (h)
(let ([size 0])
(hash-table-for-each h (lambda (_ _2) (set! size (add1 size))))
size)))
(define hash-table-empty?
(lambda (h)
(let/ec escape
(hash-table-for-each h (lambda (k v) (escape #f)))
#t)))
(define/contract hash-table-has-key? (hash-table? any/c . -> . boolean?)
(lambda (hash-table key)
(if (hash-table-get hash-table key cst:thunk-false) #t #f)))
;; (hash-table key (list value)) key value -> (hash-table key (list value))
(define/contract hash-table-prepend! (hash-table? any/c any/c . -> . any)
(lambda (hash-table key value)
(hash-table-put! hash-table key
(if (hash-table-has-key? hash-table key)
(cons value (hash-table-get hash-table key
(lambda () (error 'hash-table-prepend! "Could not prepend"))))
(list value)))))
;;
;; Function functions
;;
(define (curry f)
(lambda (x) (f x)))
;;
;; Boolean functions
;;
(define true?
(lambda (x) (eq? x #t)))
;;
;; Random functions
;;
(define/contract numberify-symbol (symbol? integer? . -> . symbol?)
(lambda (sym x)
(string->symbol (string-append (symbol->string sym) ":" (number->string x)))))
(define/contract numberify-list ((cons/c symbol? (listof any/c)) integer? . -> . (cons/c symbol? (listof any/c)))
(lambda (syms x)
(cons (numberify-symbol (car syms)) (cdr syms))))
(define/contract pretty-error (symbol? any/c . -> . any)
(lambda (sym v)
(let ([out (open-output-string)])
(pretty-print v out)
(error sym (get-output-string out)))))
(define andmap4-vector
(lambda (f v0 v1 v2 v3)
(let loop ([i 0])
(if (= i (vector-length v0)) #t
(and (f (vector-ref v0 i) (vector-ref v1 i) (vector-ref v2 i) (vector-ref v3 i))
(loop (add1 i)))))))
(define andmap2-vector-interval
(lambda (f v0 v1 lo high)
(let loop ([i lo])
(if (= i high) #t
(and (f (vector-ref v0 i) (vector-ref v1 i))
(loop (add1 i)))))))
(define andmap2-vector
(lambda (f v0 v1)
(andmap2-vector-interval f v0 v1 0 (vector-length v0))))
; return #t if the p(i) = # for all i in the half-open interval lo <= i < hi
(define andmap-vector-interval
(lambda (f v0 lo high)
(let loop ([i lo])
(if (= i high) #t
(and (f (vector-ref v0 i))
(loop (add1 i)))))))
(define andmap-vector
(lambda (f v0)
(andmap-vector-interval f v0 0 (vector-length v0))))
(define ormap4-vector
(lambda (f v0 v1 v2 v3)
(let loop ([i 0])
(if (= i (vector-length v0)) #f
(or (f (vector-ref v0 i) (vector-ref v1 i) (vector-ref v2 i) (vector-ref v3 i))
(loop (add1 i)))))))
;; Classes
(define counter%
(class object%
(init-field [start 0])
(define count start)
(define/public get
(lambda () count))
(define/public next!
(lambda () (set! count (add1 count)) count))
(super-new)))
)