;; typedproc.ss
;;
;; @author  Morgan McGuire, morgan@cs.brown.edu
;;
;; @created 2002-01-15
;; @edited  2002-01-15
;;
;; Includes basic scheme and adds proc
;;

(module typedproc (file "basescheme.ss")
 (require (lib "string.ss")
          (lib "list.ss")
          (lib "etc.ss"))
 
 (require-for-syntax (lib "list.ss")
                     (file "basescheme.ss"))
 
 (provide (all-from (file "basescheme.ss"))
          symbol-append
          proc
          define-proc
          not-equal?
          mem?
          list-copy
          assert
          type-check)


;;
;; Generalized memq; uses an arbitrary equality proc. 
;;
(define (mem? x lst =?)
   (and
    (not (empty? lst))
    (or (=? (first lst) x)
        (mem? x (rest lst) =?))))
  

;; Shallow copy
(define (list-copy lst)
  (apply list lst))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Throws an exn:user? exception if the
;; argument is not true.
(define-macro (assert expr)
  `(if (not ,(first expr))
       (error "Assertion failure: " ,(format "~s" (first expr)))
       void))

;; (type-check test? object)
(define-macro (type-check expr)
  `(if (not (,(first expr) ,(second expr)))
       (error (format "Type check failed: Argument ~v has value ~v, which does not satisfy ~v" 
                      ,(format "~s" (second expr))
                       ,(second expr)
                      ,(format "~s" (first expr))))
       void))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   
;; symbol-append: symbol x symbol -> symbol
(define (symbol-append a b)
  (string->symbol 
   (string-append (symbol->string a) 
                  (symbol->string b))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (not-equal? a b)
  (not (equal? a b)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (proc (arg1 : type1 arg2 : type2 ...) body1 body2 ...):return-type
;;
;; Procedure with run-time type checking.
;;
;; You won't get type checking on assignment (e.g. set!), only on the
;; initial argument values and the return value.  The "type" can be
;; any function of one argument; e.g. integer?,  list?, 
;; (lambda (x) (and (integer? x) (odd? x) (> x 4)))
(define-macro (proc expr)     
  (let* 
      (
       ;; Extract and reparse the argument list so that colons are handled
       [arg-list       (reparse-for-colons
                        (retokenize-for-colons 
                         (first expr)))]

       ;; Extract the procedure body and type, if specified.  maybe-body
       ;; contains the type declaration, if there is one.
       [maybe-body     (cdr expr)]
       
       ;; See if the first symbol begins with a ":"
       [proc-type-specified   (and (not (eq? maybe-body '()))
                                   (symbol? (first maybe-body))
                                   (eq? (string-ref (symbol->string (first maybe-body)) 0) #\:))]

       ;; There's a space after the colon if the first symbol is exactly ':
       [proc-type-has-space   (and proc-type-specified (eq? (first maybe-body) ':))]
       
       ;; Extract the type if it exists
       [proc-type      (if proc-type-specified
                           (if proc-type-has-space
                               ;; pull out the second thing
                               (cadr maybe-body)
                               
                               ;; parse the name out of the first
                               (symbol-remove-first (first maybe-body)))
                           
                           void)]

       ;; The identifier used for the return value of the procedure
       [temp-id        (gensym)]
       [body           (if proc-type-specified
                           ;; There is an extra set of parens around let
                           ;; because the code below expects a list of expressions
                           ;; in body, not a single expression.

                           ;; Parsing the return type is tricky because we
                           ;; don't know if it is one symbol (:x) or two (: x)
                           `((let ([,temp-id (begin ,@(if proc-type-has-space 
                                                  (cddr maybe-body)
                                                  (rest maybe-body)))])
                              (type-check ,proc-type ,temp-id)
                              ,temp-id))
                                
                           maybe-body)]
              
       ;; Create a regular scheme proc list from the arg list by
       ;; stripping the types off
       [simple-arg-list 
        (map 
         (lambda (arg-decl) (if (list? arg-decl) (second arg-decl) arg-decl)) 
         arg-list)]
       
       ;; Make type checks from the arg-list by turning each (: v t) into
       ;; (type-check t? v)
       [type-checks     
        (map
         (lambda (binding)
               (let ([var  (second binding)]
                     [type (third binding)])
                 `(type-check ,type ,var)))
           (filter list? arg-list))])

   `(lambda ,simple-arg-list ,@type-checks ,@body)
    
    ))

;(define-syntax (define-proc stx)
;  (syntax-case stx ()
;    [(_ (proc-name arg1 arg2 ...) body1 body2 ...)
;     (syntax/loc
;      stx
;      (define proc-name (proc (arg1 arg2 ...) body1 body2 ...)))]))

(define-macro (define-proc expr)
  (let ([name  (first (first expr))]
        [args  (rest (first expr))]
        [body  (rest expr)])
    `(define ,name (proc ,args ,@body))))

 
)