(module utilities mzscheme
(require (lib "etc.ss")
(lib "list.ss")
(lib "plt-match.ss")
(lib "class.ss")
(prefix fw: (lib "framework.ss" "framework"))
(lib "mred.ss" "mred")
(lib "errortrace.ss" "errortrace"))
(define voice-debug false)
(define (voice-printf . args)
(when voice-debug
(apply printf args)))
(provide print-current-stack-trace)
(define (print-current-stack-trace)
(with-handlers ([exn:fail?
(lambda (exn)
(print-error-trace (current-output-port) exn))])
(error 'print-current-stack-trace)))
(provide trim-whitespace-prefix)
(define (trim-whitespace-prefix text)
(let ([m (regexp-match " *(.*)" text)])
(if m
(second m)
text)))
(provide end-cons)
(define (end-cons l a)
(reverse (cons a (reverse l))))
(provide list-gcd)
(define (list-gcd lst)
(define ?
(lambda args
(if (empty? args)
true
(let* ([a (first args)]
[? (lambda (b) (equal? a b))])
(andmap ? (rest args))))))
(if (empty? lst)
empty
(let loop ([lst lst])
(if (ormap empty? lst)
empty
(let ([a (map first lst)]
[b (map rest lst)])
(if (apply ? a)
(cons (first a) (loop b))
empty))))))
(provide filter-double)
(define (filter-double xs)
(define ht (make-hash-table 'equal))
(define (seen? x)
(hash-table-get ht x (lambda () #f)))
(define (mark! x)
(hash-table-put! ht x #t))
(let loop ([xs xs])
(cond
[(empty? xs) '()]
[(seen? (first xs))
(loop (rest xs))]
[else
(mark! (first xs))
(cons (first xs) (loop (rest xs)))])))
(provide list-ref/safe)
(define (list-ref/safe lst i)
(if (and (>= i 0) (< i (length lst)))
(list-ref lst i)
(raise (make-voice-exn (format "there are only ~a matches" (length lst))))))
(provide line-index line-pos
line-end-index line-end-pos
line-text/index line-text/pos
line-number)
(define (line-index text index)
(let loop ([i 0]
[result 0])
(cond [(= i (string-length text))
result]
[(= i index)
result]
[(char=? #\newline (string-ref text i))
(loop (add1 i) (add1 i))]
[else
(loop (add1 i) result)])))
(define (line-pos text pos)
(index->pos (line-index text (pos->index pos))))
(define (line-end-index text index)
(let loop ([i index])
(cond
[(= i (string-length text)) i]
[(char=? (string-ref text i) #\newline) i]
[else
(loop (add1 i))])))
(define (line-end-pos text pos)
(index->pos (line-end-index text (pos->index pos))))
(define (line-text/index text index)
(substring text
(line-index text index)
(line-end-index text index)))
(define (line-text/pos text pos)
(line-text/index text (pos->index pos)))
(define (line-number text pos)
(let loop ([i 0]
[count 1])
(cond [(= i (pos->index pos))
count]
[(char=? (string-ref text i) #\newline)
(loop (add1 i) (add1 count))]
[else
(loop (add1 i) count)])))
(provide compute-new-start-index/insert
compute-new-end-index/insert
compute-new-selection/insert
compute-new-index/delete
compute-new-selection/delete
compute-new-selection/replace)
(define (compute-new-start-index/insert current-index insertion-index insertion-length)
(cond
[(< current-index insertion-index) current-index]
[else (+ current-index insertion-length)]))
(define (compute-new-end-index/insert current-index insertion-index insertion-length)
(cond
[(<= current-index insertion-index) current-index]
[else (+ current-index insertion-length)]))
(define (compute-new-selection/insert current-index current-length insertion-index insertion-length)
(let* ([new-index (compute-new-start-index/insert current-index insertion-index insertion-length)]
[new-end-index (compute-new-end-index/insert (+ current-index current-length) insertion-index insertion-length)])
(if (<= new-index new-end-index) (values new-index (- new-end-index new-index))
(values new-index 0))))
(define (compute-new-index/delete current-index deletion-index deletion-length)
(cond
[(< current-index deletion-index) current-index]
[(and (>= current-index deletion-index)
(<= current-index (+ deletion-index deletion-length))) deletion-index]
[else (- current-index deletion-length)]))
(define (compute-new-selection/delete current-index current-length deletion-index deletion-length)
(let* ([new-start-index (compute-new-index/delete current-index deletion-index deletion-length)]
[new-end-index (compute-new-index/delete (+ current-index current-length) deletion-index deletion-length)])
(values new-start-index (- new-end-index new-start-index))))
(define (compute-new-selection/replace current-index current-length replace-index deletion-length insertion-length)
(let-values ([(new-index new-length) (compute-new-selection/delete current-index current-length replace-index deletion-length)])
(compute-new-selection/insert new-index new-length replace-index insertion-length)))
(provide symbol/stx? prefix/string? prefix/symbol?)
(define (symbol/stx? stx)
(symbol? (syntax-e stx)))
(define ((prefix/symbol? a) b)
((prefix/string? (symbol->string a)) (symbol->string b)))
(define ((prefix/string? a) b)
(let ([a-len (string-length a)]
[b-len (string-length b)])
(and (<= a-len b-len)
(string=? a (substring b 0 a-len)))))
(provide syntax-begins-with/is-symbol? syntax-is-symbol? syntax-begins-with? identifier-match? tokenize-identifier)
(define ((syntax-begins-with/is-symbol? symbol) stx)
(or ((syntax-begins-with? symbol) stx)
((syntax-is-symbol? symbol) stx)))
(define ((syntax-is-symbol? symbol) stx)
(let ([stx-e (syntax-e stx)])
(and (atomic? stx-e)
(if (symbol? stx-e)
(identifier-match? symbol stx-e)
(eq? symbol (string->symbol (format (cond
[(string? stx-e) "\"~a\""]
[(char? stx-e) "#\\~a"]
[else "~a"]) stx-e)))))))
(define ((syntax-begins-with? symbol) stx)
(let ([lst (stx->lst stx)])
(and (not (empty? lst))
((syntax-is-symbol? symbol) (first lst)))))
(define (identifier-match? symbol element)
(or ((prefix/symbol? symbol) element)
(let ([tokens (tokenize-identifier (symbol->string element))])
(and (not (empty? tokens))
((prefix/string? (symbol->string symbol)) (first tokens))))))
(define (tokenize-identifier str)
(define (count pred lst)
(let loop ([lst lst])
(cond
[(empty? lst) 0]
[(pred (first lst)) (add1 (loop (rest lst)))]
[else 0])))
(let loop ([lst (string->list str)])
(cond
[(empty? lst) empty]
[else
(let* ([nb-alpha-char (count char-alphabetic? lst)]
[sub-alpha-str (substring (list->string lst) 0 nb-alpha-char)]
[lst (string->list (substring (list->string lst) nb-alpha-char (length lst)))]
[nb-non-alpha-char (count (lambda (a) (not (char-alphabetic? a))) lst)]
[lst (string->list (substring (list->string lst) nb-non-alpha-char (length lst)))])
(if (= 0 nb-alpha-char)
(loop lst)
(cons sub-alpha-str (loop lst))))])))
(provide get-clipboard-content set-clipboard-content)
(define (get-clipboard-content)
(send the-clipboard get-clipboard-string 0))
(define (set-clipboard-content text)
(when text
(send the-clipboard set-clipboard-string text 0)))
(provide print-mem)
(define (print-mem label thunk)
(thunk)
(let* ([a (current-memory-use)]
[_1 (collect-garbage)]
[b (current-memory-use)]
[result (call-with-values thunk (lambda args args))]
[c (current-memory-use)]
[_2 (collect-garbage)]
[d (current-memory-use)])
(printf "print-mem ~a: ~a ~a~n"
label
(round (/ (- a b) 1000))
(round (/ (- c d) 1000)))
(apply values result)))
(provide print-mem*)
(define-syntax (print-mem* stx)
(syntax-case stx ()
[(_ label e ...)
(syntax/loc stx
(print-mem label (lambda () e ...)))]))
(provide reverse-take)
(define (reverse-take lst n)
(let loop ([lst lst]
[n n]
[acc empty])
(cond
[(= n 0) acc]
[else
(loop (rest lst) (sub1 n) (cons (first lst) acc))])))
(provide map*)
(define (map* fn elts)
(define (fast-path lst n)
(cond
[(empty? lst) elts]
[else
(let ([result (fn (first lst))])
(cond
[(eq? result (first lst))
(fast-path (rest lst) (add1 n))]
[else (slow-path (rest lst)
(cons result (reverse-take elts n)))]))]))
(define (slow-path lst acc)
(cond
[(empty? lst) (reverse acc)]
[else
(slow-path (rest lst)
(cons (fn (first lst)) acc))]))
(fast-path elts 0))
(provide id)
(define (id x) x)
(provide or* atomic? atomic/stx? stx->lst gmap orgmap andgmap syntax-is-syntax? equal-syntax?)
(define (or* args)
(ormap id args))
(define (atomic? x)
(not (or (pair? x)
(list? x)
(vector? x))))
(define (atomic/stx? stx)
(atomic? (syntax-e stx)))
(define (stx->lst stx)
(match (syntax-e stx)
[(? atomic?) empty]
[(vector xs ...) xs]
[(list xs ...) xs]
[(list-rest lst ... last) (append lst (list last))]))
(define (gmap fn stx)
(map fn (stx->lst stx)))
(define (orgmap fn stx)
(ormap fn (stx->lst stx)))
(define (andgmap fn stx)
(andmap fn (stx->lst stx)))
(define ((syntax-is-syntax? stx) sty)
(equal-syntax? stx sty))
(define (equal-syntax? stx1 stx2)
(equal? (syntax-object->datum stx1) (syntax-object->datum stx2)))
(provide list-equal? syntax<-symbol)
(define (syntax<-symbol symbol)
#`#,symbol)
(define ((list-equal? equal?) l1 l2)
(with-handlers ([(lambda args true) (lambda args false)])
(andmap equal? l1 l2)))
(provide shape-paren)
(define (shape-paren type text)
(define (aux open close)
(format "~a~a~a" open (substring text 1 (sub1 (string-length text))) close))
(match type
[#f text]
['Round (aux #\( #\))]
['Square (aux #\[ #\])]
['Curly (aux #\{ #\})]))
(provide quoting-char?)
(define (quoting-char? ch)
(member ch (list #\` #\' #\, #\#)))
(provide file->string)
(define (file->string filename)
(define input false)
(dynamic-wind
(lambda () (set! input (open-input-file filename)))
(lambda () (list->string (let loop ([char (read-char input)])
(if (eof-object? char)
empty
(cons char (loop (read-char input)))))))
(lambda () (close-input-port input))))
(provide input->syntax-list string->syntax-list string->syntax)
(define (input->syntax-list input-port)
(let ([read-scheme-tree (lambda () (read-syntax 'voice:action:get-syntax input-port))])
(port-count-lines! input-port)
(with-handlers
([(lambda args true)
(lambda (exn)
(raise (make-voice-exn "The parenthesis of the definitions text are not correctly balanced.")))])
(let loop ([stx (read-scheme-tree)])
(if (eof-object? stx)
()
(cons stx (loop (read-scheme-tree))))))))
(define (string->syntax-list text)
(input->syntax-list (open-input-string text)))
(define (string->syntax text)
(match (string->syntax-list text)
[(list head tail ...) head]
[_ (raise (make-voice-exn "string->syntax: empty text"))]))
(provide syntax-first syntax-pos->index index->syntax-pos syntax-index syntax-end-position syntax-end-index pos->index index->pos syntax-position->mred-position mred-position->syntax-position)
(define syntax-first (syntax-position (string->syntax "a")))
(define (syntax-pos->index pos)
(- pos syntax-first))
(define (index->syntax-pos index)
(+ index syntax-first))
(define (syntax-index stx)
(syntax-pos->index (syntax-position stx)))
(define (syntax-end-position stx)
(+ (syntax-position stx)
(syntax-span stx)))
(define (syntax-end-index stx)
(syntax-pos->index (syntax-end-position stx)))
(define pos->index syntax-pos->index)
(define index->pos index->syntax-pos)
(define syntax-position->mred-position syntax-pos->index)
(define mred-position->syntax-position index->syntax-pos)
(provide insert-text delete-text replace-text get-subtext/pos+len get-subtext/stx)
(define (insert-text txt index tyt)
(format "~a~a~a" (substring txt 0 index)
tyt
(substring txt index (string-length txt))))
(define (delete-text txt index len)
(cond
[( = len 0) txt]
[(< len 0) (delete-text txt (- index len) (- len))]
[else
(format "~a~a" (substring txt 0 index)
(substring txt (+ index len) (string-length txt)))]))
(define (replace-text txt index tyt len)
(if (< len 0)
(replace-text txt (+ index len) tyt (- len))
(format "~a~a~a" (substring txt 0 index)
tyt
(substring txt (+ index len) (string-length txt)))))
(define (get-subtext/stx text stx)
(get-subtext/pos+len text (syntax-position stx) (syntax-span stx)))
(define (get-subtext/pos+len text pos len)
(if (<= 0 len)
(substring text
(syntax-pos->index pos)
(syntax-pos->index (+ pos len)))
(get-subtext/pos+len text (+ pos len) (- len))))
(provide make-voice-exn
voice-exn?
voice-exn-message)
(define (make-voice-exn text)
(list 'voice-exn text))
(define (voice-exn? exn)
(match exn
[(list 'voice-exn (? string? text)) true]
[_ false]))
(define (voice-exn-message exn)
(match exn
[(list 'voice-exn text) text]))
(define (make-voice-exn/world text world)
(list 'voice-exn/world text world))
(provide make-voice-exn/world
voice-exn/world?
voice-exn/world-message
voice-exn/world-world)
(define (voice-exn/world? exn)
(match exn
[(list 'voice-exn/world text world) true]
[_ false]))
(define (voice-exn/world-message exn)
(match exn
[(list 'voice-exn/world text world) text]))
(define (voice-exn/world-world exn)
(match exn
[(list 'voice-exn/world text world) world]))
(provide timef)
(define (timef label thunk)
(let-values ([(results cpu real gc)
(time-apply thunk empty)])
(printf "timef ~a: cpu ~a real ~a gc ~a~n" label cpu real gc)
(apply values results))))