(module infix mzscheme
  ;; Slightly evil and wrong: we try to transparently handle infix notation and turn
  ;; it into prefix.  We handle the following infix operators:
  ;;
  ;;    * + - /
  ;;
  ;; plus parenthesized function call expressions.
  ;;
  ;; We use parser-tools to do this hackery.
  ;;
  ;; TODO: add chained comparisons just to add to the madness.
  ;;
  ;; TODO: add more unit tests
  ;;
  ;; TODO: fix bug with capturing.  We don't want to capture + if it's
  ;; been rebound.  Test example would look like:
  ;; I still don't quite understand module-or-top-identifier=?.  I've fixed it
  ;; by using module-transformer-identifier=?, but I have to admit I don't understand
  ;; how that actually fixes it, which means this is a kludge until I get a clue.
  
  (provide (all-defined))
  
  (require (lib "list.ss")
           (lib "plt-match.ss")
           (lib "stx.ss" "syntax")
           (lib "lex.ss" "parser-tools")
           (lib "yacc.ss" "parser-tools"))
  
  (require-for-template mzscheme)
  
  
  
  ;                                                                                     
  ;                                                                                     
  ;  ;;;;;;;       ;;                      ;                           ;                
  ;  ;  ;  ;        ;                                          ;                        
  ;     ;     ;;;   ; ;;;   ;;;  ;; ;;   ;;;    ;;;;;   ;;;   ;;;;;  ;;;     ;;;  ;; ;; 
  ;     ;    ;   ;  ;  ;   ;   ;  ;;  ;    ;    ;  ;   ;   ;   ;       ;    ;   ;  ;;  ;
  ;     ;    ;   ;  ;;;    ;;;;;  ;   ;    ;      ;     ;;;;   ;       ;    ;   ;  ;   ;
  ;     ;    ;   ;  ; ;    ;      ;   ;    ;     ;     ;   ;   ;       ;    ;   ;  ;   ;
  ;     ;    ;   ;  ;  ;   ;      ;   ;    ;    ;   ;  ;   ;   ;   ;   ;    ;   ;  ;   ;
  ;    ;;;    ;;;  ;; ;;;;  ;;;; ;;; ;;; ;;;;;  ;;;;;   ;;;;;   ;;;  ;;;;;   ;;;  ;;; ;;;
  ;                                                                                     
  ;                                                                                     
  ;                                                                                     
  ;                                                                                     
  
  (define-tokens tokens (lparen atom rparen comma eof
                                plus minus times divide
                                cmp))
  
  ;; syntax->token-list: syntax -> (listof tokens)
  ;; given a piece of syntax, returns a list of its tokens.
  ;; Each token remembers its origin stx.
  (define (syntax->token-list stx)
    ;; TODO: simplify this code if possible.
    (define (operator? stx)
      (and (operator-token/#f stx)
           #t))
    
    ;; just to save typing:
    (define identifier=? module-or-top-identifier=?)
    
    (define (operator-token/#f stx)
      (cond
        [(not (identifier? stx)) #f]
        [(identifier=? stx (syntax +))
         (token-plus stx)]
        [(identifier=? stx (syntax -))
         (token-minus stx)]
        [(identifier=? stx (syntax *))
         (token-times stx)]
        [(identifier=? stx (syntax /))
         (token-divide stx)]
        [(ormap (lambda (op-stx) (identifier=? stx op-stx))
                (list (syntax <) (syntax <=) (syntax =) (syntax >) (syntax >=)))
         (token-cmp stx)]
        [else #f]))
    
    (syntax-case* stx (unquote quote) identifier=?
      ;; unquote unfolded as comma
      [(unquote e)
       (cons (token-comma stx)
             (syntax->token-list (syntax e)))]

      ;; quotes treated as atomic
      [(quote e)
       (list (token-atom stx))]
      
      ;; lists unfolded as lparen ... rparen
      [(e ...)
       `( ,(token-lparen stx) 
           ,@(apply append (map syntax->token-list (syntax-e (syntax (e ...)))))
           ,(token-rparen stx))]
      
      ;; infix operators transformed into specific tokens
      [e (operator? stx)
         (list (operator-token/#f stx))]
      
      [else
       (list (token-atom stx))]))
  
  
  ;; token-list->producer: (listof tokens) -> (-> tokens)
  (define (token-list->producer a-token-list)
    (lambda ()
      (cond [(empty? a-token-list)
             (token-eof (void))]
            [else
             (let ([next-token (first a-token-list)])
               (set! a-token-list (rest a-token-list))
               next-token)])))
  
  
  
  
  ;                                                  
  ;                                                  
  ;   ;;;;                          ;                
  ;    ;  ;                                          
  ;    ;  ;   ;;;   ;; ;;   ;;;;  ;;;   ;; ;;    ;; ;;
  ;    ;  ;  ;   ;   ;;    ;   ;    ;    ;;  ;  ;  ;;
  ;    ;;;    ;;;;   ;      ;;;     ;    ;   ;  ;   ;
  ;    ;     ;   ;   ;         ;    ;    ;   ;  ;   ;
  ;    ;     ;   ;   ;     ;   ;    ;    ;   ;  ;   ;
  ;   ;;;     ;;;;; ;;;;;  ;;;;   ;;;;; ;;; ;;;  ;;;;
  ;                                                 ;
  ;                                              ;;; 
  ;                                                  
  ;                                                  

  (define-struct app-node (op rands) #f)
  (define-struct cmp-node (op lhs rhs) #f)
  (define-struct atom-node (atom) #f)
  
  (define parse-expression
    (parser
     (tokens tokens)
     (start top-expr)
     (end eof)
     
     
     (grammar [top-expr ((expr) $1)]
              [expr ((comparison) $1)
                    ((arithmetic) $1)
                    ((function-application) $1)
                    ((parenthesized) $1)
                    ((atom) (make-atom-node $1))]
              
              [comparison ([expr cmp expr] (make-cmp-node (make-atom-node $2) $1 $3))]
              
              [parenthesized ((lparen expr rparen) $2)]
              
              [arithmetic ((expr plus expr) (make-app-node (make-atom-node $2) (list $1 $3)))
                          ((expr minus expr) (make-app-node (make-atom-node $2) (list $1 $3)))
                          ((expr times expr) (make-app-node (make-atom-node $2) (list $1 $3)))
                          ((expr divide expr) (make-app-node (make-atom-node $2) (list $1 $3)))]
              
              [function-application ((expr lparen comma-separated-exprs rparen)
                                     (make-app-node $1 $3))]
              
              [comma-separated-exprs ((expr comma comma-separated-exprs) (cons $1 $3))
                                     ((expr) (list $1))
                                     (() (list))])
     
     
     
     (precs (left cmp)
            (left plus minus)
            (left times divide)
            (nonassoc lparen))
     
     (error (lambda (token-ok token-name token-value)
              (raise-syntax-error 'parse-expression "while parsing" token-value)))))
  
  
  
  
  
  ;                                                                                                          
  ;                                                                                                          
  ;    ;;;;            ;;                                                                   ;                
  ;   ;   ;             ;                                                           ;                        
  ;   ;       ;;;    ;; ;   ;;;           ;; ;;  ;;;  ;; ;;    ;;;   ;; ;;   ;;;   ;;;;;  ;;;     ;;;  ;; ;; 
  ;   ;      ;   ;  ;  ;;  ;   ;         ;  ;;  ;   ;  ;;  ;  ;   ;   ;;    ;   ;   ;       ;    ;   ;  ;;  ;
  ;   ;      ;   ;  ;   ;  ;;;;;         ;   ;  ;;;;;  ;   ;  ;;;;;   ;      ;;;;   ;       ;    ;   ;  ;   ;
  ;   ;      ;   ;  ;   ;  ;             ;   ;  ;      ;   ;  ;       ;     ;   ;   ;       ;    ;   ;  ;   ;
  ;   ;   ;  ;   ;  ;   ;  ;             ;   ;  ;      ;   ;  ;       ;     ;   ;   ;   ;   ;    ;   ;  ;   ;
  ;    ;;;    ;;;    ;;;;;  ;;;;          ;;;;   ;;;; ;;; ;;;  ;;;;  ;;;;;   ;;;;;   ;;;  ;;;;;   ;;;  ;;; ;;;
  ;                                          ;                                                               
  ;                                       ;;;                                                                
  ;                                                                                                          
  ;                                                                                                          
  
  
  ;; expression->code: node -> stx
  ;; Walks the node tree and generates the appropriate Scheme syntax.
  (define (expression->code node context-stx)
    (match node
      [(struct app-node (op rands))
       (app-node->code op rands context-stx)]
      [(struct cmp-node (op l r))
       (cmp-node->code node context-stx)]
      [(struct atom-node (atom))
       (atom-node->code atom)]))
  
  
  
  ;; app-node->code: node (listof node) stx -> stx
  ;; For code generating an application, just move things back to prefix order.
  (define (app-node->code op-node rand-nodes context-stx)
    (with-syntax ([op (expression->code op-node context-stx)]
                  [(rands ...) (map (lambda (node) (expression->code node context-stx)) rand-nodes)])
      ;; TODO: capture more location information to make this accurate.
      (syntax/loc context-stx
        (op rands ...))))
  
  
  ;; cmp-node->code: node stx -> stx
  ;; Code generating for cmp-nodes is subtle: we chain the comparisons to guarantee
  ;; left->right order, avoiding duplicated evaluation.
  ;;
  ;; We're doing this in pseudo-continuation-passing-style, since we don't have direct
  ;; access to the macro expander and its ability to recursively call macros.
  (define (cmp-node->code node context-stx)
    
    (define (cmp-node->code/tmp node tmp-for-right k-stx)
      (match node
        [(struct cmp-node (op (and left
                                   (struct cmp-node (op-child l-child r-child)))
                              right))
         (with-syntax ([tmp-for-right tmp-for-right]
                       [k-stx k-stx]
                       [tmp-for-left (syntax tmp-for-left)]
                       [compiled-op (expression->code op context-stx)]
                       [compiled-right (expression->code right context-stx)])
           (cmp-node->code/tmp
            left
            (syntax tmp-for-left)
            (syntax/loc context-stx
              (let ([tmp-for-right compiled-right])
                (if (compiled-op tmp-for-left tmp-for-right)
                    k-stx
                    #f)))))]
        
        [(struct cmp-node (op left right))
         (with-syntax ([tmp-for-right tmp-for-right]
                       [k-stx k-stx]
                       [compiled-op (expression->code op context-stx)]
                       [compiled-right (expression->code right context-stx)]
                       [compiled-left (expression->code left context-stx)])
           (syntax/loc context-stx
             (let ([tmp-for-right compiled-right])
               (if (compiled-op compiled-left tmp-for-right) k-stx #f))))]))

    ;; And now we start up the recursion:
    (cmp-node->code/tmp node (syntax tmp-for-right) (syntax #t)))
  
  
  ;; And atomic values can stay as they are.
  (define (atom-node->code atom-stx)
    atom-stx))