Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
557 lines (449 sloc) 19.6 KB
(module utilities mzscheme
(require (lib "etc.ss")
(lib "list.ss")
(lib "plt-match.ss")
(lib "class.ss")
(lib "errortrace-lib.ss" "errortrace")
(lib "contract.ss")
"voice-exn.ss"
"rope.ss")
(provide (all-from "voice-exn.ss"))
(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 end-cons)
;; end-cons : ('a list) 'a -> ('a list)
(define (end-cons l a)
(reverse (cons a (reverse l))))
(provide list-gcd)
;; list-gcd : (('a list) list) -> ('a list)
(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 blank-string?)
;; blank-string? string -> boolean
;; Returns true if the string consists only of whitespace characters.
(define (blank-string? text)
(let loop ([i 0])
(cond
[(= i (string-length text))
#t]
[(char-whitespace? (string-ref text i))
(loop (add1 i))]
[else #f])))
;; alt/meta-prefix: string -> string
;; Given a string, constructs a key description appending
;; whatever system-specific control character describes meta.
(provide alt/meta-prefix)
(define (alt/meta-prefix str)
(format "~a~a" (case (system-type)
[(macosx macos) "d:"]
[(windows) "m:"]
[(unix) "m:"]
[else "m:"]) str))
(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)
;; list-ref/safe : ('a list) int -> 'a
;; Calls list-ref with error.
;; i can be negative because of back. We do not control the value.
(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 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)
;; compute-new-start-index/insert : index index non-negative-integer -> index
;; We want to compute the new index of the 'current-index' knowing
;; we are inserting a string of length 'insertion-length' at
;; index 'insertion-index'.
(define (compute-new-start-index/insert current-index insertion-index insertion-length)
(cond
[(< current-index insertion-index) current-index]
[else (+ current-index insertion-length)]))
;; compute-new-end-index/insert : index index non-negative-integer -> index
;; This function differs from the start one on the behavior
;; if the current-index is equal to the insertion-index,
;; and in this case the recult of compute-new-end-index can be lesser then compute-new-start-index, so becareful.
;; This should be understood in the context of inserting text in a selection.
(define (compute-new-end-index/insert current-index insertion-index insertion-length)
(cond
[(<= current-index insertion-index) current-index]
[else (+ current-index insertion-length)]))
;; compute-new-selection/insert : index non-negative-integer index non-negative-integer -> (index non-negative-integer values)
;; Given a selection and an inserting text, it returns the new selection.
(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) ; the false case only happens when current-index == insertion-index and current-length == 0
(values new-index (- new-end-index new-index))
(values new-index 0))))
;; compute-new-index/delete : index index non-negative-integer -> index
(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)]))
;; compute-new-selection/delete : index non-negative-integer index non-negative-integer -> (index non-negative-integer values)
(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))))
;; compute-new-selection/replace : index non-negative-integer index non-negative-integer non-negative-integer -> (index non-negative-integer values)
(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?)
;; symbol/stx? : syntax -> boolean
(define (symbol/stx? stx)
(symbol? (syntax-e stx)))
;; prefix/symbol? : symbol -> symbol -> boolean
(define ((prefix/symbol? a) b)
((prefix/string? (symbol->string a)) (symbol->string b)))
;; prefix/string? : string -> string -> boolean
(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)
;; syntax-begins-with/is-symbol? : symbol -> syntax -> boolean
(define ((syntax-begins-with/is-symbol? symbol) stx)
(or ((syntax-begins-with? symbol) stx)
((syntax-is-symbol? symbol) stx)))
;; syntax-is-symbol? : symbol -> syntax -> boolean
(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)))))))
;; syntax-begins-with? : symbol -> syntax -> boolean
(define ((syntax-begins-with? symbol) stx)
(let ([lst (stx->lst stx)])
(and (not (empty? lst))
((syntax-is-symbol? symbol) (first lst)))))
;; This function returns true if the first parameter matched the rule up given the second parameter.
;; identifier-match? : symbol symbol -> boolean
(define (identifier-match? symbol element)
(or ((prefix/symbol? symbol) element)
;;(and (member (symbol->string symbol) (tokenize-identifier (symbol->string element))) true)))
(let ([tokens (tokenize-identifier (symbol->string element))])
(and (not (empty? tokens))
((prefix/string? (symbol->string symbol)) (first tokens))))))
;; tokenize-identifier : string -> (string list)
(define (tokenize-identifier str)
;; count : (char -> boolean) (char list) -> non-negative-integer
(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))))])))
(define print-mem-labels '())
(provide print-mem)
(define (print-mem label thunk)
(thunk)
#; (begin
(set! print-mem-labels (cons label print-mem-labels))
(let* ([a (current-memory-use)]
[_1 (collect-garbage)]
[b (current-memory-use)]
[t1 (current-inexact-milliseconds)]
[result (call-with-values thunk (lambda args args))]
[t2 (current-inexact-milliseconds)]
[c (current-memory-use)]
[_2 (collect-garbage)]
[d (current-memory-use)])
(printf "PM ~a ms | ~a: GC pre ~a kb | GC post ~a kb~n"
(- t2 t1)
(reverse print-mem-labels)
(round (/ (- a b) 1000))
(round (/ (- c d) 1000)))
(set! print-mem-labels (rest print-mem-labels))
(apply values result))))
(provide print-time*)
(define-syntax (print-time* stx)
(syntax-case stx ()
[(_ label exprs ...)
(syntax/loc stx
(let* ([start-time (current-inexact-milliseconds)]
[result (call-with-values (lambda () exprs ...)
(lambda args args))])
(printf "~a: time ~a~n"
label
(- (current-inexact-milliseconds)
start-time))
(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)
;; reverse-take: (listof X) number -> (listof X)
;; Returns the first n elements of lst in reverse order.
(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*)
;; map*: (X -> Y) (listof X) -> (listof Y)
;; map, but with some care to avoid generating garbage.
(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)
;; id : 'a -> 'a
;; x -> y
(define (id x) x)
(provide or* atomic? atomic/stx? gmap orgmap andgmap syntax-is-syntax? equal-syntax?)
;; or* : ('a list) -> 'a
(define (or* args)
(ormap id args))
;; atomic? : any -> boolean
(define (atomic? x)
(not (or (pair? x)
(list? x)
(vector? x))))
;; atomic/stx? : syntax -> boolean
(define (atomic/stx? stx)
(atomic? (syntax-e stx)))
;; stx->lst : syntax -> (syntax list)
(provide/contract [stx->lst (syntax? . -> . (listof syntax?))])
(define (stx->lst stx)
(match (syntax-e stx)
[(? atomic?) empty]
[(vector xs ...) xs]
[(list xs ...) xs]
[(list-rest lst ... last) (append lst (list last))])) ; for things like '(a b c . d)
;; gmap : (syntax -> 'a) syntax -> ('a list)
(define (gmap fn stx)
(map fn (stx->lst stx)))
;; orgmap : (syntax -> 'a) syntax -> 'a
(define (orgmap fn stx)
(ormap fn (stx->lst stx)))
;; andgmap : (syntax -> 'a) syntax -> 'a
(define (andgmap fn stx)
(andmap fn (stx->lst stx)))
;; syntax-is-syntax? : syntax -> syntax -> boolean
(define ((syntax-is-syntax? stx) sty)
(equal-syntax? stx sty))
;; equal-syntax? : syntax syntax -> boolean
(define (equal-syntax? stx1 stx2)
(equal? (syntax-object->datum stx1) (syntax-object->datum stx2)))
(provide list-equal? syntax<-symbol)
;; syntax<-symbol : symbol -> syntax
(define (syntax<-symbol symbol)
#`#,symbol)
;; I need it to compare 2 lists of syntax object.
;; list-equal? : ('a 'a -> boolean) -> ('a list) ('a list) -> boolean
(define ((list-equal? equal?) l1 l2)
(with-handlers ([(lambda args true) (lambda args false)])
(andmap equal? l1 l2)))
;; This function converts the first element and the last element
;; into parenthesis, with form according to its parameter.
(provide shape-paren)
;; shape-paren : (union false 'Round 'Square 'Curly) string -> string
(define (shape-paren type text)
;; aux : char char -> string
(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?)
;; Returns true if the character appears to be a quoting char.
(define (quoting-char? ch)
(member ch (list #\` #\' #\, #\#)))
;; This function is to read the content of a file.
;; Use it for test ("engine.ss" of MzTake).
(provide file->string)
;; file -> string : string -> 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))))
;; These functions are to convert a string to Scheme tree,
;; with syntax objects.
(provide input->syntax-list string->syntax-list string->syntax)
;; input->syntax-list : input-port -> (syntax list)
(define (input->syntax-list input-port)
;(letrec ([read-scheme-tree (lambda () (with-handlers ([list (lambda args (read-scheme-tree))]) (read-syntax 'voice:action:get-syntax 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)
#;(printf "~s~n" 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))))))))
;; string->syntax-list : string -> (syntax list)
(define (string->syntax-list text)
(input->syntax-list (open-input-string text)))
;; string->syntax : string -> syntax
(define (string->syntax text)
(match (string->syntax-list text)
[(list head tail ...) head]
[_ (raise (make-voice-exn "string->syntax: empty text"))]))
;; Offset begins at 1 (syntax-first) for syntax object instead of 0.
(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)
;; This is from where the positions are counted in syntax-object.
(define syntax-first (syntax-position (string->syntax "a")))
(define (syntax-pos->index pos)
(- pos syntax-first))
(define (index->syntax-pos index)
(+ index syntax-first))
;; Accessor for syntax element in index instead of position.
(define (syntax-index stx)
(syntax-pos->index (syntax-position stx)))
;; Accessors for the end position/index of an syntax object.
(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)
;; Functions manipulating ropes.
(provide insert-rope delete-rope replace-rope get-subrope/pos+len get-subrope/stx)
;; insert-rope : rope index rope -> rope
(define (insert-rope a-rope index tyt)
(rope-append* (subrope a-rope 0 index)
tyt
(subrope a-rope index)))
;; delete-rope : rope index int -> rope
(define (delete-rope a-rope index len)
(cond
[( = len 0) a-rope]
[(< len 0) (delete-rope a-rope (- index len) (- len))]
[else
(rope-append (subrope a-rope 0 index) (subrope a-rope (+ index len)))]))
;; replace-rope : rope index rope int -> rope
(define (replace-rope a-rope index tyt len)
(print-mem*
'replace-text
(if (< len 0)
(replace-rope a-rope (+ index len) tyt (- len))
(rope-append* (subrope a-rope 0 index)
tyt
(subrope a-rope (+ index len))))))
;; get-subrope/stx : rope syntax -> rope
(define (get-subrope/stx a-rope stx)
(get-subrope/pos+len a-rope (syntax-position stx) (syntax-span stx)))
;; get-subrope/pos+len : rope pos integer -> rope
(define (get-subrope/pos+len a-rope pos len)
(if (<= 0 len)
(subrope a-rope
(syntax-pos->index pos)
(syntax-pos->index (+ pos len)))
(get-subrope/pos+len a-rope (+ pos len) (- len))))
;; get-mzcsheme-mapped-symbols: -> (listof symbol)
;; Returns the base symbols exposed by mzscheme.
(provide/contract [get-mzscheme-mapped-symbols
(-> (listof symbol?))])
(define (get-mzscheme-mapped-symbols)
(namespace-mapped-symbols (make-namespace)))
(provide/contract [string-convert-non-control-chars
(string? char? . -> . string?)])
(define (string-convert-non-control-chars a-str a-char)
(build-string
(string-length a-str)
(lambda (i)
(let ([ch (string-ref a-str i)])
(cond [(< (char->integer ch) 32)
ch]
[else a-char])))))
(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))))
Jump to Line
Something went wrong with that request. Please try again.