#lang racket
#|

File: semantics/beginner-syntax.rkt
Author: Bill Turtle

Syntactic forms that are introduced at the beginner level.

|#

(require (for-syntax syntax/stx))
(require "../utilities.rkt")
(require (for-syntax "../utilities.rkt"))
(require (only-in test-engine/racket-tests
                  check-expect
                  check-within
                  check-member-of
                  check-range
                  check-error
                  test))
#;(require (only-in test-engine/racket-gui
                  test))

(define-syntax (pyret-cond stx)
  (syntax-case stx (else)
    [(_ (test then) ... (else else-then))
     (let ([clause-list (syntax->list (syntax ((test then) ...)))])
       (let ([loc-list (map (λ (s) (vector (syntax-source s)
                                           (syntax-line s)
                                           (syntax-column s)
                                           (syntax-position s)
                                           (syntax-span s)))
                            (map (λ (s) (stx-car s)) clause-list))])
         (with-syntax ([loc-list-stx loc-list])
           (syntax/loc stx
             (pyret-do-cond `((,(lambda () test) ,(lambda () then)) 
                              ... 
                              (,(lambda () #t) ,(lambda () else-then))) 
                            'loc-list-stx)))))]
    [(kw (test then) ...)
     (with-syntax ([locs (syntax->vector stx)])
       (syntax/loc stx
         (kw
           (test then)
           ...
           (else (raise-pyret-error "cond: all question results were false" locs)))))]))

(define (pyret-do-cond clauses locs)
  ; locs has length equal to (sub1 (length clauses))
  (let ([adjusted-locs (append locs '(#t))])
    (let loop ([c clauses]
               [l adjusted-locs])
      (let ([f-clause (first c)]
            [r-clause (rest c)]
            [f-loc (first l)]
            [r-loc (rest l)])
        (if (boolean? ((first f-clause)))
            (if ((first f-clause))
                ((second f-clause))
                (loop r-clause r-loc))
            (raise-pyret-error
             "if: the highlighted expression does not evaluate to True or False"
             f-loc))))))
(provide (rename-out [pyret-cond cond])
         and
         or)

(provide (all-from-out test-engine/racket-tests
                       #;test-engine/racket-gui))