#lang racket/base

(require racket/cmdline
         racket/match
         unstable/generics)

(generics module-symbol
          (print module-symbol))

(define-struct symbol:normal (name)
               #:property prop:module-symbol
               (define-methods module-symbol
                               (define (print self)
                               (format "~a" (symbol:normal-name self)))))

(define-struct symbol:renamed (provided defined)
               #:property prop:module-symbol
               (define-methods module-symbol
                               (define (print self)
                               (format "~a as ~a" (symbol:renamed-defined self)
                                       (symbol:renamed-provided self)))))

(define-struct symbol:module-exported (where)
               #:property prop:module-symbol
               (define-methods module-symbol
                               (define/generic symbol-print print)
                               (define (print self)
                                 (format "from ~a"
                                         (resolved-module-path-name 
                                           (module-path-index-resolve
                                             (symbol:module-exported-where self)))
                                         ))))

(define-struct symbol:module-exported-as
               (where phase-shift imported-name import-shift)
               #:property prop:module-symbol
               (define-methods module-symbol
                               (define/generic symbol-print print)
                               (define (print self)
                                 (format "from ~a as ~a"
                                         (resolved-module-path-name
                                           (module-path-index-resolve
                                             (symbol:module-exported-as-where self)))
                                         (symbol:module-exported-as-imported-name self)))))

(define-struct symbol:multiple-modules (symbol modules)
               #:property prop:module-symbol
               (define-methods module-symbol
                               (define/generic symbol-print print)
                               (define (print self)
                                 (format "~a ~a" (symbol:multiple-modules-symbol self)
                                         (let ([modules (symbol:multiple-modules-modules self)])
                                           (if (null? modules)
                                             ""
                                             (for/fold ([start (symbol-print (car modules))])
                                                       ([next (cdr modules)])
                                                       (format "~a and ~a" start (symbol-print next)))))))))

(struct provided (phase variables syntaxes))

(define (read-file file)
  (parameterize ([read-accept-reader #t])
                (with-input-from-file file (lambda () (read)))))

(define (make-symbol something)
  (match something
    [(list exported (list paths ...))
     (symbol:multiple-modules exported
                              (map (lambda (path)
                                     (match path
                                            [(and (? module-path-index?) module)
                                             (symbol:module-exported module)]
                                            [(list path phase-shift imported-name imported-phase)
                                             (symbol:module-exported-as path
                                                                        phase-shift
                                                                        imported-name
                                                                        imported-phase)]))
                                   paths))])
  #;
  (match something
    [(list exported (list))
     (symbol:normal exported)]
    [(list exported (list paths ...))
     (for/fold ([symbol (symbol:normal exported)])
               ([path paths])
       (match path
         [(and (? module-path-index?) module)
          (symbol:module-exported symbol module)]
         [(list path phase-shift imported-name imported-phase)
          (symbol:module-exported-as symbol
                                     path
                                     phase-shift
                                     imported-name
                                     imported-phase)]))])
  #;
  (match something
    [(and (? symbol?) x) (symbol:normal something)]
    [(cons module-path-index (cons provided-sym defined-sym))
     (symbol:module-exported module-path-index provided-sym defined-sym)]
    [(cons (and (? symbol?) provided)
           (and (? symbol?) defined)) (symbol:renamed provided defined)]))

(define (get-provides file)
  (define (sort-symbols symbols)
    (sort symbols (lambda (a b)
                    (define (get-symbol what)
                      (match what
                        [(list name rest ...) (symbol->string name)]))
                    (string<? (get-symbol a)
                              (get-symbol b)))))
  (let-values ([(exported-variables
                  exported-syntaxes)
                (parameterize ([current-namespace (make-base-namespace)])
                                (dynamic-require file #f)
                                (module->exports file)
                                #;
                     (expand (read-file file)))])
    ; (printf "Expanded is ~a\n" expanded)
    ; (printf "Variables ~a\n" (syntax-property expanded 'module-variable-provides))
    ; (printf "Syntaxes ~a\n" (syntax-property expanded 'module-syntax-provides))
    (define exports (make-hash))
    (for ([export exported-variables])
     (match export
            [(list (and (? number?) phase) symbols ...)
             (hash-set! exports phase (provided phase
                                                (map make-symbol (sort-symbols symbols))
                                                '()))]))
    (for ([export exported-syntaxes])
     (match export
            [(list (and (? number?) phase) symbols ...)
             (hash-set! exports phase
                        (let ([existing (hash-ref exports phase (lambda () (provided phase '() '())))])
                          (provided phase
                                    (provided-variables existing)
                                    (map make-symbol (sort-symbols symbols)))))]))
    (hash-map exports (lambda (a b) b))))

(define (phase-name phase)
  (case phase
    [(0) " (runtime)"]
    [(1) " (syntax)"]
    [(-1) " (template)"]
    [else ""]))

(define (check-file file [phase 'all])
  (define (print-all prefix stuff)
    (for ([symbol stuff])
         (printf "~a~a\n" prefix (print symbol))))
  (for ([provide (get-provides file)])
    (when (or (eq? phase 'all)
              (equal? phase (provided-phase provide)))
       (printf "Phase ~a~a\n" (provided-phase provide)
               (phase-name (provided-phase provide)))
       (printf " Variables\n")
       (print-all "  " (provided-variables provide))
       (printf " Syntaxes\n")
       (print-all "  " (provided-syntaxes provide)))))

(define only-phase (make-parameter 'all))
(check-file
  (command-line
    #:program "checker"
    #:once-each
    [("--phase") phase
               "Only show identifiers at this phase"
               (only-phase (string->number phase))]
    #:args (file)
    file)
  (only-phase))