#lang racket/base

(provide schema-check-problems
         schema-check-problems!
         valid-id?)

(require racket/match)
(require (only-in racket/list check-duplicates))
(require (only-in racket/string string-join))
(require preserves/order)

(require (only-in "type.rkt" unwrap))
(require "gen/schema.rkt")

(define (valid-id? x)
  (and (symbol? x)
       (regexp-match? #px"^[a-zA-Z][a-zA-Z_0-9]*$" (symbol->string x))))

(define (schema-check-problems schema)
  (define problems '())

  (define (problem! context f . args)
    (set! problems (cons (format "~a: ~a" (reverse context) (apply format f args)) problems)))

  (define (check-binding context scope n)
    (when (hash-has-key? scope n)
      (problem! context "duplicate binding ~v" n))
    (when (not (valid-id? n))
      (problem! context "invalid binding name ~v" n))
    (hash-set! scope n #t))

  (define (check-pattern context scope p value-available?)
    (match (unwrap p)
      [(SimplePattern-lit _)
       (void)]
      [(? SimplePattern? u)
       (when (not value-available?) (problem! context "necessary information not captured"))
       (match u
         [(SimplePattern-Ref (Ref (ModulePath ids) id))
          (when (not (andmap valid-id? (cons id ids)))
            (problem! context "invalid reference name"))]
         [_ (void)])]
      [(CompoundPattern-rec l f)
       (check-named-pattern (cons "label" context) scope l)
       (check-named-pattern (cons "fields" context) scope f)]
      [(CompoundPattern-tuple ps)
       (for [(p (in-list ps)) (i (in-naturals))] (check-named-pattern (cons i context) scope p))]
      [(CompoundPattern-tuplePrefix ps v)
       (for [(p (in-list ps)) (i (in-naturals))] (check-named-pattern (cons i context) scope p))
       (check-named-pattern (cons "tail" context) scope v)]
      [(CompoundPattern-dict (DictionaryEntries entries))
       (for [(entry (in-list (sorted-dict-entries entries)))]
         (check-named-pattern (cons (car entry) context) scope (cdr entry)))]))

  (define (check-named-pattern context scope p)
    (match (unwrap p)
      [(Binding n p)
       (check-binding context scope n)
       (check-pattern (cons n context) scope p #t)]
      [p (check-pattern context scope p #f)]))

  (for [((name def) (in-hash (Definitions-value (Schema-definitions schema))))]
    (define context (list name))
    (match def
      [(Definition-or p0 p1 pN)
       (define alts (list* p0 p1 pN))
       (unless (void? (check-duplicates alts #:key NamedAlternative-variantLabel #:default (void)))
         (problem! context "duplicate variant label"))
       (for [(a (in-list alts))]
         (define label (string->symbol (NamedAlternative-variantLabel a)))
         (when (not (valid-id? label)) (problem! context "invalid variant label ~v" label))
         (check-pattern (cons label context) (make-hash) (NamedAlternative-pattern a) #t))]
      [(Definition-and p0 p1 pN)
       (define scope (make-hash))
       (for [(p (in-list (list* p0 p1 pN)))]
         (check-named-pattern context scope p))]
      [(Definition-Pattern p) (check-pattern context (make-hash) p #t)]))

  (reverse problems))

(define (schema-check-problems! schema #:name [name "<unknown>"])
  (let ((problems (schema-check-problems schema)))
    (when (not (null? problems))
      (error 'schema-check-problems! "Problems checking schema ~a:\n - ~a"
             name
             (string-join problems "\n - "))))
  schema)