diff --git a/test/define-pass.rkt b/test/define-pass.rkt index 69cc4fb..672fa4a 100644 --- a/test/define-pass.rkt +++ b/test/define-pass.rkt @@ -8,13 +8,13 @@ trivial/vector) (module+ test - (require typed/rackunit) + (require typed/rackunit typed/racket/class) (check-equal? (let () - (define: n 3) + (define: n 3) ;; TODO define is broken (let: ([m n]) - (ann (-: n m) Zero))) + (ann (-: m n) Zero))) 0) (check-equal? @@ -35,4 +35,20 @@ [ys '(4 3 1)]) (map: f xs ys))) '("hello(hi) and 100" "hello(hi) and 11" "hello(HI) and 1")) + + ;; Should be okay with "Indiana-style" defines + (let () + (define fact : (-> Integer Integer) + (lambda (n) + (if (< n 2) 1 (* n (fact (- n 1)))))) + (check-equal? (fact 5) 120)) + + ;; Also with classes + (let () + (define f% : (Rec t (Class (yolo (-> (Instance t))))) + (class object% + (super-new) + (define/public (yolo) + (new f%)))) + (check-false (not (new f%)))) ) diff --git a/trivial/private/common.rkt b/trivial/private/common.rkt index 8a7427c..11fac4c 100644 --- a/trivial/private/common.rkt +++ b/trivial/private/common.rkt @@ -47,8 +47,11 @@ #:attr evidence #'p+ #:attr expanded #'e+))) +(define-syntax-rule (log stx msg arg* ...) + (begin (printf "[LOG:~a:~a] " (syntax-line stx) (syntax-column stx)) (printf msg arg* ...) (newline))) + (define (expand-expr stx) - (local-expand stx 'expression '())) + (local-expand stx 'expression (*STOP-LIST*))) (define (quoted-stx-value? stx) (and @@ -94,11 +97,15 @@ (lambda (stx) (syntax-parse stx #:literals (tr:#%plain-lambda) [(_ name:id v) - #:with (tr:#%plain-lambda (_) v+) (expand-expr (syntax/loc stx (tr:lambda (name) v))) + #:with (tr:#%plain-lambda (_) v+) + (parameterize ([*STOP-LIST* (cons #'name (*STOP-LIST*))]) + (expand-expr (syntax/loc stx (tr:lambda (name) v)))) #:when (syntax-e (syntax/loc stx v+)) #:with m (f-parse (syntax/loc stx v+)) #:when (syntax-e (syntax/loc stx m)) (free-id-table-set! tbl #'name (syntax-e #'m)) + (when (*TRIVIAL-LOG*) + (log stx "define ~a" sym)) (syntax/loc stx (tr:define name v+))] [_ #f]))) @@ -109,6 +116,8 @@ #:with (v+* ...) (map expand-expr (syntax-e (syntax/loc stx (v* ...)))) #:with (m* ...) (map f-parse (syntax-e (syntax/loc stx (v+* ...)))) #:when (andmap syntax-e (syntax-e (syntax/loc stx (m* ...)))) + (when (*TRIVIAL-LOG*) + (log stx "let ~a" sym)) (quasisyntax/loc stx (tr:let ([name* v+*] ...) (tr:let-syntax ([name* (make-rename-transformer @@ -125,7 +134,7 @@ (cond [(parser stx) => (lambda (r) - (when (*TRIVIAL-LOG*) (printf "[LOG] alias ~a\n" (syntax->datum id-stx))) + (when (*TRIVIAL-LOG*) (log stx "alias ~a" (syntax->datum id-stx))) r)] [else (syntax-parse stx @@ -136,17 +145,14 @@ #`(app-stx #,id-stx e* ...)])])) (define ((make-keyword-alias id-sym parser) stx) - (cond - [(parser stx) - => (lambda (r) - (when (*TRIVIAL-LOG*) (printf "[LOG] keyword ~a\n" id-sym)) - r)] - [else - (syntax-parse stx - [(_ e* ...) - #:with id-stx (case id-sym - [(define) #'tr:define] - [(let) #'tr:let] - [(set!) #'tr:set!] - [else (error 'trivial "Unknown keyword '~a'" id-sym)]) - (syntax/loc stx (id-stx e* ...))])])) + (or (with-handlers ((exn:fail? (lambda (e) #f))) (parser stx)) + ;; 2016-06-08: sometimes parser raises error ... i.e. "unbound local member name" + (parser stx) + (syntax-parse stx + [(_ e* ...) + #:with id-stx (case id-sym + [(define) #'tr:define] + [(let) #'tr:let] + [(set!) #'tr:set!] + [else (error 'trivial "Unknown keyword '~a'" id-sym)]) + (syntax/loc stx (id-stx e* ...))]))) diff --git a/trivial/private/parameters.rkt b/trivial/private/parameters.rkt index 4ce496c..37bab4c 100644 --- a/trivial/private/parameters.rkt +++ b/trivial/private/parameters.rkt @@ -2,10 +2,18 @@ (provide *TRIVIAL-LOG* + *STOP-LIST* + set-trivial-print ) ;; ============================================================================= (: *TRIVIAL-LOG* (Parameterof Boolean)) -(define *TRIVIAL-LOG* (make-parameter #f)) +(define *TRIVIAL-LOG* (make-parameter #t)) +(: *STOP-LIST* (Parameterof (Listof Identifier))) +(define *STOP-LIST* (make-parameter '())) + +(define (set-trivial-print) + (*TRIVIAL-LOG* #t) + (void)) diff --git a/trivial/private/raco-command.rkt b/trivial/private/raco-command.rkt index b6d8816..a0d7dad 100644 --- a/trivial/private/raco-command.rkt +++ b/trivial/private/raco-command.rkt @@ -21,7 +21,7 @@ ;; ============================================================================= -(define TRIVIAL-LOG-PREFIX "[LOG]") +(define TRIVIAL-LOG-PREFIX "[LOG") (define *ANNIHILATE* (make-parameter #f)) diff --git a/trivial/private/vector.rkt b/trivial/private/vector.rkt index ba8a8b5..96e9319 100644 --- a/trivial/private/vector.rkt +++ b/trivial/private/vector.rkt @@ -1,5 +1,8 @@ #lang typed/racket/base +;; TODO: +;; - use unsafe-vector* operations? (will we ever have an impersonator? not yet) + (provide define-vector: let-vector: