#lang racket/base
(require "bytecode-translator.rkt"
"bytecode-structs.rkt"
"sexp.rkt"
"translate-bytecode-structs.rkt"
"module-record.rkt"
"collect-unimplemented-primvals.rkt"
"path-helpers.rkt"
(prefix-in permissions: "../permissions/query.rkt")
(prefix-in js-impl: "../lang/js-impl/query.rkt")
(prefix-in js-conditional: "../lang/js-conditional/query.rkt")
(prefix-in internal: compiler/zo-parse)
racket/list
racket/path
racket/contract
racket/runtime-path
racket/match
syntax/modcode
syntax/modresolve)
(define-runtime-path mzscheme-vm-src-directory "..")
(define-runtime-path hardcoded-moby-kernel-path
"../lang/kernel.rkt")
(define-runtime-path hardcoded-moby-paramz-path
"../lang/paramz.rkt")
(define-runtime-path hardcoded-js-impl-path
"../lang/js-impl/js-impl.rkt")
(define-runtime-path hardcoded-js-conditional-path
"../lang/js-conditional/js-conditional.rkt")
(define racket-path
(resolve-module-path 'racket #f))
(define racket/base-path
(resolve-module-path 'racket/base #f))
(define racket-private-modbeg-path
(resolve-module-path 'racket/private/modbeg #f))
(provide/contract [compile-moby-modules
(path? . -> . (listof module-record?))])
(define (compile-moby-modules main-module-path)
(let*-values ([(a-path) (normalize-path main-module-path)])
(let loop ([to-visit (list a-path)]
[module-records empty])
(cond
[(empty? to-visit)
module-records]
[else
(let* ([record (compile-moby-module (first to-visit) (normalize-path main-module-path))]
[neighbors (filter-already-visited-modules
(module-neighbors (first to-visit))
(map module-record-path module-records))])
(loop (append neighbors (rest to-visit))
(cons record module-records)))]))))
(define (module-neighbors a-path)
(cond [(looks-like-js-conditional-module? a-path)
'()]
[else
(let* ([translated-compilation-top
(lookup&parse a-path)]
[neighbors
(get-module-phase-0-requires
translated-compilation-top a-path)])
neighbors)]))
(define (compile-moby-module a-path main-module-path)
(cond
[(looks-like-js-implemented-module? a-path)
=>
(lambda (a-js-impl-record)
(make-js-module-record (munge-resolved-module-path-to-symbol a-path main-module-path)
a-path
(apply string-append (js-impl:js-module-impls a-js-impl-record))
(js-impl:js-module-exports a-js-impl-record)
(map (lambda (a-path)
(munge-resolved-module-path-to-symbol a-path main-module-path))
(filter (negate known-hardcoded-module-path?)
(module-neighbors a-path)))
'()
'()))]
[(looks-like-js-conditional-module? a-path)
(let* ([translated-compilation-top (lookup&parse a-path)]
[exports (collect-provided-names translated-compilation-top)])
(make-js-module-record (munge-resolved-module-path-to-symbol a-path main-module-path)
a-path
(js-conditional:query `(file ,(path->string a-path)))
exports
(list)
(list)
(list)))]
[else
(let* ([translated-compilation-top
(lookup&parse a-path)]
[translated-jsexp
(translate-top
(rewrite-module-locations/compilation-top translated-compilation-top
a-path
main-module-path))]
[translated-program
(jsexp->js translated-jsexp)]
[unimplemented-primvals
(collect-unimplemented-primvals translated-jsexp)]
[permissions
(permissions:query `(file ,(path->string a-path)))]
[provides
(collect-provided-names translated-compilation-top)])
(make-module-record (munge-resolved-module-path-to-symbol a-path main-module-path)
a-path
translated-program
provides
(map (lambda (a-path)
(munge-resolved-module-path-to-symbol a-path main-module-path))
(filter (negate known-hardcoded-module-path?)
(module-neighbors a-path)))
permissions
unimplemented-primvals))]))
(define (negate pred)
(lambda (x)
(not (pred x))))
(define (looks-like-js-implemented-module? a-path)
(js-impl:query `(file ,(path->string a-path))))
(define (looks-like-js-conditional-module? a-path)
(js-conditional:has-javascript-implementation? `(file ,(path->string a-path))))
(define (filter-already-visited-modules paths visited-paths)
(filter (lambda (p1)
(and (not (findf (lambda (p2) (same-path? p1 p2))
visited-paths))
(not (known-hardcoded-module-path? p1))))
paths))
(define (known-hardcoded-module-path? p)
(let ([hardcoded-modules
(list hardcoded-moby-kernel-path
hardcoded-moby-paramz-path
hardcoded-js-impl-path
hardcoded-js-conditional-path)])
(ormap (lambda (h)
(same-path? p h))
hardcoded-modules)))
(define (same-path? p1 p2)
(= (file-or-directory-identity p1)
(file-or-directory-identity p2)))
(define ns (make-base-empty-namespace))
(define (lookup&parse a-path)
(let ([op (open-output-bytes)])
(write (parameterize ([current-namespace ns])
(get-module-code a-path))
op)
(translate-compilation-top
(internal:zo-parse (open-input-bytes (get-output-bytes op))))))
(define (munge-resolved-module-path-to-symbol a-resolved-module-path main-module-path)
(let-values ([(base file dir?) (split-path (normalize-path main-module-path))])
(cond
[(symbol? a-resolved-module-path)
a-resolved-module-path]
[(path? a-resolved-module-path)
(let ([normalized-resolved-module-path
(normalize-path a-resolved-module-path)])
(cond
[(js-conditional:redirected? normalized-resolved-module-path)
(munge-resolved-module-path-to-symbol
(js-conditional:follow-redirection normalized-resolved-module-path)
main-module-path)]
[(subdirectory-of? (let-values ([(d name dir?)
(split-path normalized-resolved-module-path)])
d)
mzscheme-vm-src-directory)
(let ([relative (find-relative-path (normalize-path mzscheme-vm-src-directory)
normalized-resolved-module-path)])
(string->symbol
(string-append "mzscheme-vm/"
(munge-path-string (path->string relative)))))]
[else
(let ([relative (find-relative-path base
normalized-resolved-module-path)])
(string->symbol (string-append "relative/"
(munge-path-string (path->string relative)))))]))]
[else
(error 'munge-resolved-module-path-to-symbol a-resolved-module-path)])))
(define (munge-path-string a-str)
(replace-other-forbidden-chars
(replace-dots
(replace-up-dirs
(replace-backslashes-with-forwards
(remove-extension a-str))))))
(define (replace-backslashes-with-forwards a-str)
(regexp-replace* #px"[\\\\]" a-str "/"))
(define replace-other-forbidden-chars
(let ([n 0]
[ht (make-hash)]
[forbidden-regexp #px"[^a-zA-Z0-9\\-\\+\\_\\.\\/]"])
(lambda (a-str)
(hash-ref ht a-str
(lambda ()
(cond
[(regexp-match forbidden-regexp a-str)
=>
(lambda (a-match)
(set! n (add1 n))
(hash-set! ht a-str
(string-append
(regexp-replace* forbidden-regexp a-str "")
(number->string n)))
(hash-ref ht a-str))]
[else
a-str]))))))
(define (replace-up-dirs a-str)
(regexp-replace* #px"\\.\\./" a-str "up/"))
(define (replace-dots a-str)
(regexp-replace* #px"\\." a-str "-dot-"))
(define (remove-extension a-str)
(regexp-replace* #px"\\.[^\\.]+$" a-str ""))
(define (rewrite-module-locations/compilation-top a-top self-path main-module-path)
(match a-top
[(struct compilation-top (max-let-depth prefix code))
(make-compilation-top max-let-depth
(rewrite-module-locations/prefix prefix self-path main-module-path)
(rewrite-module-locations/code code self-path main-module-path))]))
(define (rewrite-module-locations/prefix a-prefix self-path main-module-path)
(match a-prefix
[(struct prefix (num-lifts toplevels stxs))
(make-prefix num-lifts
(map (lambda (t) (rewrite-module-locations/toplevel t self-path main-module-path))
toplevels)
stxs)]))
(define (rewrite-module-locations/toplevel a-toplevel self-path main-module-path)
(cond
[(eq? a-toplevel #f)
a-toplevel]
[(symbol? a-toplevel)
a-toplevel]
[(global-bucket? a-toplevel)
a-toplevel]
[(module-variable? a-toplevel)
(rewrite-module-locations/module-variable a-toplevel self-path main-module-path)]))
(define (rewrite-module-locations/module-variable a-module-variable self-path main-module-path)
(match a-module-variable
[(struct module-variable (modidx sym pos phase))
(make-module-variable (rewrite-module-locations/modidx modidx self-path main-module-path)
sym pos phase)]))
(define (rewrite-module-locations/modidx a-modidx self-path main-module-path)
(let ([resolved-path (resolve-module-path-index a-modidx self-path)])
(cond
[(symbol? resolved-path)
a-modidx]
[(same-path? resolved-path hardcoded-moby-kernel-path)
(module-path-index-join 'moby/kernel
(module-path-index-join #f #f))]
[(same-path? resolved-path hardcoded-moby-paramz-path)
(module-path-index-join 'moby/paramz
(module-path-index-join #f #f))]
[(same-path? resolved-path hardcoded-js-impl-path)
(module-path-index-join 'moby/js-impl
(module-path-index-join #f #f))]
[(same-path? resolved-path hardcoded-js-conditional-path)
(module-path-index-join 'moby/js-conditional
(module-path-index-join #f #f))]
[(same-path? resolved-path racket-private-modbeg-path)
(module-path-index-join 'moby/kernel
(module-path-index-join #f #f))]
[else
(let* ([renamed-path-symbol
(munge-resolved-module-path-to-symbol resolved-path main-module-path)])
(module-path-index-join renamed-path-symbol
(module-path-index-join #f #f)))])))
(define (rewrite-module-locations/code a-code self-path main-module-path)
(match a-code
[(struct mod (name self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context))
(make-mod name
(rewrite-module-locations/modidx self-modidx self-path main-module-path)
(rewrite-module-locations/prefix prefix self-path main-module-path)
(map (lambda (phase+provided)
(list (first phase+provided)
(map (lambda (p) (rewrite-module-locations/provided p self-path main-module-path))
(second phase+provided))
(map (lambda (p) (rewrite-module-locations/provided p self-path main-module-path))
(third phase+provided))))
provides)
(map (lambda (phase+requires)
(cons (first phase+requires)
(map (lambda (p) (rewrite-module-locations/modidx p self-path main-module-path))
(rest phase+requires))))
requires)
body
syntax-body
unexported
max-let-depth
dummy
lang-info
internal-context)]
[else
a-code]))
(define (rewrite-module-locations/provided a-provided self-path main-module-path)
(match a-provided
[(struct provided (name src src-name nom-src src-phase protected? insp))
(make-provided name
(if src (rewrite-module-locations/modidx src self-path main-module-path) src)
src-name
nom-src
src-phase
protected?
insp)]))
(define (get-module-phase-0-requires a-top relative-to)
(define (resolve mpi)
(resolve-module-path-index mpi relative-to))
(cond
[(mod? (compilation-top-code a-top))
(let* ([a-mod (compilation-top-code a-top)]
[requires (mod-requires a-mod)]
[phase0+paths
(findf (lambda (phase+paths)
(= (first phase+paths) 0))
requires)])
(cond
[(eq? phase0+paths #f)
empty]
[else
(map normalize-path
(filter path? (map resolve (rest phase0+paths))))]))]
[else
empty]))
(define (collect-provided-names a-top)
(define (get-name a-provided)
(provided-name a-provided))
(cond
[(mod? (compilation-top-code a-top))
(let* ([a-mod (compilation-top-code a-top)]
[provides (mod-provides a-mod)]
[phase0+provides
(findf (lambda (phase+provides)
(= (first phase+provides) 0))
provides)])
(cond
[(eq? phase0+provides #f)
empty]
[else
(map get-name (second phase0+provides))]))]
[else
empty]))
(define (make-output-file-dir-path a-file-path)
(let*-values ([(base file dir?)
(split-path a-file-path)]
[(new-directory-path)
(normalize-path
(build-path base
(remove-filename-extension
(file-name-from-path file))))])
(unless (directory-exists? new-directory-path)
(make-directory new-directory-path))
new-directory-path))
(define (remove-filename-extension a-path)
(let ([p (if (path? a-path)
(path->string a-path)
a-path)])
(regexp-replace #px"\\.\\w+$" p "")))