#lang racket/base

(provide read-preserve/text
         string->preserve)

(require racket/match)
(require racket/set)
(require "embedded.rkt")
(require "annotation.rkt")
(require "read-binary.rkt")
(require "record.rkt")
(require "float.rkt")
(require "float-bytes.rkt")
(require syntax/readerr)
(require (only-in file/sha1 hex-string->bytes))
(require (only-in net/base64 base64-decode))

(define PIPE #\|)

(define (parse-error* #:raise-proc [raise-proc raise-read-error] i source fmt . args)
  (define-values [line column pos] (port-next-location i))
  (raise-proc (format "read-preserve: ~a" (apply format fmt args))
              source
              line
              column
              pos
              #f))

(define (default-decode-embedded v)
  (error 'read-preserve/text "No decode-embedded function supplied"))

(define (string->preserve s
                          #:read-syntax? [read-syntax? #f]
                          #:decode-embedded [decode-embedded #f]
                          #:source [source "<string>"])
  (define p (open-input-string s))
  (when read-syntax? (port-count-lines! p))
  (define v (read-preserve/text p
                                #:read-syntax? read-syntax?
                                #:decode-embedded decode-embedded
                                #:source source))
  (when (eof-object? v)
    (parse-error* #:raise-proc raise-read-eof-error p source "Unexpected end of input"))
  (skip-whitespace* p)
  (when (not (eof-object? (peek-char p)))
    (parse-error* p source "Unexpected text following preserve"))
  v)

(define (skip-whitespace* i)
  (regexp-match? #px#"^(\\s|,)*" i)) ;; side effect: consumes matched portion of input

(define-match-expander px
  (syntax-rules ()
    [(_ re pat) (app (lambda (v) (regexp-try-match re v)) pat)]))

(define (read-preserve/text [in-port (current-input-port)]
                            #:read-syntax? [read-syntax? #f]
                            #:decode-embedded [decode-embedded0 #f]
                            #:source [source (object-name in-port)])
  (define read-annotations? read-syntax?)
  (define decode-embedded (or decode-embedded0 default-decode-embedded))

  ;;---------------------------------------------------------------------------
  ;; Core of parser

  (define (next) (wrap (pos) (next*)))

  (define (next*)
    (skip-whitespace)
    (match (next-char)
      [#\" (read-string #\")]
      [(== PIPE) (string->symbol (read-string PIPE))]

      [#\; (annotate-next-with (read-comment-line))]
      [#\@ (annotate-next-with (next))]

      [#\: (parse-error "Unexpected key/value separator between items")]

      [#\# (match (next-char)
             [#\f #f]
             [#\t #t]
             [#\{ (sequence-fold (set) set-add* values #\})]
             [#\" (read-literal-binary)]
             [#\x (match (next-char)
                    [#\" (read-hex-binary '())]
                    [#\f (read-hex-float 'float)]
                    [#\d (read-hex-float 'double)]
                    [c (parse-error "Invalid #x syntax: ~v" c)])]
             [#\[ (read-base64-binary '())]
             [#\! (embedded (decode-embedded (next)))]
             [c (parse-error "Invalid # syntax: ~v" c)])]

      [#\< (match (read-sequence #\>)
             ['() (parse-error "Missing record label")]
             [(cons label fields) (record label fields)])]
      [#\[ (read-sequence #\])]
      [#\{ (read-dictionary)]

      [#\> (parse-error "Unexpected >")]
      [#\] (parse-error "Unexpected ]")]
      [#\} (parse-error "Unexpected }")]

      [c (read-raw-symbol-or-number (list c))]))

  (define (set-add* s e)
    (when (set-member? s e) (parse-error "Duplicate set element: ~v" e))
    (set-add s e))

  (define (annotate-next-with a)
    (if read-annotations?
        (annotate (next) a)
        (next)))

  ;;---------------------------------------------------------------------------
  ;; Basic I/O

  (define (parse-error fmt . args)
    (apply parse-error* in-port source fmt args))

  (define (eof-guard v)
    (when (eof-object? v)
      (parse-error* #:raise-proc raise-read-eof-error in-port source "Unexpected end of input"))
    v)

  (define (next-char) (eof-guard (read-char in-port)))

  (define (skip-whitespace) (skip-whitespace* in-port))

  ;;---------------------------------------------------------------------------
  ;; Source location tracking

  (define pos
    (if read-syntax?
        (lambda ()
          (define-values (line column position) (port-next-location in-port))
          (list line column position))
        (lambda () #f)))

  (define wrap
    (if read-syntax?
        (lambda (pos0 v)
          (if (annotated? v)
              v
              (let ()
                (match-define (list line0 column0 position0) pos0)
                (match-define (list line1 column1 position1) (pos))
                (define loc (and line0 column0 position0 position1
                                 (srcloc source line0 column0 position0 (- position1 position0))))
                (annotated '() loc v))))
        (lambda (pos0 v) v)))

  ;;---------------------------------------------------------------------------
  ;; String-like things

  (define (read-stringlike xform-item finish terminator-char hexescape-char hexescape-proc)
    (let loop ((acc '()))
      (match (next-char)
        [(== terminator-char) (finish (reverse acc))]
        [#\\ (match (next-char)
               [(== hexescape-char) (loop (cons (hexescape-proc) acc))]
               [(and c (or (== terminator-char) #\\ #\/)) (loop (cons (xform-item c) acc))]
               [#\b (loop (cons (xform-item #\u08) acc))]
               [#\f (loop (cons (xform-item #\u0C) acc))]
               [#\n (loop (cons (xform-item #\u0A) acc))]
               [#\r (loop (cons (xform-item #\u0D) acc))]
               [#\t (loop (cons (xform-item #\u09) acc))]
               [c (parse-error "Invalid escape code \\~a" c)])]
        [c (loop (cons (xform-item c) acc))])))

  (define (read-string terminator-char)
    (read-stringlike values
                     list->string
                     terminator-char
                     #\u
                     (lambda ()
                       (integer->char
                        (match in-port
                          [(px #px#"^[a-fA-F0-9]{4}" (list hexdigits))
                           (define n1 (string->number (bytes->string/utf-8 hexdigits) 16))
                           (if (<= #xd800 n1 #xdfff) ;; surrogate pair first half
                               (match in-port
                                 [(px #px#"^\\\\u([a-fA-F0-9]{4})" (list _ hexdigits2))
                                  (define n2 (string->number (bytes->string/utf-8 hexdigits2) 16))
                                  (if (<= #xdc00 n2 #xdfff)
                                      (+ (arithmetic-shift (- n1 #xd800) 10)
                                         (- n2 #xdc00)
                                         #x10000)
                                      (parse-error "Bad second half of surrogate pair"))]
                                 [_ (parse-error "Missing second half of surrogate pair")])
                               n1)]
                          [_ (parse-error "Bad string \\u escape")])))))

  (define (read-literal-binary)
    (read-stringlike (lambda (c)
                       (define b (char->integer c))
                       (when (>= b 256)
                         (parse-error "Invalid code point ~a (~v) in literal binary" b c))
                       b)
                     list->bytes
                     #\"
                     #\x
                     (lambda ()
                       (match in-port
                         [(px #px#"^[a-fA-F0-9]{2}" (list hexdigits))
                          (string->number (bytes->string/utf-8 hexdigits) 16)]
                         [_ (parse-error "Bad binary \\x escape")]))))

  ;;---------------------------------------------------------------------------
  ;; Hex-encoded ByteStrings

  (define (hexdigit? ch)
    (or (and (char>=? ch #\A) (char<=? ch #\F))
        (and (char>=? ch #\a) (char<=? ch #\f))
        (and (char>=? ch #\0) (char<=? ch #\9))))

  (define (read-hex-binary acc)
    (skip-whitespace)
    (define ch (next-char))
    (cond [(eqv? ch #\")
           (hex-string->bytes (list->string (reverse acc)))]
          [(hexdigit? ch)
           (define ch2 (next-char))
           (when (not (hexdigit? ch2))
             (parse-error "Hex-encoded binary digits must come in pairs"))
           (read-hex-binary (cons ch2 (cons ch acc)))]
          [else
           (parse-error "Invalid hex character")]))

  ;;---------------------------------------------------------------------------
  ;; Hex-encoded floating point numbers

  (define (read-hex-float precision)
    (unless (eqv? (next-char) #\")
      (parse-error "Missing open-double-quote in hex-encoded floating-point number"))
    (define bs (read-hex-binary '()))
    (unless (= (bytes-length bs) (match precision ['float 4] ['double 8]))
      (parse-error "Incorrect number of bytes in hex-encoded floating-point number"))
    (match precision
      ['float (bytes->float bs)]
      ['double (bytes->double bs)]))

  ;;---------------------------------------------------------------------------
  ;; Base64-encoded ByteStrings

  (define (read-base64-binary acc)
    (skip-whitespace)
    (define ch (next-char))
    (cond [(eqv? ch #\])
           (base64-decode (string->bytes/latin-1 (list->string (reverse acc))))]
          [(char=? ch #\-) (read-base64-binary (cons #\+ acc))]
          [(char=? ch #\_) (read-base64-binary (cons #\/ acc))]
          [(or (and (char>=? ch #\A) (char<=? ch #\Z))
               (and (char>=? ch #\a) (char<=? ch #\z))
               (and (char>=? ch #\0) (char<=? ch #\9))
               (memv ch '(#\+ #\/ #\=)))
           (read-base64-binary (cons ch acc))]
          [else
           (parse-error "Invalid base64 character")]))

  ;;---------------------------------------------------------------------------
  ;; Comments

  (define (read-comment-line)
    (define pos0 (pos))
    (let loop ((acc '()))
      (match (next-char)
        [(or #\newline #\return)
         (wrap pos0 (list->string (reverse acc)))]
        [c (loop (cons c acc))])))

  ;;---------------------------------------------------------------------------
  ;; Collections

  (define (sequence-fold acc accumulate-one finish terminator-char)
    (let loop ((acc acc))
      (skip-whitespace)
      (match (eof-guard (peek-char in-port))
        [(== terminator-char) (read-char in-port) (finish acc)]
        [_ (loop (accumulate-one acc (next)))])))

  (define (read-sequence terminator)
    (sequence-fold '() (lambda (acc v) (cons v acc)) reverse terminator))

  (define (read-dictionary)
    (sequence-fold (hash)
                   (lambda (acc k)
                     (skip-whitespace)
                     (match (peek-char in-port)
                       [#\: (read-char in-port)
                            (when (hash-has-key? acc k) (parse-error "Duplicate key: ~v" k))
                            (hash-set acc k (next))]
                       [_ (parse-error "Missing expected key/value separator")]))
                   values
                   #\}))

  ;;---------------------------------------------------------------------------
  ;; "Raw" symbols and numbers

  (define (read-raw-symbol-or-number acc)
    (match (peek-char in-port)
      [(or (? eof-object?)
           (? char? (or #\( #\) #\{ #\} #\[ #\] #\< #\>
                        #\" #\; #\, #\@ #\# #\: (== PIPE)
                        (? char-whitespace?))))
       (let ((input (reverse acc)))
         (or (analyze-number input)
             (string->symbol (list->string input))))]
      [_ (read-raw-symbol-or-number (cons (read-char in-port) acc))]))

  (define (analyze-number input)
    (match input
      [(cons (and sign (or #\+ #\-)) input) (read-digit+ (list sign) read-fracexp input)]
      [_ (read-digit+ (list) read-fracexp input)]))

  (define (read-digit* acc-rev k input)
    (match input
      [(cons (? char? (? char-numeric? d)) input) (read-digit* (cons d acc-rev) k input)]
      [_ (k acc-rev input)]))

  (define (read-digit+ acc-rev k input)
    (match input
      [(cons (? char? (? char-numeric? d)) input) (read-digit* (cons d acc-rev) k input)]
      [_ #f]))

  (define (read-fracexp acc-rev input)
    (match input
      [(cons #\. input) (read-digit+ (cons #\. acc-rev) read-exp input)]
      [_ (read-exp acc-rev input)]))

  (define (read-exp acc-rev input)
    (match input
      [(cons (and e (or #\e #\E)) input) (read-sign-and-exp (cons e acc-rev) input)]
      [_ (finish-number acc-rev input)]))

  (define (read-sign-and-exp acc-rev input)
    (match input
      [(cons (and sign (or #\+ #\-)) input) (read-digit+ (cons sign acc-rev) finish-number input)]
      [_ (read-digit+ acc-rev finish-number input)]))

  (define (finish-number acc-rev input)
    (define s (list->string (reverse acc-rev)))
    (define n (string->number s 10))
    (cond [(not n) #f]
          [(and (flonum? n) (member input '((#\f) (#\F)))) (float n)]
          [(equal? input '()) n]
          [else #f]))

  ;;---------------------------------------------------------------------------
  ;; Main entry point to parser

  (skip-whitespace)
  (match (peek-char in-port)
    [(? eof-object?) eof]
    [_ (next)]))
