#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)
(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
(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])
(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)])
#'(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)))))
(define (get-contract symbol file)
(parameterize ([current-namespace (make-base-namespace)])
(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)
(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 ...)
(for ([path paths])
(define module-path (let-values ([(module-path rest) (module-path-index-split path)])
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)))))
(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))