(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"))
  
  
  
  
  
  ;                                                                                     
  ;                                                                                     
  ;  ;;;;;;;       ;;                      ;                           ;                
  ;  ;  ;  ;        ;                                          ;                        
  ;     ;     ;;;   ; ;;;   ;;;  ;; ;;   ;;;    ;;;;;   ;;;   ;;;;;  ;;;     ;;;  ;; ;; 
  ;     ;    ;   ;  ;  ;   ;   ;  ;;  ;    ;    ;  ;   ;   ;   ;       ;    ;   ;  ;;  ;
  ;     ;    ;   ;  ;;;    ;;;;;  ;   ;    ;      ;     ;;;;   ;       ;    ;   ;  ;   ;
  ;     ;    ;   ;  ; ;    ;      ;   ;    ;     ;     ;   ;   ;       ;    ;   ;  ;   ;
  ;     ;    ;   ;  ;  ;   ;      ;   ;    ;    ;   ;  ;   ;   ;   ;   ;    ;   ;  ;   ;
  ;    ;;;    ;;;  ;; ;;;;  ;;;; ;;; ;;; ;;;;;  ;;;;;   ;;;;;   ;;;  ;;;;;   ;;;  ;;; ;;;
  ;                                                                                     
  ;                                                                                     
  ;                                                                                     
  ;                                                                                     
  
  (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))
    
    (define identifier=? module-transformer-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) identifier=?
      ;; unquote unfolded as comma
      [(unquote e)
       (cons (token-comma stx)
             (syntax->token-list (syntax e)))]
      ;; lists unfolded as lparen ... rparen
      [(e ...)
       `( ,(token-lparen stx) 
           ,@(apply append (map syntax->token-list (syntax-e (syntax (e ...)))))
           ,(token-rparen stx))]
      [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)
    (let ([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.
      (datum->syntax-object 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 k-stx)
      (match node
        [(struct cmp-node (op (and left
                                   (struct cmp-node (op-child l-child r-child)))
                              right))
         (let* ([fresh-tmp (syntax fresh-tmp)]
                [new-k-stx
                 (datum->syntax-object context-stx
                                       ` (let ([,tmp ,(expression->code right context-stx)])
                                           (if (,(expression->code op context-stx)
                                                 ,fresh-tmp ,tmp)
                                               ,k-stx
                                               #f)))])
           (cmp-node->code/tmp left fresh-tmp new-k-stx))]
        
        [(struct cmp-node (op l r))
         (datum->syntax-object context-stx
                               ` (let ([,tmp ,(expression->code r context-stx)])
                                   (if (,(expression->code op context-stx)
                                         ,(expression->code l context-stx) ,tmp)
                                       ,k-stx
                                       #f)))]))
    (cmp-node->code/tmp node
                        (syntax tmp-1)
                        (datum->syntax-object context-stx #t)))

  
  ;; And atomic values can stay as they are.
  (define (atom-node->code atom-stx)
    atom-stx))