#lang racket/base

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

(require racket/match)
(require racket/set)
(require "record.rkt")
(require "read-text-generic.rkt")
(require syntax/readerr)

(define *reader-name* 'read-preserve/text)

(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 *reader-name* p source "Unexpected end of input"))
  (skip-whitespace p)
  (when (not (eof-object? (peek-char p)))
    (parse-error *reader-name* p source "Unexpected text following preserve"))
  v)

(define text-reader
  (make-preserve-text-reader
   #:reader-name *reader-name*
   #:on-hash (lambda (in-port source next parse-error* default)
               (match-lambda
                 [#\{ (sequence-fold in-port
                                     source
                                     next
                                     skip-whitespace/commas
                                     (set)
                                     (lambda (s e)
                                       (when (set-member? s e)
                                         (parse-error* "Duplicate set element: ~v" e))
                                       (set-add s e))
                                     values
                                     #\})]
                 [c (default c)]))
   #:on-char (lambda (in-port source next parse-error* default)
               (match-lambda
                 [#\< (match (read-sequence in-port source next skip-whitespace #\>)
                        ['() (parse-error* "Missing record label")]
                        [(cons label fields) (record label fields)])]
                 [#\[ (read-sequence in-port source next skip-whitespace/commas #\])]
                 [#\{ (read-dictionary in-port source next parse-error*)]

                 [#\; (parse-error* "Semicolon is reserved syntax")]
                 [#\: (parse-error* "Unexpected key/value separator between items")]
                 [#\> (parse-error* "Unexpected >")]
                 [#\] (parse-error* "Unexpected ]")]
                 [#\} (parse-error* "Unexpected }")]
                 [#\, (parse-error* "Unexpected ,")]

                 [c (default c)]))))

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

(define (read-sequence in-port source next skip-ws terminator)
  (sequence-fold in-port source next skip-ws '() (lambda (acc v) (cons v acc)) reverse terminator))

(define (read-dictionary in-port source next parse-error*)
  (sequence-fold in-port
                 source
                 next
                 skip-whitespace/commas
                 (hash)
                 (lambda (acc k)
                   (skip-whitespace in-port)
                   (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
                 #\}))

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