You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
207 lines
8.8 KiB
Racket
207 lines
8.8 KiB
Racket
#lang racket/base
|
|
|
|
(module+ test
|
|
|
|
(require yaragg/rules/stx-types
|
|
yaragg/codegen/flatten
|
|
rackunit)
|
|
|
|
|
|
(define (make-fresh-name)
|
|
(let ([n 0])
|
|
(lambda ()
|
|
(set! n (add1 n))
|
|
(string->symbol (format "r~a" n)))))
|
|
|
|
|
|
;; Simple literals
|
|
(check-equal? (map syntax->datum (flatten-rule #'(rule expr (lit "hello"))))
|
|
'((prim-rule lit expr [(lit "hello")])))
|
|
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule expr
|
|
(seq (lit "hello")
|
|
(lit "world")))))
|
|
'((prim-rule seq expr [(lit "hello") (lit "world")])))
|
|
|
|
|
|
(check-equal? (map syntax->datum (flatten-rule #'(rule expr (token HELLO))))
|
|
'((prim-rule token expr [(token HELLO)])))
|
|
|
|
(check-equal? (map syntax->datum (flatten-rule #'(rule expr (id rule-2))))
|
|
'((prim-rule id expr [(id rule-2)])))
|
|
|
|
|
|
;; Sequences of primitives
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule expr (seq (lit "1") (seq (lit "2") (lit "3"))))))
|
|
'((prim-rule seq expr
|
|
[(lit "1") (lit "2") (lit "3")])))
|
|
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule expr (seq (seq (lit "1") (lit "2")) (lit "3")))))
|
|
'((prim-rule seq expr
|
|
[(lit "1") (lit "2") (lit "3")])))
|
|
|
|
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule expr (seq (seq (lit "1")) (seq (lit "2") (lit "3"))))))
|
|
'((prim-rule seq expr
|
|
[(lit "1") (lit "2") (lit "3")])))
|
|
|
|
|
|
|
|
;; choices
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule expr (choice (id rule-2) (id rule-3)))))
|
|
'((prim-rule choice expr
|
|
[(id rule-2)]
|
|
[(id rule-3)])))
|
|
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule sexp (choice (seq (lit "(") (lit ")"))
|
|
(seq)))
|
|
#:fresh-name (make-fresh-name)))
|
|
'((prim-rule choice sexp
|
|
[(lit "(") (lit ")")] [])))
|
|
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule sexp (choice (seq (seq (lit "(") (token BLAH))
|
|
(lit ")"))
|
|
(seq)))
|
|
#:fresh-name (make-fresh-name)))
|
|
'((prim-rule choice sexp
|
|
[(lit "(") (token BLAH) (lit ")")] [])))
|
|
|
|
|
|
|
|
|
|
;; maybe
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule expr (maybe (id rule-2)))))
|
|
'((prim-rule maybe expr
|
|
[(id rule-2)]
|
|
[])))
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule expr (maybe (token HUH)))))
|
|
'((prim-rule maybe expr
|
|
[(token HUH)]
|
|
[])))
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule expr (maybe (seq (lit "hello") (lit "world"))))))
|
|
'((prim-rule maybe expr
|
|
[(lit "hello") (lit "world")]
|
|
[])))
|
|
|
|
|
|
|
|
|
|
;; repeat
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule rule-2+ (repeat 0 #f (id rule-2)))))
|
|
'((prim-rule maybe rule-2+ ((inferred-id %rule1 repeat)) ())
|
|
(inferred-prim-rule repeat %rule1
|
|
((inferred-id %rule1 repeat) (id rule-2))
|
|
((id rule-2)))))
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule rule-2+ (repeat 0 #f (seq (lit "+") (id rule-2))))))
|
|
'((prim-rule maybe rule-2+ ((inferred-id %rule2 repeat)) ())
|
|
(inferred-prim-rule repeat %rule2
|
|
((inferred-id %rule2 repeat) (lit "+") (id rule-2))
|
|
((lit "+") (id rule-2)))))
|
|
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule rule-2+ (repeat 1 #f (id rule-2)))))
|
|
'((prim-rule repeat rule-2+
|
|
[(inferred-id rule-2+ repeat) (id rule-2)]
|
|
[(id rule-2)])))
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule rule-2+ (repeat 1 #f (seq (lit "-") (id rule-2))))))
|
|
'((prim-rule repeat rule-2+
|
|
[(inferred-id rule-2+ repeat) (lit "-") (id rule-2)]
|
|
[(lit "-") (id rule-2)])))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; Mixtures
|
|
|
|
;; choice and maybe
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule sexp (choice (lit "x")
|
|
(maybe (lit "y"))))
|
|
#:fresh-name (make-fresh-name)))
|
|
'((prim-rule choice sexp
|
|
[(lit "x")]
|
|
[(inferred-id r1 maybe)])
|
|
(inferred-prim-rule maybe r1
|
|
[(lit "y")]
|
|
[])))
|
|
;; choice, maybe, repeat
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule sexp (choice (lit "x")
|
|
(maybe (repeat 1 #f (lit "y")))))
|
|
#:fresh-name (make-fresh-name)))
|
|
'((prim-rule choice sexp
|
|
[(lit "x")]
|
|
[(inferred-id r1 maybe)])
|
|
(inferred-prim-rule maybe r1
|
|
[(inferred-id r2 repeat)]
|
|
[])
|
|
(inferred-prim-rule repeat r2
|
|
[(inferred-id r2 repeat) (lit "y")]
|
|
[(lit "y")])))
|
|
;; choice, seq
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule sexp (choice (seq (lit "x") (lit "y"))
|
|
(seq (lit "z") (lit "w"))))
|
|
#:fresh-name (make-fresh-name)))
|
|
'((prim-rule choice sexp
|
|
[(lit "x") (lit "y")]
|
|
[(lit "z") (lit "w")])))
|
|
|
|
;; maybe, choice
|
|
(check-equal? (map syntax->datum
|
|
(flatten-rule #'(rule sexp (maybe (choice (seq (lit "x") (lit "y"))
|
|
(seq (lit "z") (lit "w")))))
|
|
#:fresh-name (make-fresh-name)))
|
|
'((prim-rule maybe sexp
|
|
[(inferred-id r1 choice)]
|
|
[])
|
|
(inferred-prim-rule choice r1
|
|
[(lit "x") (lit "y")]
|
|
[(lit "z") (lit "w")])))
|
|
|
|
|
|
(test-case "seq, repeat"
|
|
(define rule-stx #'(rule expr (seq (id term) (repeat 0 #f (seq (lit "+") (id term))))))
|
|
(check-equal? (map syntax->datum (flatten-rule rule-stx #:fresh-name (make-fresh-name)))
|
|
'((prim-rule seq expr ((id term) (inferred-id r1 repeat)))
|
|
(prim-rule maybe r1 ((inferred-id r2 repeat)) ())
|
|
(inferred-prim-rule repeat r2
|
|
((inferred-id r2 repeat) (lit "+") (id term))
|
|
((lit "+") (id term))))))
|
|
|
|
|
|
(test-case "larger example: simple arithmetic"
|
|
(define rule-stxs
|
|
(syntax->list
|
|
#'((rule expr (seq (id term) (repeat 0 #f (seq (lit "+") (id term)))))
|
|
(rule term (seq (id factor) (repeat 0 #f (seq (lit "*") (id factor)))))
|
|
(rule factor (token INT)))))
|
|
(check-equal? (map syntax->datum (flatten-rules rule-stxs #:fresh-name (make-fresh-name)))
|
|
|
|
'((prim-rule seq expr ((id term) (inferred-id r1 repeat)))
|
|
(prim-rule maybe r1 ((inferred-id r2 repeat)) ())
|
|
(inferred-prim-rule repeat r2
|
|
((inferred-id r2 repeat) (lit "+") (id term))
|
|
((lit "+") (id term)))
|
|
(prim-rule seq term ((id factor) (inferred-id r3 repeat)))
|
|
(prim-rule maybe r3 ((inferred-id r4 repeat)) ())
|
|
(inferred-prim-rule repeat r4
|
|
((inferred-id r4 repeat) (lit "*") (id factor))
|
|
((lit "*") (id factor)))
|
|
(prim-rule token factor ((token INT)))))))
|