#lang racket/base

(provide parse-schema-dsl
         port->schema
         file->schema)

(require racket/match)
(require racket/set)
(require racket/dict)
(require (only-in racket/list splitf-at))
(require (only-in racket/string string-split))
(require preserves)

(require (only-in "checker.rkt" valid-id?))
(require "gen/schema.rkt")

(define (split-by items separator)
  (let loop ((items items) (acc-rev '()))
    (if (null? items)
        (reverse acc-rev)
        (let-values (((head separator-and-rest)
                      (splitf-at items (lambda (x) (not (preserve=? x separator))))))
          (loop (if (pair? separator-and-rest)
                    (cdr separator-and-rest)
                    separator-and-rest)
                (if (null? head)
                    acc-rev
                    (cons head acc-rev)))))))

(define (input->string input)
  (preserve->string input #:commas? #f))

(define (parse-schema-dsl toplevel-tokens
                          #:source [source #f]
                          #:read-include [read-include #f])
  (define version #f)
  (define embeddedType (EmbeddedTypeName-false))
  (define definitions (make-hash))

  (define (process toplevel-tokens source)
    (for [(clause (in-list (split-by (peel-annotations toplevel-tokens) '|.|)))]
      (match clause
        [`(,(peel-annotations 'version) ,(peel-annotations v))
         (set! version (parse-Version! (strip-annotations v)))]
        [`(,(peel-annotations 'embeddedType) ,(peel-annotations #f))
         (set! embeddedType (EmbeddedTypeName-false))]
        [`(,(peel-annotations 'embeddedType) ,(peel-annotations (? valid-qid? r)))
         (set! embeddedType (EmbeddedTypeName-Ref (parse-ref-dsl r)))]
        [`(,(peel-annotations 'include) ,(peel-annotations (? string? path)))
         (when (not read-include)
           (error 'parse-schema-dsl "Cannot include files"))
         (define new-source
           (cond [(absolute-path? path) path]
                 [(not source) (error 'parse-schema-dsl "Cannot resolve relative include path")]
                 [else (simplify-path (build-path source 'up path) #f)]))
         (process (read-include new-source) new-source)]
        [`(,(peel-annotations (? valid-id? name)) ,(peel-annotations '=) ,@def-stx)
         (when (hash-has-key? definitions name)
           (error 'parse-schema-dsl "Duplicate definition: ~a" name))
         (hash-set! definitions name (parse-def-dsl name def-stx))]
        [clause (error 'parse-schema-dsl "Invalid clause: ~a" (input->string clause))])))

  (process toplevel-tokens source)
  (when (not version) (error 'parse-schema "Missing version declaration"))
  (Schema (Definitions definitions) embeddedType version))

(define (symbol-pieces s)
  (map string->symbol (string-split (symbol->string s) ".")))

(define (valid-qid? x)
  (and (symbol? x)
       (andmap valid-id? (symbol-pieces x))))

(define (qid-last n)
  (car (reverse (symbol-pieces n))))

(define (parse-ref-dsl s)
  (match-define (list module-path ... final-id) (symbol-pieces s))
  (Ref (ModulePath module-path) final-id))

(define (namelike v)
  (match v
    [(? string? s) (string->symbol s)]
    [(? symbol? s) s]
    [(? number? n) (string->symbol (number->string n))]
    [(? boolean? b) (if b 'true 'false)]
    [_ #f]))

(define (parse-def-dsl name def-stx)
  (define (and-branch input)
    (define p (parse-pattern-dsl name input))
    (match (or (find-name input) (find-name (car input)))
      [#f
       (NamedPattern-anonymous p)]
      [n
       (when (not (Pattern-SimplePattern? p))
         (error 'parse-def-dsl "Named pattern in 'and' must be simple: ~a" (input->string input)))
       (NamedPattern-named (Binding n (Pattern-SimplePattern-value p)))]))
  (define (or-branch input)
    (define p (parse-pattern-dsl name input))
    (match (or (find-name input) (find-name (car input)))
      [(and n (not #f)) (NamedAlternative (symbol->string n) p)]
      [#f (match p
            [(Pattern-CompoundPattern
              (CompoundPattern-rec
               (NamedPattern-anonymous
                (Pattern-SimplePattern
                 (SimplePattern-lit (? valid-id? n))))
               _))
             (NamedAlternative (symbol->string n) p)]
            [(Pattern-SimplePattern (SimplePattern-Ref (Ref _ (? valid-qid? n))))
             (NamedAlternative (symbol->string (qid-last n)) p)]
            [(Pattern-SimplePattern (SimplePattern-lit (app namelike (? valid-id? n))))
             (NamedAlternative (symbol->string n) p)]
            [_
             (error 'parse-def-dsl "Name missing for alternative: ~a" (input->string input))])]))
  (match* [(split-by def-stx '&) (split-by def-stx '/)]
    [['() '()]
     (error 'parse-def-dsl "Invalid clause in ~a" name)]
    [[(list* _ _ _) (list* _ _ _)]
     (error 'parse-def-dsl "Mixed 'or' and 'and' clause: ~a" (input->string def-stx))]
    [[(list* p0 p1 pN) (list _)]
     (Definition-and (and-branch p0) (and-branch p1) (map and-branch pN))]
    [[(list _) (list* p0 p1 pN)]
     (Definition-or (or-branch p0) (or-branch p1) (map or-branch pN))]
    [[(list p) (list _)]
     (Definition-Pattern (parse-pattern-dsl name p))]))

(define (parse-pattern-dsl name input)

  (define (parse-simple-dsl item ks kf)
    (match (peel-annotations item)
      ['any (ks (SimplePattern-any))]
      ['bool (ks (SimplePattern-atom (AtomKind-Boolean)))]
      ['float (ks (SimplePattern-atom (AtomKind-Float)))]
      ['double (ks (SimplePattern-atom (AtomKind-Double)))]
      ['int (ks (SimplePattern-atom (AtomKind-SignedInteger)))]
      ['string (ks (SimplePattern-atom (AtomKind-String)))]
      ['bytes (ks (SimplePattern-atom (AtomKind-ByteString)))]
      ['symbol (ks (SimplePattern-atom (AtomKind-Symbol)))]
      [(? symbol? sym)
       (define str (symbol->string sym))
       (cond
         [(and (> (string-length str) 0) (string=? (substring str 0 1) "="))
          (ks (SimplePattern-lit (string->symbol (substring str 1))))]
         [(valid-qid? sym)
          (ks (SimplePattern-Ref (parse-ref-dsl sym)))]
         [else
          (error 'parse-simple-dsl "Invalid schema name reference: ~a" sym)])]
      [(strip-annotations (record (record 'lit '()) lit-pat))
       (match lit-pat
         [(list v) (ks (SimplePattern-lit v))]
         [_ (error 'parse-simple-dsl "Invalid <<lit> ...> pattern: ~a" (input->string item))])]
      [(list stx (peel-annotations '...)) (ks (SimplePattern-seqof (walk-simple stx)))]
      [(? set? s)
       (when (not (= (set-count s) 1))
         (error 'parse-simple-dsl "Invalid set pattern: ~a" (input->string item)))
       (ks (SimplePattern-setof (walk-simple (car (set->list s)))))]
      [(hash-table ((peel-annotations '...) (peel-annotations '...)) (kp vp))
       (ks (SimplePattern-dictof (walk-simple kp) (walk-simple vp)))]
      [(embedded interface-pat) (ks (SimplePattern-embedded (walk-simple interface-pat)))]
      [(or (? list?) (? set?) (? dict?) (? record?)) (kf)]
      [(strip-annotations v) (ks (SimplePattern-lit v))]))

  (define (parse-compound-dsl item)
    (match (peel-annotations item)
      [(record (strip-annotations (record 'rec '())) fields-pat)
       (match fields-pat
         [(peel-annotations (list label fields))
          (CompoundPattern-rec (maybe-named label) (maybe-named fields))]
         [_ (error 'parse-simple-dsl "Invalid <<rec> ...> pattern: ~a" (input->string item))])]
      [(record (strip-annotations label) (peel-annotations fields))
       (CompoundPattern-rec (NamedPattern-anonymous (Pattern-SimplePattern (SimplePattern-lit label)))
                            (NamedPattern-anonymous (walk fields)))]
      [(list fixed ... variable (peel-annotations '...))
       (CompoundPattern-tuplePrefix (map maybe-named fixed)
                                    (maybe-named-simple
                                     (apply annotate (list variable '...) (annotations variable))))]
      [(list item ...)
       (CompoundPattern-tuple (map maybe-named item))]
      [(? dict? d) #:when (not (dict-has-key? (strip-annotations d) '...))
       (CompoundPattern-dict (DictionaryEntries
                              (for/hash [((k0 vp) (in-dict d))]
                                (define k (strip-annotations k0))
                                (values k ((maybe-named* NamedSimplePattern-named
                                                         NamedSimplePattern-anonymous
                                                         walk-simple
                                                         k) vp)))))]
      [_ (error 'parse-pattern-dsl "Invalid pattern: ~a" (input->string input))]))

  (define (walk stx) (parse-pattern-dsl name (list stx)))
  (define (walk-simple stx)
    (parse-simple-dsl stx
                      values
                      (lambda () (error 'parse-simple-dsl "Compound patterns not accepted here: ~a" (input->string stx)))))

  (define ((maybe-named* knamed kanonymous recur [literal-name #f]) b)
    (define n (or (find-name b)
                  (and (valid-id? literal-name) literal-name)))
    (if n
        (let ((p (parse-simple-dsl
                  b
                  values
                  (lambda () (error 'parse-pattern-dsl "Named pattern must be simple: ~a"
                                    (input->string b))))))
          (knamed (Binding n p)))
        (kanonymous (recur b))))

  (define maybe-named
    (maybe-named* NamedPattern-named NamedPattern-anonymous walk))

  (define maybe-named-simple
    (maybe-named* NamedSimplePattern-named NamedSimplePattern-anonymous walk-simple))

  (if (not (= (length input) 1))
      (error 'parse-pattern-dsl "Invalid pattern: ~a" (input->string input))
      (parse-simple-dsl (car input)
                        Pattern-SimplePattern
                        (lambda () (Pattern-CompoundPattern (parse-compound-dsl (car input)))))))

(define (find-name input)
  (findf valid-id? (map peel-annotations (annotations input))))

(define (port->schema src [p (current-input-port)])
  (parse-schema-dsl (port->preserves p
                                     #:decode-embedded values
                                     #:read-syntax? #t
                                     #:source src)
                    #:source src
                    #:read-include (and src (lambda (src)
                                              (file->preserves src
                                                               #:decode-embedded values
                                                               #:read-syntax? #t)))))

(define (file->schema src)
  (call-with-input-file src (lambda (p) (port->schema src p))))

(module+ main
  (require preserves)
  (require "methods.rkt")
  (define expected (car (time (file->preserves "../../../../schema/schema.bin"))))
  (define actual (time (file->schema "../../../../schema/schema.prs")))
  (equal? expected (time (->preserve actual))))
