#lang racket/base
(require parser-tools/lex
         (prefix-in : parser-tools/lex-sre)
         2htdp/image
         "../lexer.rkt"
)

(provide get-syntax-token)

(define (syn-val lex a b c d)
  (values lex a b (position-offset c) (position-offset d)))

(define (colorize-string my-start-pos)
  (define lxr
    (lexer
     [(:~ #\" #\\) (lxr input-port)]
     [(:: #\\ #\\) (lxr input-port)]
     [(:: #\\ #\newline) (lxr input-port)]
     [(:: #\\ #\") (lxr input-port)]
     [(eof) (syn-val "" 'error #f my-start-pos end-pos)]
     [#\" (syn-val "" 'string #f my-start-pos end-pos)]))
  lxr)

(define (suck-up-comment ip)
  (define (helper str l)
    (define current-position (file-position ip))
    (let ((next (read-char-or-special ip)))
      (if (eof-object? next)
          (values str l)
          (if (char? next)
              (if (equal? #\newline next)
                  (values (string-append str "\n") (add1 l))
                  (helper (string-append str (string next)) (add1 l)))
              ; we don't know what this is, so skip it
              (helper str (+ l (- (file-position ip) current-position)))))))
                  
  (helper "" 0))

(define (lex-string ip target-char start-pos)
  (define (helper str current-pos skip?)
    (let ((next (read-char-or-special ip)))
      (if (eof-object? next)
          (syn-val str 'string #f start-pos current-pos)
          (if (not (char? next))
              (syn-val str 'error #f start-pos current-pos)
              (let-values (((next-line next-col next-off)
                            (port-next-location ip)))
                (let ((next-pos (make-position next-off next-line next-col)))
                  (if (equal? next #\\)
                      (helper (string-append str (string #\\)) next-pos (not skip?))
                      (if (and (equal? next target-char)
                               (not skip?))
                          (syn-val (string-append str (string next)) 'string #f start-pos next-pos)
                          (helper (string-append str (string next)) next-pos #f)))))))))
  (let-values (((next-line next-col next-off)
                (port-next-location ip)))
    (let ((next-pos (make-position next-off next-line next-col)))
      (helper (string target-char) next-pos #f))))

(define get-syntax-token
  (lexer
   [(:+ whitespace)
    (syn-val lexeme 'whitespace #f start-pos end-pos)]
   ; comments
   [#\#
    (let-values ([(rest-of-line len) (suck-up-comment input-port)])
      (syn-val (string-append lexeme rest-of-line)
               'comment
               #f
               start-pos
               (make-position (+ (position-offset start-pos) (add1 len))
                              (position-line start-pos)
                              (+ (position-col start-pos) (add1 len)))))]
;; ------------------------------------
;; keywords
   ["empty"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["True"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["False"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["def"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["and"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["or"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["not"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["if"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["elif"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["else"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   [":done"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["struct"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["len"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["in"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["fun"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["test"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["is"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["within"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["test_error"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["test_range"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["from"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["to"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["big_bang"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["init"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["on_tick"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["tick_rate"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["tick_limit"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["to_draw"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["draw_width"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["draw_height"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["on_key"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["on_pad"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["on_release"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["on_mouse"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["stop_when"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["last_scene"
    (syn-val lexeme 'keyword #f start-pos end-pos)]

;; ------------------------------------
   [".."
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["..."
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["...."
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["....."
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   ["......"
    (syn-val lexeme 'keyword #f start-pos end-pos)]
   [(:: "......" (:+ #\.))
    (syn-val lexeme 'error #f start-pos end-pos)]

;; ------------------------------------
   ; colon
   [#\:
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   ; semi-colon
   [#\;
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   ; comma
   [#\,
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   ; brackets and parentheses
   [(:or #\( #\) #\[ #\])
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   ; dot
   [#\.
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   ; integers
   [(:: (:/ #\0 #\9) (:* alpha-numeric-re))
    (syn-val lexeme 'constant #f start-pos end-pos)]
   ; floating point
   [float-re
    (syn-val lexeme 'constant #f start-pos end-pos)]
   ; imaginary numbers
   [imag-re
    (syn-val lexeme 'constant #f start-pos end-pos)]
   ; strings
   [#\'
    (begin #;(displayln (peek-char input-port))
    (lex-string input-port #\' start-pos))]
   [#\"
    (lex-string input-port #\" start-pos)]
   [identifier-re
    (syn-val lexeme 'symbol #f start-pos end-pos)]
;; ------------------------------------
;; infix operators
   [#\+
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   [#\-
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   [#\*
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   [#\/
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   [#\%
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   [(:: #\* #\*)
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   [#\<
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   ["<="
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   ["="
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   ["!="
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   [">="
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]
   [">"
    (syn-val lexeme 'parenthesis #f start-pos end-pos)]

;; ------------------------------------
   [(eof) (syn-val lexeme 'eof #f start-pos end-pos)]
   #;[#\" ((colorize-string start-pos) input-port)]
   [any-char (syn-val lexeme 'symbol #f start-pos end-pos)]
   ; for images
   [(special)
    (syn-val lexeme 'no-color #f start-pos end-pos)]
  )
)