#lang racket/base

(require (for-syntax racket/base
                     "transformer.rkt"
                     "fixture.rkt"
                     "compile.rkt"
                     "debug.rkt"
                     syntax/parse))

(provide (all-defined-out))

(define-syntax (define-honu-operator/syntax stx)
  (syntax-parse stx
    [(_ name precedence associativity binary-function)
     (syntax/loc stx (define-syntax name (make-honu-operator precedence associativity binary-function #f #f)))]
    [(_ name precedence associativity binary-function unary-function postfix?)
     (syntax/loc stx (define-syntax name (make-honu-operator precedence associativity binary-function unary-function postfix?)))]))

(define-syntax (define-honu-fixture stx)
  (syntax-parse stx
    [(_ name transformer)
     #'(define-syntax name (make-fixture transformer))]))

(define-syntax-rule (define-binary-operator name precedence associativity operator)
    (define-honu-operator/syntax name precedence associativity
                                 ;; binary
                                 (lambda (left right)
                                   (with-syntax ([left left]
                                                 [right right])
                                     (racket-syntax (operator left right))))))

(define-syntax-rule (define-unary+binary-operator name precedence associativity operator)
    (define-honu-operator/syntax name precedence associativity
                                 ;; binary
                                 (lambda (left right)
                                   (with-syntax ([left left]
                                                 [right right])
                                     (racket-syntax (operator left right))))
                                 ;; unary
                                 (lambda (arg)
                                   (with-syntax ([arg arg])
                                     (racket-syntax (operator arg))))
                                 ;; binary operators should not be able to be postfix
                                 #f))

(define-syntax-rule (define-unary-operator name precedence postfix? operator)
                    ;; associativity dont matter for unary 
                    (define-honu-operator/syntax name precedence 'left
                                                 #f
                                                 ;; unary
                                                 (lambda (argument)
                                                   (with-syntax ([argument argument])
                                                     (racket-syntax (operator argument))))
                                                 postfix?))

(define-honu-operator/syntax honu-flow 0.001 'left
  (lambda (left right)
    (with-syntax ([left left]
                  [right right])
      (racket-syntax (right left)))))

(begin-for-syntax
  (define-syntax-rule (mutator change)
                      (lambda (left right)
                        (with-syntax ([left left]
                                      [right (change left right)])
                          (racket-syntax (set! left right))))))

;; Traditional assignment operator
(define-honu-operator/syntax honu-equal 0.0001 'left
  (let ([plain-mutate (mutator (lambda (left right) right))])
    (lambda (left right)
      (define mutate (syntax-property left 'assign))
      (if mutate
        (mutate right)
        (plain-mutate left right)))))

;; Define an assignment operator that uses the current value in its operation
;;   a -= 2
;; is the same 
;;   a = a - 2
;; and turns into
;;   (set! a (- a 2))
;;
;;   a.x -= 2
;; turns into
;;   (honu-struct-set! a x (- (dot a x) 2))
;; where (dot a x) is field lookup of x inside a
(define-syntax-rule (define-honu-operator-= name operation)
  (define-honu-operator/syntax name 0.0001 'left
    (let ()
      (define (do-it left right)
        (with-syntax ([left left] [right right])
          #'(operation left right)))
      (define plain-mutate (mutator do-it))
      (lambda (left right)
        (define mutate (syntax-property left 'assign))
        (if mutate
          (mutate (do-it left right))
          (plain-mutate left right))))))

;; Operators that mutate the left hand side
(define-honu-operator-= honu-+= +)
(define-honu-operator-= honu--= -)
(define-honu-operator-= honu-*= *)
(define-honu-operator-= honu-/= /)

(define-unary+binary-operator honu-+ 1 'left +)
(define-unary+binary-operator honu-- 1 'left -)
(define-binary-operator honu-* 2 'left *)
(define-binary-operator honu-/ 2 'left /)
(define-binary-operator honu-^ 2 'right expt)
(define-binary-operator honu-< 0.9 'left <)
(define-binary-operator honu-<= 0.9 'left <=)
(define-binary-operator honu-> 0.9 'left >)
(define-binary-operator honu->= 0.9 'left >=)
;; (define-binary-operator honu-= 0.9 'left =)
(define-binary-operator honu-and 0.5 'left and)
(define-binary-operator honu-or 0.5 'left or)
(define-binary-operator honu-cons 0.1 'right cons)
(define-binary-operator honu-map 0.09 'left map)
(define-binary-operator honu-string=? 1 'left string=?)
(define-binary-operator honu-modulo 2 'left modulo)

(define-binary-operator honu-to 0.001 'left
                        (lambda (left right)
                          (for/list ([i (in-range left right)]) i)))

(define-unary-operator honu-not 0.7 #f not)

(define-binary-operator honu-== 1 'left equal?)
(define-binary-operator honu-not-equal 1 'left (lambda (left right)
                                                 (not (equal? left right))))

(define-honu-operator/syntax honu-=> 0.00001 'left
  (lambda (left right)
    (when (not (identifier? left))
      (raise-syntax-error '=> "expected an identifier" left))
    (with-syntax ([left left]
                  [right right])
      (racket-syntax (lambda (left)
                       right)))))