#lang racket/base

(provide read-pexpr
         string->pexpr

         pexpr->preserve
         preserve->pexpr

         write-pexpr
         write-pexprs

         COMMA
         SEMICOLON
         TRAILER-ANCHOR
         COLONS

         *COMMA*
         *SEMICOLON*
         *TRAILER-ANCHOR*

         RECORD
         BLOCK
         GROUP
         SET

         remove-trailer)

(require (for-syntax racket/base))
(require racket/match)
(require racket/set)
(require "record.rkt")
(require "annotation.rkt")
(require "embedded.rkt")
(require "read-text-generic.rkt")
(require (only-in racket/list append-map))

(define *reader-name* 'read-pexpr)

(define *COMMA* (record 'p '(|,|)))
(define *SEMICOLON* (record 'p '(|;|)))
(define *TRAILER-ANCHOR* (record 'a '()))

(define-match-expander COMMA
  (syntax-rules () [(_) (strip-annotations (== *COMMA*) #:depth 3)])
  (lambda (stx)
    (syntax-case stx ()
      [(_) #'*COMMA*]
      [_ #'(lambda () *COMMA*)])))

(define-match-expander SEMICOLON
  (syntax-rules () [(_) (strip-annotations (== *SEMICOLON*) #:depth 3)])
  (lambda (stx)
    (syntax-case stx ()
      [(_) #'*SEMICOLON*]
      [_ #'(lambda () *SEMICOLON*)])))

(define-match-expander TRAILER-ANCHOR
  (syntax-rules () [(_) (strip-annotations (== *TRAILER-ANCHOR*) #:depth 2)])
  (lambda (stx)
    (syntax-case stx ()
      [(_) #'*TRAILER-ANCHOR*]
      [_ #'(lambda () *TRAILER-ANCHOR*)])))

(define-match-expander RECORD
  (syntax-rules () [(_ ps ...) (strip-annotations (record 'r (list ps ...)) #:depth 2)])
  (lambda (stx)
    (syntax-case stx ()
      [(_ v ...) #'(record 'r (list v ...))]
      [_ #'(lambda vs (record 'r vs))])))

(define-match-expander BLOCK
  (syntax-rules () [(_ ps ...) (strip-annotations (record 'b (list ps ...)) #:depth 2)])
  (lambda (stx)
    (syntax-case stx ()
      [(_ v ...) #'(record 'b (list v ...))]
      [_ #'(lambda vs (record 'b vs))])))

(define-match-expander GROUP
  (syntax-rules () [(_ ps ...) (strip-annotations (record 'g (list ps ...)) #:depth 2)])
  (lambda (stx)
    (syntax-case stx ()
      [(_ v ...) #'(record 'g (list v ...))]
      [_ #'(lambda vs (record 'g vs))])))

(define-match-expander SET
  (syntax-rules () [(_ ps ...) (strip-annotations (record 's (list ps ...)) #:depth 2)])
  (lambda (stx)
    (syntax-case stx ()
      [(_ v ...) #'(record 's (list v ...))]
      [_ #'(lambda vs (record 's vs))])))

(define (colon-sym-length s)
  (and (symbol? s)
       (let ((s (string->list (symbol->string s))))
         (and (andmap (lambda (c) (eqv? c #\:)) s)
              (length s)))))

(define (colon-sym n) (string->symbol (make-string n #\:)))
(define (make-colons n) (record 'p (list (colon-sym n))))

(define-match-expander COLONS
  (syntax-rules () [(_ n) (strip-annotations (record 'p (list (app colon-sym-length n))) #:depth 3)])
  (lambda (stx)
    (syntax-case stx ()
      [(_ n) (let ((s (string->symbol (make-string (syntax->datum #'n) #\:)))) #`(record 'p '(#,s)))]
      [_ #'make-colons])))

(define (remove-trailer ps)
  (filter (match-lambda [(TRAILER-ANCHOR) #f] [_ #t]) ps))

(define pexpr-reader
  (make-preserve-text-reader
   #:reader-name *reader-name*
   #:read-annotated-value (lambda (in-port source next parse-error*)
                            (lambda ()
                              (skip-whitespace in-port)
                              (match (peek-char in-port)
                                [(or (? eof-object?) #\] #\> #\} #\)) *TRAILER-ANCHOR*]
                                [_ (next)])))
   #:on-hash (lambda (in-port source next parse-error* default)
               (match-lambda
                 [#\{ (read-sequence 's in-port source next #\})]
                 [c (default c)]))
   #:on-char (lambda (in-port source next parse-error* default)
               (match-lambda
                 [#\< (read-sequence 'r in-port source next #\>)]
                 [#\[ (read-sequence #f in-port source next #\])]
                 [#\{ (read-sequence 'b in-port source next #\})]
                 [#\( (read-sequence 'g in-port source next #\))]
                 [#\, *COMMA*]
                 [#\; *SEMICOLON*]
                 [#\: (let loop ((acc '(#\:)))
                        (match (peek-char in-port)
                          [#\: (loop (cons (read-char in-port) acc))]
                          [_ (record 'p (list (string->symbol (list->string (reverse acc)))))]))]
                 [c (default c)]))))

(define string->pexpr (make-preserve-string-reader *reader-name* pexpr-reader))

(define (read-sequence record-label in-port source next terminator-char)
  (let loop ((acc '()))
    (skip-whitespace in-port)
    (match (eof-guard *reader-name* in-port source (peek-char in-port))
      [(== terminator-char)
       (read-char in-port)
       (if record-label
           (record record-label (reverse acc))
           (reverse acc))]
      [_
       (match (next)
         [(record 'a '()) ;; skip bare annotation-anchors
          ;; NB. Not matching (TRAILER-ANCHOR)! That would skip *non-bare* anchors too!
          (loop acc)]
         [v (loop (cons v acc))])])))

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

;;---------------------------------------------------------------------------

(define (uncomma p
                 #:map-embedded [map-embedded (lambda (walk v) (walk v))])
  (define (walk-seq ps)
    (map walk (filter (match-lambda [(COMMA) #f] [_ #t]) ps)))

  (define (walk p)
    (match p
      [(? list? ps) (walk-seq ps)]
      [(RECORD ps ...) (apply RECORD (walk-seq ps))]
      [(GROUP ps ...) (apply GROUP (walk-seq ps))]
      [(BLOCK ps ...) (apply BLOCK (walk-seq ps))]
      [(SET ps ...) (apply SET (walk-seq ps))]
      [(embedded v) (map-embedded walk v)]
      [(annotated as loc v) (annotated (map walk as) loc (walk v))]
      [(COMMA) (error 'uncomma "Cannot remove commas from term with comma outside container")]
      [v v]))

  (walk p))

(define (pexpr->preserve p
                         #:discard-trailers? [discard-trailers? #f]
                         #:map-embedded [map-embedded (lambda (walk v) (walk v))])
  (define untrailer (if discard-trailers? remove-trailer values))
  (let walk ((p (uncomma p #:map-embedded map-embedded)))
    (match p
      [(list ps ...)
       (map walk (untrailer ps))]
      [(RECORD l ps ...) (record (walk l) (map walk (untrailer ps)))]
      [(GROUP _ ...) (error 'pexpr->preserve "Cannot convert uninterpreted grouping")]
      [(BLOCK ps ...)
       (let loop ((acc (hash)) (ps (untrailer ps)))
         (match ps
           [(list)
            acc]
           [(list k0 (COLONS 1) v more ...)
            (define k (walk k0))
            (if (hash-has-key? acc k)
                (error 'pexpr->preserve "Duplicate key in dictionary: ~v" k)
                (loop (hash-set acc k (walk v)) more))]
           [_
            (error 'pexpr->preserve "Cannot convert invalid dictionary")]))]
      [(SET ps ...)
       (let loop ((acc (set)) (ps (untrailer ps)))
         (match ps
           ['() acc]
           [(cons v0 more)
            (define v (walk v0))
            (if (set-member? acc v)
                (error 'pexpr->preserve "Duplicate item in set: ~v" v)
                (loop (set-add acc v) more))]))]
      [(SEMICOLON) (error 'pexpr->preserve "Cannot convert semicolon")]
      [(COLONS _) (error 'pexpr->preserve "Cannot convert colons")]
      [(TRAILER-ANCHOR) (error 'pexpr->preserve "Cannot convert trailer")]
      [(embedded v) (map-embedded walk v)]
      [(annotated as loc v) (annotated (map walk as) loc (walk v))]
      [v v])))

(define (preserve->pexpr v #:map-embedded [map-embedded (lambda (walk v) (walk v))])
  (let walk ((v v))
    (match v
      [(list vs ...) (map walk vs)]
      [(? set?) (record 's (map walk (set->list v)))]
      [(hash-table (kk vv) ...)
       (record 'b (append-map (lambda (kk vv) (list (walk kk) (COLONS 1) (walk vv)))
                              kk vv))]
      [(record l fs) (record 'r (map walk (cons l fs)))]
      [(embedded v) (map-embedded walk v)]
      [(annotated as loc v) (annotated (map walk as) loc (walk v))]
      [v v])))

(define (write-pexpr v0 [o (current-output-port)]
                     #:outer-sequence? [outer-sequence? #f]
                     #:indent [indent-amount 4]
                     #:encode-embedded [encode-embedded #f]
                     #:write-annotations? [write-annotations? #t])
  (local-require "block-write.rkt")
  (local-require "write-text.rkt")

  (define (space span)
    (if (null? span)
        '()
        (cons " " span)))

  (define (convert-inner vs)
    (define (finish-span span spans)
      (if (null? span)
          spans
          (cons (reverse span) spans)))
    (let loop ((es (map convert vs)) (spans '()) (span '()))
      (match es
        ['() (reverse (finish-span span spans))]
        [(cons ";" more) (loop more (finish-span (cons ";" span) spans) '())]
        [(cons "," more) (loop more (finish-span (cons "," span) spans) '())]
        [(cons ":" more) (loop more spans (cons ":" span))]
        [(cons (? string? s) more) (loop more spans (cons s (space span)))]
        [(cons (? separated? e) more) (loop more (finish-span span spans) (list e))]
        [(cons (and e (grouped _ _ _ "{ " " }")) more) (loop more (finish-span (cons e (space span)) spans) '())]
        [(cons (and e (grouped _ _ _ "<" ">")) more) (loop more spans (cons e (space span)))]
        [(cons (and e (grouped _ _ _ "[" "]")) more) (loop more spans (cons e (space span)))]
        [(cons e more) (loop more spans (cons e span))])))

  (define (convert v)
    (match v
      [(annotated as _loc v)
       (if (and (pair? as) write-annotations?)
           (separated (append (map (lambda (a) (list "@" (convert a))) as)
                              (match v
                                [(TRAILER-ANCHOR) '()]
                                [_ (list (convert v))]))
                      " "
                      "")
           (convert v))]
      [(? list? ps) (grouped (convert-inner ps) " " "" "[" "]")]
      [(RECORD ps ...) (grouped (convert-inner ps) " " "" "<" ">")]
      [(GROUP ps ...) (grouped (convert-inner ps) " " "" "(" ")")]
      [(BLOCK ps ...) (grouped (convert-inner ps) " " "" "{ " " }")]
      [(SET ps ...) (grouped (convert-inner ps) " " "" "#{ " " }")]
      [(TRAILER-ANCHOR) ""]
      [(embedded v) (list "#!" (convert (encode-embedded v)))]
      [(strip-annotations (record 'p (list s))) (symbol->string s)]
      [v (preserve->string v)]))

  (emit (if outer-sequence?
            (separated (convert-inner v0) " " "")
            (convert v0))
        o
        #:indentation indent-amount))

(define (write-pexprs vs [o (current-output-port)]
                      #:indent [indent-amount 4]
                      #:encode-embedded [encode-embedded #f]
                      #:write-annotations? [write-annotations? #t])
  (write-pexpr vs o
               #:outer-sequence? #t
               #:indent indent-amount
               #:encode-embedded encode-embedded
               #:write-annotations? write-annotations?))
