#lang racket
(require plai/datatype)
(provide (all-from-out plai/datatype))
(provide (except-out (all-defined-out) stx-foo? stx-symbol=? binop-list stx-binop-pred))
(define stx-foo?
(lambda (predicate)
(lambda (candidate)
(and (syntax? candidate) (predicate (syntax->datum candidate))))))
(define stx-symbol=?
(lambda (sym)
(stx-foo? (lambda (c) (equal? c sym)))))
(define binop-list '(+ - * / < <= = >= > expt modulo and or))
(define stx-binop-pred
(lambda (sym)
(stx-foo? (lambda (c) (member c binop-list)))))
(define-type stage-1-parse
(stx-eof)
(stx-begin (defs/exprs (listof stage-1-parse?)))
(stx-num (val (stx-foo? number?)))
(stx-str (val (stx-foo? string?)))
(stx-char (val (stx-foo? char?)))
(stx-id (val (stx-foo? symbol?)))
(stx-return (kwd (stx-symbol=? 'return))
(expr stage-1-parse?))
(stx-binding (id stx-id?)
(eq (stx-symbol=? '=))
(expr stage-1-parse?))
(stx-struct (kwd (stx-symbol=? 'struct))
(id stx-id?)
(args (listof stx-id?)))
(stx-fun (kwd (stx-symbol=? 'fun)) (id stx-id?)
(args (listof stx-id?))
(colon (stx-symbol=? ':))
(body stage-1-parse?))
(stx-def (kwd (stx-symbol=? 'def)) (id stx-id?)
(args (listof stx-id?))
(colon (stx-symbol=? ':))
(body stage-1-parse?))
(stx-let (let-kwd (stx-symbol=? 'let)) (bindings (listof stx-binding?))
(in-kwd (stx-symbol=? 'in))
(colon (stx-symbol=? ':))
(body stage-1-parse?))
(stx-where (body stage-1-parse?) (kwd (stx-symbol=? 'where))
(bindings (listof stx-binding?)))
(stx-app (id stx-id?)
(args (listof stage-1-parse?)))
(stx-lst (lst (listof stage-1-parse?)))
(stx-bool (val (stx-foo? (lambda (b) (or (equal? b #t)
(equal? b #f))))))
(stx-neg (kwd (stx-symbol=? '-))
(expr stage-1-parse?))
(stx-binop (op stx-binop-pred)
(left stage-1-parse?)
(right stage-1-parse?))
(stx-not (kwd (stx-symbol=? 'not))
(expr stage-1-parse?))
(stx-if (kwd (stx-symbol=? 'if))
(test-expr stage-1-parse?)
(colon (stx-symbol=? ':))
(then-expr stage-1-parse?))
(stx-else (kwd (stx-symbol=? 'else))
(colon (stx-symbol=? ':))
(then-expr stage-1-parse?))
(stx-if-else (if-clause stx-if?)
(else-clause stx-else?))
(stx-elif (kwd (stx-symbol=? 'elif))
(test-expr stage-1-parse?)
(colon (stx-symbol=? ':))
(then-expr stage-1-parse?))
(stx-cond (if-clause stx-if?)
(elif-lst (listof stx-elif?))
(else-clause stx-else?)))