165 lines
5.3 KiB
Racket
165 lines
5.3 KiB
Racket
#lang racket/base
|
||
|
||
(require lang/private/rewrite-error-message)
|
||
|
||
;; -----------------------------------------------------------------------------
|
||
;; this module provides one-point functionality to report errors in teachpacks
|
||
|
||
;; -----------------------------------------------------------------------------
|
||
(provide check-arg
|
||
check-list-list
|
||
check-arity
|
||
check-proc
|
||
check-result
|
||
check-fun-res
|
||
check-color
|
||
check-dependencies
|
||
natural?
|
||
number->ord
|
||
find-non
|
||
tp-exn?
|
||
tp-error)
|
||
|
||
;; check-arg : sym bool str (or/c str non-negative-integer) TST -> void
|
||
(define (check-arg pname condition expected arg-posn given)
|
||
(unless condition
|
||
(tp-error pname "expects ~a as ~a argument, given ~e"
|
||
(add-article expected)
|
||
(spell-out arg-posn)
|
||
given)))
|
||
|
||
;; Symbol (union true String) String X -> void
|
||
(define (check-list-list pname condition pred given)
|
||
(when (string? condition)
|
||
(tp-error pname (string-append condition (format "\nin ~e" given)))))
|
||
|
||
;; check-arity : sym num (list-of TST) -> void
|
||
(define (check-arity name arg# args)
|
||
(unless (= (length args) arg#)
|
||
(tp-error name (argcount-error-message #f arg# (length args)))))
|
||
|
||
;; check-proc : sym (... *->* ...) num (union sym str) (union sym str) -> void
|
||
(define (check-proc name f exp-arity arg# arg-err)
|
||
(define arg#-text (if (number? arg#) (number->ord arg#) arg#))
|
||
(unless (procedure? f)
|
||
(tp-error name "expected a function as ~a argument; given ~e" arg#-text f))
|
||
(define arity-of-f (procedure-arity f))
|
||
(unless (procedure-arity-includes? f exp-arity)
|
||
(tp-error name "expected function of ~a as ~a argument; given function of ~a "
|
||
arg-err arg#-text
|
||
(cond
|
||
[(number? arity-of-f)
|
||
(if (= arity-of-f 1)
|
||
(format "1 argument")
|
||
(format "~s arguments" arity-of-f))]
|
||
[(arity-at-least? arity-of-f) "variable number of arguments"]
|
||
[else (format "multiple arities (~s)" arity-of-f)]))))
|
||
|
||
;; Symbol (_ -> Boolean) String X X *-> X
|
||
(define (check-result pname pred? expected given . other-given)
|
||
(if (pred? given)
|
||
given
|
||
(tp-error pname "is expected to return ~a, but it returned ~v"
|
||
(add-article expected)
|
||
(if (pair? other-given)
|
||
(car other-given)
|
||
given))))
|
||
|
||
;; check-color : symbol (or/c str non-negative-integer) TST -> void
|
||
(define (check-color pname arg-pos given)
|
||
(check-arg pname
|
||
(or (string? given)
|
||
(symbol? given))
|
||
'color
|
||
arg-pos given)
|
||
;; this would be good to check, but it isn't possible, since this
|
||
;; file is not allowed to rely on mred.
|
||
;; also nice would be to allow color% objects here, but that's
|
||
;; not possible for the same reason (but that is why
|
||
;; the '[else color]' case is below in the cond.
|
||
#;
|
||
(let ([color
|
||
(cond
|
||
[(symbol? given)
|
||
(send the-color-database find-color (symbol->string given))]
|
||
[(string? given)
|
||
(send the-color-database find-color given)]
|
||
[else given])])
|
||
(unless color
|
||
(tp-error pname
|
||
"expected the name ~e to be a color, but did not recognize it"
|
||
given))))
|
||
|
||
;; (: check-fun-res (∀ (γ) (∀ (β α ...) (α ...α -> β)) (_ -γ-> boolean) _ -> γ))
|
||
(define (check-fun-res f pred? type)
|
||
(lambda x
|
||
(check-result (object-name f) pred? type (apply f x))))
|
||
|
||
;; check-dependencies : Symbol x Boolean x FormatString x Any* -> Void
|
||
(define (check-dependencies pname condition fmt . args)
|
||
(unless condition
|
||
(tp-error pname (apply format fmt args))))
|
||
|
||
(define-struct (tp-exn exn) ())
|
||
|
||
(define (tp-error name fmt . args)
|
||
(raise
|
||
(make-exn:fail:contract
|
||
(string-append (format "~a: " name) (apply format fmt args))
|
||
(current-continuation-marks))))
|
||
|
||
(define (number->ord i)
|
||
(if (= i 0)
|
||
"zeroth"
|
||
(case (modulo i 10)
|
||
[(0 4 5 6 7 8 9) (format "~ath" i)]
|
||
[(1) (format "~ast" i)]
|
||
[(2) (format "~and" i)]
|
||
[(3) (format "~ard" i)])))
|
||
|
||
;; (_ -> Boolean) (listof X) -> (union X false)
|
||
;; (not (find-non list? '((1 2 3) (a b c))))
|
||
;; (symbol? (find-non number? '(1 2 3 a)))
|
||
;; (symbol? (find-non list? '((1 2 3) a (b c))))
|
||
(define (find-non pred? l)
|
||
(let ([r (filter (compose not pred?) l)])
|
||
(if (null? r) #f (car r))))
|
||
|
||
(define (natural? w)
|
||
(and (number? w) (integer? w) (>= w 0)))
|
||
|
||
;; add-article : anything -> string
|
||
;; (add-article 'color) should be "a color"
|
||
;; (add-article 'acronym) should be "an acronym"
|
||
(define (add-article thing)
|
||
(let ((s (format "~a" thing)))
|
||
(string-append
|
||
(if (starts-with-vowel? s)
|
||
"an "
|
||
"a ")
|
||
s)))
|
||
|
||
;; starts-with-vowel? : string -> boolean
|
||
(define (starts-with-vowel? s)
|
||
(and
|
||
(not (string=? s ""))
|
||
(member (string-ref s 0) (list #\a #\e #\i #\o #\u))))
|
||
|
||
;; spell-out : number-or-string -> string
|
||
(define (spell-out arg-posn)
|
||
(cond
|
||
[(string? arg-posn) arg-posn]
|
||
[(number? arg-posn)
|
||
(case arg-posn
|
||
[(1) "first"]
|
||
[(2) "second"]
|
||
[(3) "third"]
|
||
[(4) "fourth"]
|
||
[(5) "fifth"]
|
||
[(6) "sixth"]
|
||
[(7) "seventh"]
|
||
[(8) "eighth"]
|
||
[(9) "ninth"]
|
||
[(10) "tenth"]
|
||
[else (number->ord arg-posn)])]))
|