(module compile mzscheme
  (require (lib "match.ss")
           (lib "struct.ss"))

  (require (only (lib "lex.ss" "parser-tools")
                 position struct:position make-position position?
                 position-offset position-line position-col
                 set-position-offset! set-position-line! set-position-col!))

  ;; any * position * position
  (define-struct/properties region (source start end)
    ([prop:custom-write (lambda (r port write?)
                          (fprintf port
                                   "#<region:~a:~a-~a:~a>"
                                   (position-line (region-start r))
                                   (position-col (region-start r))
                                   (position-line (region-end r))
                                   (position-col (region-end r))))]))

  ;; region * symbol
  (define-struct id (loc name) #f)

  ;; region
  (define-struct Expr (loc) #f)
  ;; id * Expr
  (define-struct (FunExpr Expr) (var body) #f)
  ;; integer
  (define-struct (IntExpr Expr) (value) #f)
  ;; Expr * Expr
  (define-struct (AppExpr Expr) (rator rand) #f)
  ;; id
  (define-struct (VarExpr Expr) (name) #f)

  (define (current-position in)
    (let-values ([(line col offset) (port-next-location in)])
      (make-position offset line col)))

  ;; parse-expression : input-port -> (optional Expr)
  (define (parse-expression in)
    (skip-whitespace in)
    (and (not (eof-object? (peek-char in)))
         (begin0
           (cond
             [(regexp-match-peek-positions #rx"^fun([ \t\r\n]|$)" in)
              => (lambda (match)
                   (let ([start (current-position in)])
                     (read-string 3 in)
                     (skip-whitespace in)
                     (let ([x (parse-identifier in)])
                       (skip-whitespace in)
                       (parse-literal "." in)
                       (skip-whitespace in)
                       (let ([body (parse-expression in)]
                             [loc (make-region (object-name in) start (current-position in))])
                         (make-FunExpr loc x body)))))]
             [(regexp-match-peek-positions #rx"^[0-9]+" in)
              => (lambda (match)
                   (let ([start (current-position in)]
                         [num (string->number (read-string (cdar match) in))])
                     (make-IntExpr (make-region (object-name in) start (current-position in)) num)))]
             [(regexp-match-peek-positions #rx"^\\(" in)
              => (lambda (match)
                   (let ([start (current-position in)])
                     (read-char in)
                     (let ([rator (parse-expression in)])
                       (skip-whitespace in)
                       (let ([rand (parse-expression in)])
                         (skip-whitespace in)
                         (parse-literal ")" in)
                         (make-AppExpr (make-region (object-name in) start (current-position in)) rator rand)))))]
             [else
              (let ([start (current-position in)]
                    [x (parse-identifier in)])
                (make-VarExpr (make-region (object-name in) start (current-position in)) x))])
           (skip-whitespace in))))

  (define (parse-identifier in)
    (let ([match (regexp-match-peek-positions #rx"^[a-zA-Z]+" in)])
      (unless match
        (raise-syntax-error 'parse "invalid identifier"))
      (let ([start (current-position in)]
            [name (string->symbol (read-string (cdar match) in))])
        (make-id (make-region (object-name in) start (current-position in)) name))))

  (define (parse-literal lit in)
    (let ([next (peek-string (string-length lit) 0 in)])
      (unless (equal? next lit)
        (raise-syntax-error 'parse "expected ~a" lit))
      (read-string (string-length lit) in)))

  (define (skip-whitespace in)
    (cond
      [(regexp-match-peek-positions #rx"^[ \t\r\n]+" in)
       => (lambda (match)
            (read-string (cdar match) in)
            (void))]))

  (define stx-for-original-property (read-syntax #f (open-input-string "here")))

  ;; build-syntax : any * region -> syntax
  (define (build-syntax expr loc)
    (datum->syntax-object #f
                          expr
                          (and loc (location->syntax loc))
                          stx-for-original-property))

  ;; location->syntax : region -> syntax
  (define (location->syntax loc)
    (let ([start (region-start loc)]
          [end (region-end loc)])
      (datum->syntax-object #f
                            'source-location
                            (list
                              (region-source loc)
                              (position-line start)
                              (position-col start)
                              (position-offset start)
                              (- (position-offset end) (position-offset start)))
                            stx-for-original-property)))

  ;; id->syntax : id -> syntax
  (define (id->syntax id)
    (build-syntax (id-name id) (id-loc id)))

  ;; compile-expression : (optional Expr) -> syntax
  (define (compile-expression expr)
    (match expr
      [($ FunExpr loc var body)
       (with-syntax ([x (id->syntax var)]
                     [body-e (compile-expression body)])
         (build-syntax #'(lambda (x) body-e) loc))]
      [($ IntExpr loc value)
       (build-syntax value loc)]
      [($ AppExpr loc rator rand)
       (with-syntax ([rator-e (compile-expression rator)]
                     [rand-e (compile-expression rand)]
                     [(v) (generate-temporaries '(v))])
         (build-syntax #'(let ([v rator-e])
                           (if (procedure? v)
                               (v rand-e)
                               (error 'app "not a procedure")))
                       loc))]
      [($ VarExpr loc id)
       (build-syntax (id->syntax id) loc)]
      [#f #'(void)]))

  (provide parse-expression compile-expression))