281 lines
8.3 KiB
Racket
281 lines
8.3 KiB
Racket
#lang racket/base
|
|
(require racket/match
|
|
racket/string)
|
|
|
|
(provide mpi->list
|
|
mpi->string
|
|
self-mpi?)
|
|
|
|
;; mpi->list : module-path-index -> list
|
|
(define (mpi->list mpi)
|
|
(cond [(module-path-index? mpi)
|
|
(let-values ([(path relto) (module-path-index-split mpi)])
|
|
(cond [(not path) null]
|
|
[(not relto) (list path)]
|
|
[else (cons path (mpi->list relto))]))]
|
|
[(not mpi) null]
|
|
[else (list mpi)]))
|
|
|
|
;; mpi->string : module-path-index -> string
|
|
(define (mpi->string mpi)
|
|
(if (module-path-index? mpi)
|
|
(let ([mps (mpi->list mpi)])
|
|
(cond [(pair? mps)
|
|
(string-join (map (lambda (x) (format "~s" x)) mps)
|
|
" <= ")]
|
|
[(null? mps) "this module"]))
|
|
(format "~s" mpi)))
|
|
|
|
;; self-mpi? : module-path-index -> bool
|
|
(define (self-mpi? mpi)
|
|
(let-values ([(path relto) (module-path-index-split mpi)])
|
|
(eq? path #f)))
|
|
|
|
;; --
|
|
|
|
(provide mpi->mpi-sexpr
|
|
mpi-sexpr->mpi
|
|
rmp->rmp-sexpr
|
|
rmp-sexpr->rmp)
|
|
|
|
;; mp = module-path
|
|
;; mpi = module-path-index
|
|
;; rmp = resolved-module-path
|
|
|
|
;; An mpi-sexpr is one of
|
|
;; (cons mp-sexpr mpi-sexpr)
|
|
;; (list rmp-sexpr)
|
|
;; (list #f) ;; "self" module
|
|
;; null
|
|
|
|
;; An rmp-sexpr is
|
|
;; (list 'resolved path/symbol)
|
|
|
|
;; mpi->mpi-sexpr : mpi -> mpi-sexpr
|
|
(define (mpi->mpi-sexpr mpi)
|
|
(cond [(module-path-index? mpi)
|
|
(let-values ([(mod next) (module-path-index-split mpi)])
|
|
(cons (mp->mp-sexpr mod) (mpi->mpi-sexpr next)))]
|
|
[(resolved-module-path? mpi)
|
|
(list (rmp->rmp-sexpr mpi))]
|
|
[else null]))
|
|
|
|
;; mp->mp-sexpr : mp -> mp-sexpr
|
|
(define (mp->mp-sexpr mp)
|
|
(if (path? mp)
|
|
(if (absolute-path? mp)
|
|
`(file ,(path->string mp))
|
|
(path->string mp))
|
|
mp))
|
|
|
|
;; mpi-sexpr->mpi : mpi-sexpr -> mpi
|
|
(define (mpi-sexpr->mpi sexpr)
|
|
(match sexpr
|
|
['() #f]
|
|
[(list (list 'resolved path))
|
|
(rmp-sexpr->rmp path)]
|
|
[(cons first rest)
|
|
(module-path-index-join first (mpi-sexpr->mpi rest))]))
|
|
|
|
;; rmp->rmp-sexpr : rmp -> rmp-sexpr
|
|
(define (rmp->rmp-sexpr rmp)
|
|
(list 'resolved (resolved-module-path-name rmp)))
|
|
|
|
;; rmp-sexpr->rmp : rmp-sexpr -> rmp
|
|
(define (rmp-sexpr->rmp sexpr)
|
|
(make-resolved-module-path (cadr sexpr)))
|
|
|
|
;; ----
|
|
|
|
(provide mpi-sexpr->expanded-mpi-sexpr
|
|
expanded-mpi-sexpr->mpi-sexpr
|
|
|
|
mpi-frame->expanded-mpi-frame
|
|
expanded-mpi-frame->mpi-frame
|
|
|
|
expanded-mpi-sexpr->library
|
|
absolute-expanded-mpi-frame?
|
|
library-expanded-mpi-frame?)
|
|
|
|
;; An expanded-mpi-sexpr is (listof expanded-mpi-frame)
|
|
|
|
;; An expanded-mpi-frame is one of:
|
|
;; (list 'LIB (listof string))
|
|
;; (list 'PLANET (listof string) PackageSpec)
|
|
;; (list 'FILE string)
|
|
;; absolute file path (not relative)
|
|
;; (list 'QUOTE symbol)
|
|
;; (list 'SELF)
|
|
;; (list 'REL (listof string))
|
|
;; The first 5 variants are considered "absolute" frames.
|
|
;; The first 2 variants are consider "library" frames.
|
|
|
|
;; mpi-sexpr->expanded-mpi-sexpr
|
|
(define (mpi-sexpr->expanded-mpi-sexpr sexpr)
|
|
(map mpi-frame->expanded-mpi-frame sexpr))
|
|
|
|
;; mpi-frame->expanded-mpi-frame
|
|
(define (mpi-frame->expanded-mpi-frame sexpr)
|
|
(match sexpr
|
|
[#f
|
|
`(SELF)]
|
|
[`(quote ,mod)
|
|
`(QUOTE ,mod)]
|
|
[`(lib ,path)
|
|
(cond [(symbol? path)
|
|
(mpi-frame->expanded-mpi-frame path)]
|
|
[(regexp-match? #rx"/" path)
|
|
`(LIB ,(split-mods path))]
|
|
[else
|
|
`(LIB ,(list "mzlib" path))])]
|
|
[`(lib ,path . ,more)
|
|
`(LIB ,(split-mods path more))]
|
|
[`(planet ,(? symbol? spec))
|
|
(mpi-frame->expanded-mpi-frame (parse-planet-spec spec))]
|
|
[`(planet ,path ,package . ,more)
|
|
`(PLANET ,(split-mods path more) ,package)]
|
|
[(? symbol? mod)
|
|
`(LIB ,(split-mods* (symbol->string mod)))]
|
|
[`(file ,path)
|
|
(cond [(absolute-path? path)
|
|
`(FILE ,path)]
|
|
[else
|
|
`(REL (split-mods path))])]
|
|
[(? string? path)
|
|
`(REL ,(split-mods path))]
|
|
[`(resolved ,(? path? path))
|
|
`(FILE ,path)]
|
|
[`(resolved ,(? symbol? symbol))
|
|
`(QUOTE ,symbol)]))
|
|
|
|
;; expanded-mpi-sexpr->mpi-sexpr
|
|
(define (expanded-mpi-sexpr->mpi-sexpr sexpr)
|
|
(map expanded-mpi-frame->mpi-frame sexpr))
|
|
|
|
;; expanded-mpi-frame->mpi-frame
|
|
(define (expanded-mpi-frame->mpi-frame sexpr)
|
|
(match sexpr
|
|
[`(SELF)
|
|
#f]
|
|
[`(QUOTE ,mod)
|
|
`(quote ,mod)]
|
|
[`(LIB ,paths)
|
|
`(lib ,(apply string-append (intersperse "/" paths)))]
|
|
[`(PLANET ,paths ,package)
|
|
`(planet ,(apply string-append (intersperse "/" paths)) ,package)]
|
|
[`(FILE ,path)
|
|
`(file ,path)]
|
|
[`(REL ,paths)
|
|
(apply string-append (intersperse "/" paths))]))
|
|
|
|
(define (parse-planet-spec spec-sym)
|
|
(define spec (symbol->string spec-sym))
|
|
(let ([m (regexp-match #rx"([^/]*)/([^:/]*)(?:[:]([^/]*))?(?:/(.*))?" spec)])
|
|
(unless m (error "bad planet symbol" spec-sym))
|
|
(let ([owner (cadr m)]
|
|
[package (string-append (caddr m) ".plt")]
|
|
[version (and (cadddr m) (parse-version (cadddr m)))]
|
|
[path (list-ref m 4)])
|
|
`(planet ,(string-append (or path "main") ".rkt")
|
|
(,owner ,package . ,version)))))
|
|
|
|
(define (parse-version str)
|
|
;; FIXME!!!
|
|
'())
|
|
|
|
(define (split-mods* path)
|
|
(let ([mods (split-mods path)])
|
|
(if (and (pair? mods) (null? (cdr mods)))
|
|
(append mods (list "main.rkt"))
|
|
mods)))
|
|
|
|
(define (split-mods path [more null])
|
|
(append (apply append (map split-mods more))
|
|
(regexp-split #rx"/" path)))
|
|
|
|
(define (flatten-mods more path)
|
|
(path->string (apply build-path (append more (list path)))))
|
|
|
|
;; expanded-mpi-sexpr->library : expanded-mpi-sexpr -> expanded-mpi-frame
|
|
(define (expanded-mpi-sexpr->library sexpr0)
|
|
(define (abs? link)
|
|
(and (pair? link) (memq (car link) '(LIB PLANET))))
|
|
(define (loop stack stacks)
|
|
(cond [(pair? (cdr stack))
|
|
(cons (car stack) (loop (cdr stack) stacks))]
|
|
[(pair? stacks)
|
|
(unless (eq? 'REL (car (car stacks)))
|
|
(error 'expanded-mpi-sexpr->library
|
|
"internal error: absolute frame"))
|
|
(loop (cadr (car stacks)) (cdr stacks))]
|
|
[else stack]))
|
|
(define sexpr1 (reverse (cut-to-absolute sexpr0)))
|
|
(and (library-expanded-mpi-frame? (car sexpr1))
|
|
`(,(car (car sexpr1))
|
|
,(loop (cadr (car sexpr1)) (cdr sexpr1))
|
|
. ,(cddr (car sexpr1)))))
|
|
|
|
;; cut-to-absolute : expanded-mpi-sexpr -> expanded-mpi-sexpr
|
|
(define (cut-to-absolute sexpr)
|
|
(cond [(and (pair? sexpr)
|
|
(absolute-expanded-mpi-frame? (car sexpr)))
|
|
(list (car sexpr))]
|
|
[(pair? sexpr)
|
|
(cons (car sexpr) (cut-to-absolute (cdr sexpr)))]))
|
|
|
|
;; absolute-expanded-mpi-frame? : expanded-mpi-frame -> boolean
|
|
(define (absolute-expanded-mpi-frame? sexpr)
|
|
(not (memq (car sexpr) '(REL))))
|
|
|
|
;; library-expanded-mpi-frame? : expanded-mpi-frame -> boolean
|
|
(define (library-expanded-mpi-frame? sexpr)
|
|
(memq (car sexpr) '(LIB PLANET)))
|
|
|
|
;; intersperse : X (listof X) -> (listof X)
|
|
(define (intersperse sep items)
|
|
(cond [(and (pair? items) (pair? (cdr items)))
|
|
(cons (car items) (cons sep (intersperse sep (cdr items))))]
|
|
[else items]))
|
|
|
|
|
|
|
|
#|
|
|
(provide mpi->path-list
|
|
path-list->library-module)
|
|
|
|
(define (mpi->path-list mpi)
|
|
(reverse-to-abs (mpi->mpi-sexpr mpi) null))
|
|
|
|
(define (reverse-to-abs paths acc)
|
|
(match paths
|
|
['()
|
|
acc]
|
|
[#f
|
|
(cons (list 'SELF) acc)]
|
|
[(cons `(quote ,mod) rest)
|
|
(cons `(QUOTE ,mod) acc)]
|
|
[(cons `(lib ,path) rest)
|
|
(cond [(symbol? path)
|
|
(reverse-to-abs (cons path rest) acc)]
|
|
[(regexp-match? #rx"/" path)
|
|
(cons `(LIB ,(split-mods path)) acc)]
|
|
[else
|
|
(cons `(LIB ,(list "mzlib" path)) acc)])]
|
|
[(cons `(lib ,path . ,more) rest)
|
|
(cons `(LIB ,(split-mods path more)) acc)]
|
|
[(cons `(planet ,(? symbol? spec)) rest)
|
|
(reverse-to-abs (cons (parse-planet-spec spec) rest) acc)]
|
|
[(cons `(planet ,path ,package . ,more) rest)
|
|
(cons `(PLANET ,(split-mods path more) ,package) acc)]
|
|
[(cons (? symbol? mod) rest)
|
|
(cons `(LIB ,(split-mods* (symbol->string mod))) acc)]
|
|
[(cons `(file ,path) rest)
|
|
(cond [(absolute-path? path)
|
|
(cons `(FILE ,(split-mods path)) acc)]
|
|
[else (reverse-to-abs rest (cons (split-mods path) acc))])]
|
|
[(cons (? string? path) rest)
|
|
(reverse-to-abs rest (cons (split-mods path) acc))]))
|
|
|
|
(provide parse-planet-spec)
|
|
|#
|