preserves/implementations/racket/preserves/preserves/read-text.rkt

#lang racket/base

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

(require racket/match)
(require racket/set)
(require "annotation.rkt")
(require "read-binary.rkt")
(require "record.rkt")
(require "float.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-intpart (list #\-) (next-char))]
      [(and c (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (read-intpart '() c)]
      [#\" (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 (if (eqv? (next-char) #\")
                      (read-hex-binary '())
                      (parse-error "Expected open-quote at start of hex ByteString"))]
             [#\[ (read-base64-binary '())]
             [#\= (define bs (read-preserve/text in-port #:read-syntax? #t #:source source))
                  (when (not (bytes? (annotated-item bs)))
                    (parse-error "ByteString must follow #="))
                  (when (not (null? (annotated-annotations bs)))
                    (parse-error "Annotations not permitted after #="))
                  (bytes->preserve
                   (annotated-item bs)
                   (lambda (message . args)
                     (apply parse-error (string-append "Embedded binary value: " message) args))
                   #:read-syntax? read-syntax?
                   #:on-short (lambda () (parse-error "Incomplete embedded binary value")))]
             [#\! (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 (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)))

  ;;---------------------------------------------------------------------------
  ;; Numbers

  (define (read-intpart acc-rev ch)
    (match ch
      [#\0 (read-fracexp (cons ch acc-rev))]
      [_ (read-digit+ acc-rev read-fracexp ch)]))

  (define (read-digit* acc-rev k)
    (match (peek-char in-port)
      [(? char? (? char-numeric?)) (read-digit* (cons (read-char in-port) acc-rev) k)]
      [_ (k acc-rev)]))

  (define (read-digit+ acc-rev k [ch (read-char in-port)])
    (match ch
      [(? char? (? char-numeric?)) (read-digit* (cons ch acc-rev) k)]
      [_ (parse-error "Incomplete number")]))

  (define (read-fracexp acc-rev)
    (match (peek-char in-port)
      [#\. (read-digit+ (cons (read-char in-port) acc-rev) read-exp)]
      [_ (read-exp acc-rev)]))

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

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

  (define (finish-number acc-rev)
    (define s (list->string (reverse acc-rev)))
    (define n (string->number s 10))
    (when (not n) (parse-error "Invalid number: ~v" s))
    (if (flonum? n)
        (match (peek-char in-port)
          [(or #\f #\F) (read-char in-port) (float n)]
          [_ n])
        n))

  ;;---------------------------------------------------------------------------
  ;; 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")]))

  ;;---------------------------------------------------------------------------
  ;; 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))))]
          [(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

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

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

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