;; 
;; Units as part of the type system
;;
(require-extension codewalk)
(require-extension environments)

(define-record dimval unit value)

(define (lookup v)
  (define env (interaction-environment))
  (environment-ref env v))

(define-datatype unit-expr
  (Nonscalar  (sexp (lambda (x) (or (symbol? x) (list? x)))))
  (Measured   (unit unit?)  (lambda (x) (or (symbol? x) (list? x)))))

(define (unit-expand expr)
   (expand
    expr 
    (lambda (expr class walk env mark)
      (case c
	;; variable reference
	((ref)  
	 (let ((v  (lookup expr)))
	   (if (unit-expr? v) expr
	       (if (number? v)
		   (Measured unitless expr)
		   (Nonscalar expr)))))
	;; constant literals
	((literal)  (if (number? expr) 
			(Measured unitless expr)
			(Nonscalar expr)))
	((quoted-literal)  (Nonscalar expr))
	((if)
	 (let ((ifcond  (walk (second expr)))
	       (iftrue  (walk (third expr)))
	       (iffalse (walk (fourth expr))))
	   (match (cons iftrue iffalse)
		  
	   (if (not (unit-equal? iftrue iffalse))
	       (unit-conversion:error 'unit-expand 
				      ": arguments to if statement have different units: "
				      " iftrue=" iftrue "; iffalse= " iffalse))
	   
	 
	 ((app)
	  (match expr
		 ((':unit t val)  (or (and (unit? t) (number? val) (make-unit-value t val))
				      (unit-conversion:error 'unit-expand 
						   ": invalid arguments to :unit spec: t=" t "; val= " val)))
		 ((op . args)     (if (memq op unit-arith-ops)
				      (unit-expr op (map walk args))
				      (walk expr)))
		 (else  (walk expr)))))))))
	    


;; supported arithmetic operations on dimensioned quantities
(define unit-arith-ops  `(+ - / * expt sin cos tan))

(define (unit-expr op expr)

  (define (check-unit-dimensions unit args)
    (if (null? args) #t
	(if (= (quantity-int (unit-quantity unit))
	       (quantity-int (unit-quantity (car args))))
	    (check-unit-args unit (cdr args))
	    (unit-conversion:error 'unit-arith 
			 ": inconsistent dimensions of units in arithmetic expression: " 
			 "expression was: " (list op args)
			 " units are " unit " and " (car args)))))