#lang racket/base

(provide (struct-out ty-union)
         (struct-out ty-unit)
         (struct-out ty-value)
         (struct-out ty-record)
         (struct-out ty-array)
         (struct-out ty-set)
         (struct-out ty-dictionary)

         (struct-out ty-variant)
         (struct-out ty-field)

         definition-ty
         unwrap
         escape
         module-path-prefix)

(require preserves/record)
(require preserves/order)
(require racket/match)
(require (only-in racket/syntax format-symbol))
(require (only-in racket/string string-join))

(require "gen/schema.rkt")

(struct ty-union (variants) #:transparent)
(struct ty-unit () #:transparent)
(struct ty-value () #:transparent)
(struct ty-record (fields) #:transparent)
(struct ty-array (type) #:transparent)
(struct ty-set (type) #:transparent)
(struct ty-dictionary (key-type value-type) #:transparent)

(struct ty-variant (name type pattern) #:transparent)
(struct ty-field (name type pattern) #:transparent)

(define (definition-ty d)
  (match d
    [(Definition-or p0 p1 pN)
     (ty-union (map (match-lambda [(NamedAlternative variant-label-str pattern)
                                   (ty-variant (string->symbol variant-label-str)
                                               (pattern-ty pattern)
                                               pattern)])
                    (list* p0 p1 pN)))]
    [(Definition-and p0 p1 pN) (product-ty (list* p0 p1 pN))]
    [(Definition-Pattern pattern) (pattern-ty pattern)]))

(define (product-ty named-pats)
  (match (gather-fields* named-pats '())
    ['() (ty-unit)]
    [fields (ty-record fields)]))

(define (unwrap p)
  (match p
    [(Pattern-SimplePattern p) (unwrap p)]
    [(Pattern-CompoundPattern p) (unwrap p)]
    [(NamedPattern-named p) (unwrap p)]
    [(NamedSimplePattern-named p) (unwrap p)]
    [(NamedPattern-anonymous p) (unwrap p)]
    [(NamedSimplePattern-anonymous p) (unwrap p)]
    [_ p]))

(define (gather-fields* named-pats acc)
  (foldr gather-fields acc named-pats))

(define (gather-fields named-pat acc)
  (match (unwrap named-pat)
    [(Binding n p)
     (match (pattern-ty p)
       [(ty-unit) acc]
       [ty (cons (ty-field n ty p) acc)])]
    [(? SimplePattern?) acc]
    [(CompoundPattern-rec label-named-pat fields-named-pat)
     (gather-fields label-named-pat (gather-fields fields-named-pat acc))]
    [(CompoundPattern-tuple named-pats)
     (gather-fields* named-pats acc)]
    [(CompoundPattern-tuplePrefix fixed-named-pats variable-named-pat)
     (gather-fields* fixed-named-pats (gather-fields variable-named-pat acc))]
    [(CompoundPattern-dict (DictionaryEntries entries))
     (gather-fields* (map cdr (sorted-dict-entries entries)) acc)]))

(define (pattern-ty p)
  (match (unwrap p)
    [(SimplePattern-any) (ty-value)]
    [(SimplePattern-atom _atomKind) (ty-value)]
    [(SimplePattern-embedded _interface) (ty-value)]
    [(SimplePattern-lit _value) (ty-unit)]
    [(SimplePattern-seqof pat) (ty-array (pattern-ty pat))]
    [(SimplePattern-setof pat) (ty-set (pattern-ty pat))]
    [(SimplePattern-dictof kp vp) (ty-dictionary (pattern-ty kp) (pattern-ty vp))]
    [(SimplePattern-Ref _r) (ty-value)]
    [(? CompoundPattern?) (product-ty (list p))]))

(define (escape s)
  (format-symbol "?~a" s))

(define (module-path-prefix module-path)
  (if (null? module-path)
      '||
      (format-symbol "~a:" (string-join (map symbol->string module-path) ":"))))