#lang plai-typed

;; Start with "object.rkt"

;; Make `{get <expr> m}` call the method `m` on the object
;; produced by <expr> if that object doesn't have an `m` field.
;; Provide 0 as the argument to the method.

(define-type ExprC
  [numC (n : number)]
  [plusC (lhs : ExprC)
         (rhs : ExprC)]
  [multC (lhs : ExprC)
         (rhs : ExprC)]
  [argC]
  [thisC]
  [objectC (field-names : (listof symbol))
           (field-exprs : (listof ExprC))
           (methods : (listof Method))]
  [getC (obj-expr : ExprC)
        (field-name : symbol)]
  [sendC (obj-expr : ExprC)
         (method-name : symbol)
         (arg-expr : ExprC)])

(define-type Method
  [method (name : symbol)
          (body-expr : ExprC)])

(define-type Value
  [numV (n : number)]
  [objV (field-names : (listof symbol))
        (field-values : (listof Value))
        (methods : (listof Method))])

(module+ test
  (print-only-errors true))

;; ----------------------------------------

(define (make-find [name-of : ('a -> symbol)])
  (lambda ([name : symbol] [vals : (listof 'a)]) : 'a
    (cond
      [(empty? vals)
       (error 'find "not found")]
      [else (if (equal? name (name-of (first vals)))
                (first vals)
                ((make-find name-of) name (rest vals)))])))

(define find-method : (symbol (listof Method) -> Method)
  (make-find method-name))

;; A non-list pair:
(define-type (Pair 'a 'b)
  [kons (first : 'a) (rest : 'b)])

(define (get-field [name : symbol] 
                   [field-names : (listof symbol)] 
                   [vals : (listof Value)])
  ;; Pair fields and values, find by field name,
  ;; then extract value from pair
  (kons-rest ((make-find kons-first)
              name
              (map2 kons field-names vals))))

(module+ test
  (test/exn (find-method 'a empty)
            "not found")
  (test (find-method 'a (list (method 'a (numC 0))))
        (method 'a (numC 0)))
  (test (find-method 'b (list (method 'a (numC 0))
                              (method 'b (numC 1))))
        (method 'b (numC 1)))
  (test (get-field 'a 
                   (list 'a 'b)
                   (list (numV 0) (numV 1)))
        (numV 0)))

;; ----------------------------------------

(define interp : (ExprC Value Value -> Value)
  (lambda (a this-val arg-val)
    (type-case ExprC a
      [numC (n) (numV n)]
      [plusC (l r) (num+ (interp l this-val arg-val) 
                         (interp r this-val arg-val))]
      [multC (l r) (num* (interp l this-val arg-val) 
                         (interp r this-val arg-val))]
      [thisC () this-val]
      [argC () arg-val]
      [objectC (field-names field-exprs methods)
               (objV field-names
                     (map (lambda (a) (interp a this-val arg-val))
                          field-exprs)
                     methods)]
      [getC (obj-expr field-name)
            (local [(define obj (interp obj-expr this-val arg-val))]
              (type-case Value obj 
                [objV (field-names field-vals methods)
                      (try (get-field field-name field-names field-vals)
                           (lambda() (call-method field-name obj (numV 0))))]
                [else (error 'interp "not an object")]))]
      [sendC (obj-expr method-name arg-expr)
             (local [(define obj (interp obj-expr this-val arg-val))
                     (define next-arg-val (interp arg-expr this-val arg-val))]
               (call-method method-name obj next-arg-val))])))

(define (call-method [name : symbol] [obj : Value] [arg-val : Value])
  (type-case Value obj
    [objV (field-names field-vals methods)
          (type-case Method (find-method name methods)
            [method (name body-expr)
                    (interp body-expr
                            obj
                            arg-val)])]
    [else (error 'interp "not an object")]))

(define (num-op [op : (number number -> number)]
                [op-name : symbol] 
                [x : Value]
                [y : Value]) : Value
  (cond
    [(and (numV? x) (numV? y))
     (numV (op (numV-n x) (numV-n y)))]
    [else (error 'interp "not a number")]))

(define (num+ x y) (num-op + '+ x y))
(define (num* x y) (num-op * '* x y))

;; ----------------------------------------
;; Examples

(module+ test
  (define posn27
    (objectC
     (list 'x 'y)
     (list (numC 2) (numC 7))
     (list (method 'mdist
                   (plusC (getC (thisC) 'x) (getC (thisC) 'y)))
           (method 'addX
                   (plusC (getC (thisC) 'x) (argC)))
           (method 'multY (multC (argC) (getC (thisC) 'y))))))

  (define posn531
    (objectC
     (list 'x 'y 'z)
     (list (numC 5) (numC 3) (numC 1))
     (list (method 'mdist (plusC (getC (thisC) 'z)
                                 (plusC (getC (thisC) 'x) (getC (thisC) 'y))))))))

;; ----------------------------------------

(module+ test
  (test (interp (numC 10) 
                (numV -1) (numV -1))
        (numV 10))
  (test (interp (plusC (numC 10) (numC 17))
                (numV -1) (numV -1))
        (numV 27))
  (test (interp (multC (numC 10) (numC 7))
                (numV -1) (numV -1))
        (numV 70))
  (test (interp (objectC (list 'a 'b)
                         (list (numC 1) (numC 2))
                         (list (method 'm (numC 0))))
                (numV -1) (numV -1))
        (objV (list 'a 'b)
              (list (numV 1) (numV 2))
              (list (method 'm (numC 0)))))
  
  (test (interp (sendC posn27 'mdist (numC 0))
                (numV -1) (numV -1))
        (numV 9))
  
  (test (interp (sendC posn27 'addX (numC 10))
                (numV -1) (numV -1))
        (numV 12))

  (test (interp (getC (objectC empty
                               empty
                               (list (method 'x (numC 21))))
                      'x)
                (numV -1) (numV -1))
        (numV 21))
  
  (test/exn (interp (plusC (numC 1) (objectC empty empty empty))
                    (numV -1) (numV -1))
            "not a number")
  (test/exn (interp (getC (numC 1) 'x)
                    (numV -1) (numV -1))
            "not an object")
  (test/exn (interp (sendC (numC 1) 'mdist (numC 0))
                    (numV -1) (numV -1))
            "not an object"))