;; Datum grammar acceptors - Examples.

;; Copyright (c) 2007 David Van Horn
;; Licensed under the Academic Free License version 3.0

;; <>

(module grammar-examples mzscheme
  (provide (rename exp? eopl-section-5.5-exp?)    ;; Probably 1st ed.?
           (rename scheme? r4rs-scheme?)          ;; BUGS: Known issue with this predicate.
  (require "")
  (define exp?
    (grammar expression
        (lambda (x)
          (and (symbol? x)
               (not (memq x '(quote if lambda let set!)))))))
      (literal (predicate number?))
      (datum (predicate (lambda (x) #t)))
      (declaration (lst variable expression))
       (predicate;; this could have been (lst (plus expression))
        (lambda (x);; but then a spurious bad keyword is reported
          (and (pair? x)	    
               (not (and (symbol? (car x)) (not (variable x))))
               (not (boolean? ((plus expression) x)))))))
       (report-if-bad 'expression
                      (alt variable literal procedure-call
                           (lst 'quote datum)
                           (lst 'lambda (lst (star variable)) expression)
                           (lst 'if expression expression expression)
                           (lst 'set! variable expression)
                           (lst 'let (lst (star declaration)) expression))))))
  (define grammar?
    (grammar grammar-expression
      (datum (predicate (lambda (x) #t)))
      (expression datum)
       (report-if-bad 'grammar-expression
                      (lst 'grammar start (plus production))))
      (start variable)
      (variable (predicate symbol?))
      (production (report-if-bad 'production (lst variable (star element))))
      (element (alt terminal non-terminal))
      (terminal (lst 'quote datum))
       (report-if-bad 'non-terminal
                      (alt variable
                           (lst 'alt (star element))
                           (lst 'seq (star element))
                           (lst 'lst (star element))
                           (lst 'star element)
                           (lst 'plus element)
                           (lst 'opt element)
                           (lst 'dot element element)
                           (lst 'predicate expression)
                           (lst 'cfa expression)
                           (lst 'report-if-bad datum non-terminal))))))
  ;; With small fixes:
  ;;   - added production for string
  ;;   - used <---> naming convention for non-terminals.  This prevents
  ;;     problems with non-terminal names like "list".
  (define scheme? 
    (grammar <command-or-definition>
      ;; needed from section 7.1.1
       (alt 'quote 'lambda 'if 'set! 'begin 'cond 'and 'or 'case 'let 'let*
            'letrec 'do 'delay 'quasiquote))
        (lambda (x)
          (and (symbol? x)
               (not (<expression-keyword> (list x)))))))
      (<number>    (predicate number?))
      (<boolean>   (predicate boolean?))
      (<character> (predicate char?))
      (<string>    (predicate string?))               ; dvh
      ;; section 7.1.2, w/o abbreviations
      ;; could use simply (datum (predicate (lambda (x) #t)))
      (<datum> (alt <simple-datum> <compound-datum>))
       (alt <symbol>
             (lambda (x)
               (or (boolean? x) (number? x) (char? x) (string? x))))))
      (<symbol> (predicate symbol?))
      (<compound-datum> (alt <list> <vector>))
      (<list> (alt (lst (star <datum>)) (dot (plus <datum>) <datum>)))
      (<vector> (predicate
                 (lambda (x)
                   (and (vector? x)
                        ((star <datum>) (vector->list x))))))
      ;; section 7.1.3
      (<expression> (alt <variable> <literal> <procedure-call> <lambda-expression>
                         <conditional> <assignment> <derived-expression>))
      (<literal> (alt <quotation> <self-evaluating>))
      (<self-evaluating> (alt <boolean> <number> <character> <string>))
      (<quotation> (lst 'quote <datum>))
      (<procedure-call>  ;; This could be simply (lst operator (star operand)),
       (predicate        ;; but then a spurious bad keyword is reported by
        (lambda (x)      ;; report-if-bad 'expression.
          (and  (pair? x)
                (not (and (symbol? (car x)) (not (<variable> x))))
                ((seq <operator> (star <operand>))
      (<operator> <expression>)
      (<operand> <expression>)
      (<lambda-expression> (lst 'lambda <formals> <body>))
      (<formals> (alt (lst (star <variable>)) <variable>
                      (dot (plus <variable>) <variable>)))
      (<body> (star <definition>) <sequence>)
      (<sequence> (star <command>) <expression>)
      (<command> <expression>)
      (<conditional> (lst 'if <test> <consequent> <alternate>))
      (<test> <expression>)
      (<consequent> <expression>)
      (<alternate> (alt <expression> <empty>)) ; could use (opt expression) instead
      (<empty> (seq))
      (<assignment> (lst 'set! <variable> <expression>))
        (lst 'cond (plus <cond-clause>))
        (lst 'cond (star <cond-clause>) (lst 'else <sequence>))
        (lst 'case <expression> (plus <case-clause>))
        (lst 'case <expression> (star <case-clause>) (lst 'else <sequence>))
        (lst 'and (star <test>))
        (lst 'or (star <test>))
        (lst 'let (lst (star <binding-spec>)) <body>)
        (lst 'let <variable> (lst (star <binding-spec>)) <body>)
        (lst 'let* (lst (star <binding-spec>)) <body>)
        (lst 'letrec (lst (star <binding-spec>)) <body>)
        (lst 'begin <sequence>)
        (lst 'do (lst (star <iteration-spec>))
             (lst <test> <sequence>)
             (star <command>))
        (lst 'delay <expression>)
      (<cond-clause> (alt (lst <test> <sequence>)
                          (lst <test>)
                          (lst <test> '=> <recipient>)))
      (<recipient> <expression>)
      (<case-clause> (lst (lst (star <datum>)) <sequence>))
      (<binding-spec> (lst <variable> <expression>))
      (<iteration-spec> (alt (lst <variable> <init> <step>)
                             (lst <variable> <init>)))
      (<init> <expression>)
      (<step> <expression>)
      ;; section 7.1.4, reduced to a context-free grammar w/o abbreviations
      (<quasiquotation> (lst 'quasiquote <template>))
      (<template> (alt <simple-datum> <list-template> <vector-template> <unquotation>))
      (<list-template> (alt (lst (star <template-or-splice>))
                            (dot (plus <template-or-splice>) <template>)))
      (<vector-template> (predicate
                          (lambda (x)
                            (and (vector? x)
                                 ((star <template-or-splice>) (vector->list x))))))
      (<unquotation> (lst 'unquote <template>))
      (<template-or-splice> (alt <template> <splice-unquotation>))
      (<splice-unquotation> (lst 'unquote-splicing <template>))      
      ;; section 7.1.5
      (<command-or-definition> (alt <command> <definition>))
       (report-if-bad 'definition
                      (alt (lst 'define <variable> <expression>)
                           (lst 'define (lst <variable> <def-formals>) <body>)
                           (lst 'begin (star <definition>)))))
      (<def-formals> (alt (star <variable>)
                          (dot (plus <variable>) <variable>)))))
  (define-grammar lambda-calculus?
    (grammar <expression>
      (<expression>  (alt <variable> <application> <abstraction>))
      (<application> (lst <expression> <expression>))
      (<abstraction> (lst 'lambda (lst <variable>) <expression>))
      (<variable>    (predicate 
                      (λ (x) (and (symbol? x) (not (eq? x 'lambda))))))))
  ) ; end of module grammar-examples