Hello Racketeers,
I'm getting back into racket/plt-sheme after years away from it (and
programming in general). I'm warming back up by updating Jacob Matthews'
Quasistring module to Racket. I may have bit off a bit too much as I've run out
of ideas for fixing a bug.
I've updated function names and calling conventions. Due to the bug, I've
simplified this to a top level program (which may have been a mistake, though I
wouldn't know why).
Using both the debugger and the Macro Stepper have failed me. I've gotten
feedback that makes me think that I've got a contract violation, but he error
happens very early, before the expansion of the macro call. I'm rather
mystified by both the bug and the proper way to debug it.
The error is:
string-length: expects argument of type <string>; given #"\0"
There is one instance of this call in the program, so it is easy to know that
the early fail is not due to either expansion or execution of this code. What
else could it be and how do I fix it?
Thanks very much,
Lewis
-----------------------------------------------------------------------------------------
#lang racket
(define current-quasistring-converter (make-parameter display))
(define (to-string v)
(let ((p (open-output-string)))
(parameterize ((current-output-port p))
((current-quasistring-converter) v))
(begin0
(get-output-string p)
(close-output-port p))))
(define-syntax (qs stx)
; rewrite : syntax[string] -> syntax
; rewrites a quasistring syntax string into an expression that
; evaluates to the proper string
(define (rewrite val)
; start -> syntax
; the main function rewrite calls.
; [Implementation detail: we know string->strings-and-syntax returns >= 1
object.
; If it returns only one, we don't want to call string-append, because
it could
; make strings that were eq? into strings that aren't eq?.]
(define (start)
(let ((exprs (string->strings-and-syntax (syntax-e val))))
(if (pair? (cdr exprs))
#`(string-append #,@exprs)
#`(#%datum . #,(car exprs)))))
; add-lexical-context : syntax -> syntax
; produces a syntax object with structure and source locations equal to
the argument
; but with all subexpressions having lexical context of stx, the syntax
object that
; this macro accepts as input
(define (add-lexical-context stx-to-enrich)
(define (add-lexical-context/slist sl)
(cond
[(pair? sl) (cons (add-lexical-context (car sl))
(add-lexical-context/slist (cdr sl)))]
[(null? sl) null]
[else (add-lexical-context sl)]))
(let ([s (syntax-e stx-to-enrich)])
(cond
[(pair? s)
(quasisyntax/loc stx-to-enrich #,(add-lexical-context/slist s))]
[(null? s) stx-to-enrich]
[else (datum->syntax val s stx-to-enrich stx-to-enrich)])))
; extra-width : char -> nat
; returns a guess at the number of characters needed to represent the
given
; character on the screen. This number is just a guess!
(define (width c)
(define (char-typable? c)
(let ((n (char->integer c)))
(and (>= n 32) (<= n 127))))
(cond
[(memq c (map integer->char '(7 8 9 10 11 12 13 27 92))) 1]
[(char-typable? c) 0]
; this is just a guess. 3 is either a 3-octet or 2-hextet
representation,
; so I choose it.
[else 3]))
; fresh-port : ip (box num) -> ip
; makes a new port that just forwards to the original port
(define (monitored-port p box)
(make-input-port 'monitored
(lambda (s)
(let ((len (a s)))
(let loop ((idx 0))
(cond
[(and (< idx len) (char-ready? p))
(let ((c (read-char p)))
(if (eof-object? c)
(if (= idx 0) eof idx)
(begin
(string-set! s idx c)
(set-box! box (+ (unbox box) (width c)))
(loop (add1 idx)))))]
[else idx]))))
#f
void))
; port->syntaxes : input-port -> (listof syntax)
(define (port->syntaxes ip)
(define offset (box 0))
(define p (monitored-port ip offset))
(define (port->syntaxes/str acc-str)
(define (curr-string) (datum->syntax val (list->string (reverse
acc-str))))
(let ((c (read-char p)))
(cond
[(eof-object? c) (list (curr-string))]
[(eq? c #\$) (cons (curr-string) (port->syntaxes/expr))]
[(eq? c #\\) (port->syntaxes/escape acc-str)]
[else (port->syntaxes/str (cons c acc-str))])))
(define (port->syntaxes/escape acc-str)
(define (curr-string) (datum->syntax val (list->string (reverse (cons
#\\ acc-str)))))
(let ((c (read-char p)))
(cond
[(eof-object? c) (list (curr-string))]
[(eq? c #\$) (port->syntaxes/str (cons #\$ acc-str))]
[else (port->syntaxes/str (list* c #\\ acc-str))])))
(define (port->syntaxes/expr)
(with-handlers
([exn:fail:read?
(lambda (e)
(let* ((srclocs (exn:fail:read-srclocs))
(srcloc (car srclocs)))
raise-syntax-error
#f
"bad expression inside quasistring"
stx
(datum->syntax val
(syntax-e val)
(list
(srcloc-source e)
(srcloc-line e)
(srcloc-column e)
(+ (syntax-position val)
(- (srcloc-position e) (syntax-position
stx)))
(srcloc-span e))
#f)))])
(let* ([string-expr
(read-syntax (syntax-source val)
p
(if (and (syntax-line val) (syntax-column val)
(syntax-position val))
(list (syntax-line val)
(syntax-column val)
(+ (syntax-position val) (unbox
offset)))
(list 0 0 0)))])
(if (eof-object? string-expr)
(raise-syntax-error #f "no expression follows quasistring
delimiter" stx)
(cons
#`(to-string #,(add-lexical-context string-expr))
(port->syntaxes/str '()))))))
(port->syntaxes/str '()))
; string->strings-and-syntax : string -> listof syntax
; given a string, produces a list of syntax objects that when evaluated
; produce strings that can be appended to produce the equivalent
quasistring value
(define (string->strings-and-syntax str)
(let ((p (open-input-string str)))
(port-count-lines! p)
(port->syntaxes p)))
(start))
(syntax-case stx ()
[(_ s)
(string? (syntax-e #'s))
(rewrite #'s)]
[_ (raise-syntax-error
#f
"not a string"
stx)]))
(define b "Bob")
(qs "$b's your uncle.")
_________________________________________________
For list-related administrative tasks:
http://lists.racket-lang.org/listinfo/users
