#lang racket/base

#|
Show imports (symbols that come from requires) and exports (symbols that are provided)

1. How can I avoid showing imported symbols from the lang line? It would be nice to
ignore all the symbols from racket/base if a file starts with
#lang racket/base

|#

(require racket/cmdline
         racket/match
         unstable/generics
         racket/pretty
         (for-syntax racket/struct-info
                     racket/base
                     syntax/parse
                     racket/match))

(define module-name
  (compose resolved-module-path-name module-path-index-resolve))

(define-syntax (import-struct stx)
 (syntax-parse stx
   [(_ ([struct-name:identifier instance:identifier] more ...) body ...)
    (define (get-fields struct instance)
      ;; (printf "Import struct for ~a\n" #'struct-name)
      (let ([info (syntax-local-value struct (lambda () #f))])
        (match (extract-struct-info info)
               [(list name init-field-count auto-field-count accessor-proc
                      mutator-proc immutable-k-list)
                (begin
                  ;; messing around with strings is bad, whats a better solution?
                  (define (make-local-field field-stx)
                    (let* ([field (substring (symbol->string (syntax->datum field-stx))
                                             (- (string-length (string-append (symbol->string (syntax->datum name)) "-"))
                                                (string-length "struct:")))]
                           [final (string->symbol (string-append (symbol->string
                                                                   (syntax->datum instance))
                                                                 "."
                                                                 field))])
                      (datum->syntax instance final instance instance)))
                  #;
                  (apply printf "name: ~a init-field-count: ~a auto-field-count: ~a accessor-proc: ~a mutator-proc: ~a immutable-k-list: ~a\n"
                         (list name init-field-count auto-field-count (map syntax->datum accessor-proc)
                               mutator-proc immutable-k-list))
                  (with-syntax ([(field ...)
                                 (map make-local-field accessor-proc)]
                                [(setter! ...) mutator-proc]
                                [instance instance]
                                [(accessor ...) accessor-proc])
                    #|
                    (printf "bind: ~a\n" (map syntax->datum (syntax->list #'(field ...))))
                    (printf "setter: ~a\n" (map syntax->datum (syntax->list #'(setter! ...))))
                    |#
                    (begin
                     #;syntax-local-introduce
                      #;
                      #'(let ([my-accessor])
                          let-syntax ([field (make-rename-transformer my-accessor)] ...)
                          body)

                      #;
                      #'(let ([field (make-rename-transformer #'field
                                                              (accessor instance))]
                              ...)
                          body)

                      #'([field (make-set!-transformer
                                  (lambda (stx)
                                    (syntax-case stx (set!)
                                      [(set! id v) (if #'setter!
                                                     #'(setter! instance v)
                                                     #'(error 'with-struct "field ~a is not mutable so no set! is available" 'field))]
                                      [id #'(accessor instance)])))]
                         ...)

                      #;
                      #'(let-syntax ([field (make-set!-transformer
                                              (lambda (stx)
                                                (syntax-case stx (set!)
                                                  [(set! id v) (if #'setter!
                                                                 #'(setter! instance v)
                                                                 #'(error 'with-struct "field ~a is not mutable so no set! is available" 'field))]
                                                  [id #'(accessor instance)])))]
                                     ...)
                          body ...)

                      #;
                      #'(let-syntax ([field (lambda (stx)
                                              #'(accessor instance))]
                                     ...)
                          body1 body ...))))])))
    (with-syntax ([(field ...) (get-fields #'struct-name #'instance)])
      ;; (printf "Final let syntax is ~a\n" (syntax->datum #'(let-syntax (field ...) body ...)))
      #'(let-syntax (field ...)
          (import-struct (more ...) body ...)))]
   [(_ () body ...)
    #'(begin body ...)]))

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

(define-syntax-rule (define-module-symbol name (fields ...) rest ...)
                    (define-struct name (fields ...)
                                   #:property prop:module-symbol
                                   rest ...))

(define-module-symbol symbol:normal (name)
                      (define-methods module-symbol
                                      (define (get-symbol self) (symbol:normal-name self))
                                      (define (print self)
                                        (import-struct ([symbol:normal self])
                                                       (format "~a" self.name)))))

(define-module-symbol symbol:normal/contract (name contract)
               (define-methods module-symbol
                               (define (get-symbol self) (symbol:normal-name self))
                               (define (print self)
                                 (import-struct ([symbol:normal/contract self])
                                                (format "~a contract ~a" self.name self.contract)))))

(define-module-symbol symbol:renamed (provided defined)
               (define-methods module-symbol
                               (define (get-symbol self) (symbol:renamed-provided self))
                               (define (print self)
                                 (import-struct ([symbol:renamed self])
                                                (format "~a as ~a" self.defined self.provided)))))

(define-module-symbol symbol:module-exported (where)
               (define-methods module-symbol
                               (define/generic symbol-print print)
                               (define (get-symbol self)
                                 (raise 'get-symbol "Not defined"))
                               (define (print self)
                                 (format "from ~a"
                                         (module-name
                                             (symbol:module-exported-where self))
                                         ))))

(define-module-symbol symbol:module-exported-from (original where)
               (define-methods module-symbol
                               (define/generic symbol-print print)
                               (define (get-symbol self)
                                 (raise 'get-symbol "Not defined"))
                               (define (print self)
                                 (import-struct ([symbol:module-exported-from self])
                                                (format "from ~a ~a"
                                                        (module-name self.where)
                                                        (symbol-print self.original))))))

(define-module-symbol symbol:module-exported-as
               (where phase-shift imported-name import-shift)
               (define-methods module-symbol
                               (define/generic symbol-print print)
                               (define (get-symbol self)
                                 (symbol:module-exported-as-imported-name self))
                               (define (print self)
                                 (import-struct ([symbol:module-exported-as self])
                                 (format "from ~a as ~a"
                                         (module-name self.where)
                                         self.imported-name)))))

(define-module-symbol symbol:multiple-modules (symbol modules)
               (define-methods module-symbol
                               (define/generic symbol-print print)
                               (define (get-symbol self)
                                 (symbol:multiple-modules-symbol self))
                               (define (print self)
                                 (import-struct ([symbol:multiple-modules self])
                                                (format "~a ~a"
                                                        (symbol-print self.symbol)
                                                        (let ([modules self.modules])
                                                          (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)))))

;; extract the symbol from the module and call `contract-name' on its contract
(define (get-contract symbol file)
  (parameterize ([current-namespace (make-base-namespace)])
                ;; FIXME! it would be nice if we could pull multiple symbols out
                ;; in the same `dynamic-require' call
                (define has-contract? (dynamic-require 'racket/contract 'has-contract?))
                (define value-contract (dynamic-require 'racket/contract 'value-contract))
                (define contract-name (dynamic-require 'racket/contract 'contract-name))
                (let ([result (dynamic-require file symbol (lambda () #f))])
                  #;
                  (printf "v is ~a\n" v)
                  #;
                  (printf "v has contract? ~a\n" (has-contract? v))
                  (if (has-contract? result)
                    (contract-name (value-contract result))
                    #f))))

(define (make-symbol something file get-contract?)
  (define (populate-symbol symbol)
    (if (not get-contract?)
      (symbol:normal symbol)
      (let ([contract (get-contract symbol file)])
        (if contract
          (symbol:normal/contract symbol contract)
          (symbol:normal symbol)))))
  (define (extract-module 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)]))
  (match something
         [(list exported (list paths ...))
          (symbol:multiple-modules (populate-symbol exported)
                                   (map extract-module paths))]))

(define (get-imports file)
  (let ([imports (parameterize ([current-namespace (make-base-namespace)])
                               (dynamic-require file #f)
                               (module->imports file))])
    (define (combine-provides provides)
      ;; provides is guaranteed to have at least one thing or we wouldn't get here
      (for/fold ([all (car provides)])
                ([provide (cdr provides)])
        (provided (provided-phase all)
                  (append (provided-variables all)
                          (provided-variables provide))
                  (append (provided-syntaxes all)
                          (provided-syntaxes provide)))))
    (define phase-imports (make-hash))
    (define (fixup-paths path exports)
      (for/list ([export exports])
                (match export
                  [(symbol:multiple-modules symbol modules)
                   (symbol:multiple-modules symbol
                                            (if (null? modules)
                                              (list (symbol:module-exported path))
                                              (map (lambda (module)
                                                     (symbol:module-exported-from
                                                       module path))
                                                   modules)))])))
    (define (add-provide phase provide)
      (hash-set! phase-imports
                 phase
                 (cons provide (hash-ref phase-imports phase (lambda () (list))))))
    (for ([import imports])
         (match import
           [(list phase-shift paths ...)
            ;; (printf "Import at phase shift ~a\n" phase-shift)
            (for ([path paths])
                 ;; (printf " Module ~a\n" (module-name path))
                 (define module-path (let-values ([(module-path rest) (module-path-index-split path)])
                                               ; (printf "Module path is ~a. Rest is ~a\n" module-path rest)
                                               module-path))
                 (let ([exports (get-exports module-path #f)])
                   (for ([export exports])
                          (match export
                           [(provided phase variables syntaxes)
                            (add-provide (+ phase phase-shift)
                                         (provided (+ phase phase-shift)
                                                   (fixup-paths path variables)
                                                   (fixup-paths path syntaxes)))]))))]))
    (hash-map phase-imports (lambda (phase provides)
                              (combine-provides provides)))))

(define (get-exports file get-contracts?)
  (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)))))
  (define (make-symbol* export)
    (make-symbol export file get-contracts?))
  (let-values ([(exported-variables
                  exported-syntaxes)
                (parameterize ([current-namespace (make-base-namespace)])
                              (dynamic-require file #f)
                              (module->exports file))])

    #;
    (pretty-print (syntax->datum 
                              (parameterize ([current-namespace (make-base-namespace)])
                                            (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 show-imports? show-exports?)
  (define (print-all prefix stuff)
    (for ([symbol stuff])
         (printf "~a~a\n" prefix (print symbol))))
  (define (show-all what provides)
    (define (space n)
      (make-string n #\space))
    (printf "~a\n" what)
    (for ([provide provides])
         (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 (space 6) (provided-variables provide))
           (printf "    Syntaxes\n")
           (print-all (space 6) (provided-syntaxes provide)))))
  (define (show-imports)
    (show-all "Imports" (get-imports file)))
  (define (show-exports)
    (show-all "Exports" (get-exports file #t)))
  (when show-imports?
    (show-imports)
    (printf "\n"))
  (when show-exports?
    (show-exports)))

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