bsl/form-1.rkt
#lang racket

;; file: form-1.rkt
;; author: Bill Turtle
;;
;; The syntax after stage 1 of the parse.

(require plai/datatype)
(provide (all-from-out plai/datatype))

(provide (except-out (all-defined-out) stx-foo? stx-symbol=? binop-list stx-binop-pred))
         

;; stx-foo?: ((any -> bool) -> any -> bool)
;;
;; When giving predicates to our stage-1-parse type, we always want
;; the fields to be syntax objects, but sometimes we want to know
;; more about the value inside of that syntax object. This curried
;; function provides a concise and convenient way to create such
;; two-handled predicates.
(define stx-foo?
  (lambda (predicate)
    (lambda (candidate)
      (and (syntax? candidate) (predicate (syntax->datum candidate))))))

;; stx-symbol=? : (symbol -> any -> bool)
;;
;; For when we want a syntax-object with a specific symbol value
(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)) ; e.g. fun idty(x): x
           (id stx-id?)
           (args (listof stx-id?))
           (colon (stx-symbol=? ':))
           (body stage-1-parse?))
  (stx-def (kwd (stx-symbol=? 'def)) ; e.g. def idty(x): x
           (id stx-id?)
           (args (listof stx-id?))
           (colon (stx-symbol=? ':))
           (body stage-1-parse?))
  (stx-let (let-kwd (stx-symbol=? 'let)) ; e.g. let x = y + z in: x
           (bindings (listof stx-binding?))
           (in-kwd (stx-symbol=? 'in))
           (colon (stx-symbol=? ':))
           (body stage-1-parse?))
  (stx-where (body stage-1-parse?) ; e.g. x where x = y + z
             (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?)))