#lang racket
(require syntax/parse/define
         (for-syntax syntax/parse
                     racket/syntax
                     racket/struct-info
                     racket/list))

(begin-for-syntax
  (define (rename id stx)
    (syntax-parse stx
      [(name args ...) #`(#,id args ...)]
      [_ id]))

  (struct class (name methods)
    #:property prop:procedure (λ (this stx) (rename (class-name this) stx)))

  (struct typed-id (name type)
    #:property prop:procedure (λ (this stx) (rename (typed-id-name this) stx))))

(define-simple-macro (define-class name:id slot:id  ...)
  #:with hidden (generate-temporary #'name)
  (begin (struct hidden (slot ...))
         (define-syntax name (class #'hidden (list #'slot ...)))))

(define-simple-macro (define-class-instance name:id (~var class (static class? "class")) arg ...)
  #:do [(define args-count (length (class-methods (syntax-local-value #'class))))]
  #:fail-unless (= (length (syntax->list #'(arg ...))) args-count)
                (format "need ~a arguments" args-count)
  #:with hidden (generate-temporary #'name)
  (begin (define hidden (class arg ...))
         (define-syntax name (typed-id #'hidden #'class))))

(define-simple-macro (slot-value (~var id (static typed-id? "typed id")) slot:id)
  #:do [(define class (syntax-local-value (typed-id-type (syntax-local-value #'id))))
        (define accessors (fourth (extract-struct-info (syntax-local-value (class-name class)))))
        (define rest-accessors (memf (λ (x) (free-identifier=? x #'slot)) (class-methods class)))]
  #:fail-unless rest-accessors
                (format "slot ~a does not exist in class ~a."
                        (symbol->string (syntax->datum #'slot))
                        (symbol->string (syntax->datum (typed-id-type (syntax-local-value #'id)))))
  #:with accessor (list-ref accessors (- (length accessors) (length rest-accessors)))
  #:with real-name (typed-id-name (syntax-local-value #'id))
  (accessor real-name))