#lang scheme/base
(require scheme/class
         scheme/stxparam
         (for-syntax scheme/base))

(provide defclass defclass*
         def/public def/override define/top case-args
         maybe-box? any? bool? nonnegative-real? make-or-false make-box make-list make-alts 
         make-literal symbol-in make-procedure
         method-name init-name
         let-boxes
         properties field-properties init-properties
         ->long
         assert)

(define-syntax-parameter class-name #f)

(define-syntax-rule (defclass name super . body)
  (defclass* name super () . body))
(define-syntax-rule (defclass* name super intfs . body)
  (define name
    (syntax-parameterize ([class-name 'name])
      (class* super intfs . body))))

(define-syntax (def/public stx)
  #`(def/thing define/public #,stx))
(define-syntax (def/override stx)
  #`(def/thing define/override #,stx))
(define-syntax (define/top stx)
  #`(def/thing define #,stx))

(define (method-name class method)
  (string->symbol (format "~a in ~a" method class)))
(define (init-name class)
  (string->symbol (format "initialization for ~a" class)))

(define-syntax just-id
  (syntax-rules ()
    [(_ [id default]) id]
    [(_ id) id]))

(define-struct named-pred (pred make-name)
  #:property prop:procedure (struct-field-index pred))

(define (apply-pred pred val)
  (cond
   [(procedure? pred) (pred val)]
   [(class? pred) (val . is-a? . pred)]
   [(interface? pred) (val . is-a? . pred)]
   [else (error 'check-arg "unknown predicate type: ~e" pred)]))

(define (make-or-false pred)
  (make-named-pred (lambda (v)
                     (or (not v) (apply-pred pred v)))
                   (lambda ()
                     (string-append (predicate-name pred)
                                    " or #f"))))

(define (make-box pred)
  (make-named-pred (lambda (v)
                     (and (box? v) (apply-pred pred (unbox v))))
                   (lambda ()
                     (string-append "boxed " (predicate-name pred)))))

(define (make-list pred)
  (make-named-pred (lambda (v)
                     (and (list? v) (andmap (lambda (v) (apply-pred pred v)) v)))
                   (lambda ()
                     (string-append "list of " (predicate-name pred)))))

(define (make-alts a b)
  (make-named-pred (lambda (v)
                     (or (apply-pred a v) (apply-pred b v)))
                   (lambda ()
                     (string-append (predicate-name a)
                                    " or "
                                    (predicate-name b)))))

(define (make-literal lit)
  (make-named-pred (lambda (v) (equal? v lit))
                   (lambda () (if (symbol? lit)
                                  (format "'~s" lit)
                                  (format "~s" lit)))))

(define (make-symbol syms)
  (make-named-pred (lambda (v) (memq v syms))
                   (lambda ()
                     (let loop ([syms syms])
                       (cond
                        [(null? (cdr syms))
                         (format "'~s" (car syms))]
                        [(null? (cddr syms))
                         (format "'~s, or '~s" (car syms) (cadr syms))]
                        [else
                         (format "'~s, ~a" (car syms) (loop (cdr syms)))])))))
(define-syntax-rule (symbol-in sym ...)
  (make-symbol '(sym ...)))

(define (make-procedure arity)
  (make-named-pred (lambda (p)
                     (and (procedure? p)
                          (procedure-arity-includes? p arity)))
                   (lambda ()
                     (format "procedure (arity ~a)" arity))))

(define (check-arg val pred pos)
  (if (apply-pred pred val)
      #f
      (cons (predicate-name pred)
            pos)))

(define (predicate-name pred)
  (cond
   [(named-pred? pred) ((named-pred-make-name pred))]
   [(procedure? pred) (let ([s (symbol->string (object-name pred))])
                        (substring s 0 (sub1 (string-length s))))]
   [(or (class? pred) (interface? pred))
    (format "~a instance" (object-name pred))]
   [else "???"]))

(define maybe-box? (make-named-pred (lambda (v) (or (not v) (box? v)))
                                    (lambda () "box or #f")))
(define (any? v) #t)
(define (bool? v) #t)
(define (nonnegative-real? v) (and (real? v) (v . >= . 0)))

(define (method-of cls nam)
  (if cls
      (string->symbol (format "~a method of ~a" nam cls))
      nam))

(define-syntax (def/thing stx)
  (syntax-case stx ()
    [(_ define/orig (_ (id [arg-type arg] ...)))
     (raise-syntax-error #f "missing body" stx)]
    [(_ define/orig (_ (id [arg-type arg] ...) . body))
     (with-syntax ([(_ _ orig-stx) stx]
                   [(pos ...) (for/list ([i (in-range (length (syntax->list #'(arg ...))))])
                                i)]
                   [cname (syntax-parameter-value #'class-name)])
       (syntax/loc #'orig-stx
         (define/orig (id arg ...)
           (let ([bad (or (check-arg (just-id arg) arg-type pos)
                          ...)])
             (when bad
               (raise-type-error (method-of 'cname 'id) (car bad) (cdr bad) (just-id arg) ...)))
           (let ()
             . body))))]))

(define-for-syntax lifted (make-hash))
(define-syntax (lift-predicate stx)
  (syntax-case stx ()
    [(_ id) (identifier? #'id) #'id]
    [(_ expr)
     (let ([d (syntax->datum #'expr)])
       (or (hash-ref lifted d #f)
           (let ([id (syntax-local-lift-expression #'expr)])
             (hash-set! lifted d id)
             id)))]))

(define-syntax (case-args stx)
  (syntax-case stx ()
    [(_ expr [([arg-type arg] ...) rhs ...] ... who)
     (with-syntax ([((min-args-len . max-args-len) ...)
                    (map (lambda (args)
                           (let ([args (syntax->list args)])
                             (cons (let loop ([args args])
                                     (if (or (null? args)
                                             (not (identifier? (car args))))
                                         0
                                         (add1 (loop (cdr args)))))
                                   (length args))))
                         (syntax->list #'((arg ...) ...)))])
       #'(let* ([args expr]
                [len (length args)])
           (find-match
            (lambda (next)
              (if (and (len . >= . min-args-len)
                       (len . <= . max-args-len))
                  (apply
                   (lambda (arg ...)
                     (if (and (not (check-arg (just-id arg) (lift-predicate arg-type) 0)) ...)
                         (lambda () rhs ...)
                         next))
                   args)
                  next))
            ...
            (lambda (next)
              (bad-args who args)))))]))

(define (bad-args who args)
  (error who "bad argument combination:~a"
         (apply string-append (map (lambda (x) (format " ~e" x))
                                   args))))

(define-syntax find-match
  (syntax-rules ()
    [(_ proc)
     ((proc #f))]
    [(_ proc1 proc ...)
     ((proc1 (lambda () (find-match proc ...))))]))

(define-syntax-rule (let-boxes ([id init] ...)
                               call
                               body ...)
  (let ([id (box init)] ...)
    call
    (let ([id (unbox id)] ...)
      body ...)))

(define-syntax (do-properties stx)
  (syntax-case stx ()
    [(_ define-base check-immutable [[type id] expr] ...)
     (let ([ids (syntax->list #'(id ...))])
       (with-syntax ([(getter ...)
                      (map (lambda (id)
                             (datum->syntax id
                                            (string->symbol
                                             (format "get-~a" (syntax-e id)))
                                            id))
                           ids)]
                     [(setter ...)
                      (map (lambda (id)
                             (datum->syntax id
                                            (string->symbol
                                             (format "set-~a" (syntax-e id)))
                                            id))
                           ids)])
         #'(begin
             (define-base id expr) ...
             (define/public (getter) id) ...
             (def/public (setter [type v]) (check-immutable 'setter) (set! id (coerce type v))) ...)))]))

(define-syntax coerce
  (syntax-rules (bool?)
    [(_ bool? v) (and v #t)]
    [(_ _ v) v]))

(define-syntax properties
  (syntax-rules ()
    [(_ #:check-immutable check-immutable . props)
     (do-properties define check-immutable . props)]
    [(_ . props)
     (do-properties define void . props)]))
(define-syntax field-properties
  (syntax-rules ()
    [(_ #:check-immutable check-immutable . props)
     (do-properties define-field check-immutable . props)]
    [(_ . props)
     (do-properties define-field void . props)]))
(define-syntax-rule (define-field id val) (field [id val]))
(define-syntax init-properties
  (syntax-rules ()
    [(_ #:check-immutable check-immutable . props)
     (do-properties define-init check-immutable . props)]
    [(_ . props)
     (do-properties define-init void . props)]))
(define-syntax-rule (define-init id val) (begin
                                           (init [(internal id) val])
                                           (define id internal)))

(define (->long i) 
  (cond
   [(eqv? -inf.0 i) (- (expt 2 64))]
   [(eqv? +inf.0 i) (expt 2 64)]
   [(eqv? +nan.0 i) 0]
   [else (inexact->exact (floor i))]))


(define-syntax-rule (assert e) (void))
; (define-syntax-rule (assert e) (unless e (error 'assert "failed: ~s" 'e)))