#lang racket/base

(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 "type.rkt" namelike))
(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 #:read-include [read-include #f])
  (define version #f)
  (define embeddedType (EmbeddedTypeName-false))
  (define definitions (make-hash))

  (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 (? symbol? r)))
       (set! embeddedType (EmbeddedTypeName-Ref (parse-ref-dsl r)))]
      [`(,(peel-annotations (? symbol? 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))]))

  (when (not version) (error 'parse-schema "Missing version declaration"))

  (Schema definitions embeddedType version))

(define (parse-ref-dsl s)
  (match-define (list module-path ... final-id)
    (map string->symbol (string-split (symbol->string s) ".")))
  (Ref module-path final-id))

(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 (NamedSimplePattern_ 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 (? symbol? n))))
               _))
             (NamedAlternative (symbol->string n) p)]
            [(Pattern-SimplePattern (SimplePattern-Ref (Ref _ n)))
             (NamedAlternative (symbol->string n) p)]
            [(Pattern-SimplePattern (SimplePattern-lit (app namelike (? symbol? 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)))]
      ['embedded (ks (SimplePattern-embedded))]
      [(? symbol? sym)
       (define str (symbol->string sym))
       (if (and (> (string-length str) 0) (string=? (substring str 0 1) "="))
           (ks (SimplePattern-lit (string->symbol (substring str 1))))
           (ks (SimplePattern-Ref (parse-ref-dsl sym))))]
      [(strip-annotations (record (record 'lit '()) (list v))) (ks (SimplePattern-lit v))]
      [(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)))]
      [(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 '())) (peel-annotations (list label fields)))
       (CompoundPattern-rec (maybe-named label) (maybe-named fields))]
      [(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-tuple* (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 (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 (symbol? 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 (NamedSimplePattern_ 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 symbol? (map peel-annotations (annotations input))))

(module+ main
  (require preserves)
  (define expected (car (file->preserves "../../../../schema/schema.bin")))
  (equal? expected
          (Schema->preserves
           (parse-schema-dsl (file->preserves "../../../../schema/schema.prs"
                                              #:read-syntax? #t)))))