;; tlambda.scm
;; NKU CSC 601 - Fall 2002 - Kirby - Program 2 - A Solution  
;; --------------------------------------------------------
;; A hack-n-eval approach for syntactic sugar:
;; Adding type-checked argument lists.
;; Restricted to our "basic Scheme vocabulary."
;;
;; See tlambda_demo.scm for a demonstration.
;; --------------------------------------------------------


(define couple?
  (lambda (s)
    ; Is s a list of 2 elements?
    (and (pair? s) (pair? (cdr s)) (null? (cddr s)))))

(define triple?
  (lambda (s)
    ; Is s a list of 3 elements?
    (and (pair? s) (couple? (cdr s)))))

(define list-of
  (lambda (pred s)
    ; Is s a list of elements for which pred is true?
    (and (list? s)
         (if (null? s)
             #t
             (and (pred (car s))
                  (list-of pred (cdr s)))))))

(define arg-checker
  (lambda (typed-arg)
    ; Convert this typed argument into a (test result) clause for insertion into a (cond ...).
    (let ((argname (extract-arg typed-arg)))
      (if (symbol? typed-arg)
          '(#f null) ; untyped argument: return a do-nothing cond clause.
          (list (list 'not typed-arg)
                (list 'list 
                      ''typed-arg-error: 
                      (list 'quote typed-arg) 
                      ''false ''for 
                      (list 'quote argname)
                      ''=
                      argname))))))
    
(define extract-arg
  (lambda (typed-arg)
    ; Extract the untyped argument from this element of a typed argument list.
    ; Example: (extract-arg '(list-of number? s))  =>  s. 
    (cond
      ((symbol? typed-arg)
       typed-arg)
      ((couple? typed-arg)
       (cadr typed-arg))
      ((triple? typed-arg)
       (caddr typed-arg)))))

(define ttrans
  (lambda (defexp)
    ; Convert the tlambda-style defexp into a lambda-style definition with parameter type checking.
    ; Assumes that defexp is syntactically well-formed.
    (let ((fname   (cadr defexp))
          (arglist (cadr (caddr defexp)))
          (body    (caddr (caddr defexp))))
      (eval
        (list 'define fname 
              (list 'lambda (map extract-arg arglist) 
                     (append (list 'cond)
                             (map arg-checker arglist)
                             (list (list #t body)))))))))