suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

new syntax, take 2

Browse Source 
svn: r9052
This commit is contained in:
Jacob Matthews 2008-03-22 00:51:37 +00:00
parent 7f9dd9775f
commit 63cf6c73fc
6 changed files with 165 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
collects/planet/parsereq.ss Normal file
View File

@ -0,0 +1,105 @@
#lang scheme/base
(require mzlib/match
"private/short-syntax-helpers.ss"
"private/data.ss")
(provide (struct-out request)
spec->req
pkg-spec->full-pkg-spec
version->bounds)
(define-struct request (full-pkg-spec file path))
(define (spec->req spec stx)
(match (cdr spec)
[(file-name pkg-spec path ...)
(unless (string? file-name)
(raise-syntax-error #f (format "File name: expected a string, received: ~s" file-name) stx))
(unless (andmap string? path)
;; special-case to catch a possibly common error:
(if (ormap number? path)
(raise-syntax-error #f (format "Module path must consist of strings only, received a number (maybe you intended to specify a package version number?): ~s" path) stx)
(raise-syntax-error #f (format "Module path must consist of strings only, received: ~s" path) stx)))
(make-request (pkg-spec->full-pkg-spec pkg-spec stx)
file-name
path)]
[((? symbol? s))
(let ([str (symbol->string s)])
(define (yell msg) (λ (str) (raise-syntax-error #f (format msg str) stx)))
(try-parsing str
([owner (get-next-slash #:on-error (yell "Illegal syntax; expected an owner, received ~e"))]
[package (get-next-slash-or-end #:on-error (yell "Illegal syntax; expected a package, received ~e"))])
(λ (tail)
(let-values ([(pkg maj min) (parse-package package stx)])
(let* ([pkg-spec `(,owner ,pkg ,@(if maj (list maj) '()) ,@(if min (list min) '()))]
[fullspec (pkg-spec->full-pkg-spec pkg-spec stx)]
[final-path (if (string=? tail "")
"main.ss"
(string-append tail ".ss"))])
(make-request fullspec final-path '()))))))]
[_ (raise-syntax-error 'require (format "Illegal PLaneT invocation: ~e" (cdr spec)) stx)]))
; pkg-spec->full-pkg-spec : PKG-SPEC syntax -> FULL-PKG-SPEC
(define (pkg-spec->full-pkg-spec spec stx)
(define (pkg name maj lo hi path) (make-pkg-spec name maj lo hi path stx (version)))
(define (fail* msg)
(raise-syntax-error 'require (string->immutable-string msg) stx))
(define (fail)
(fail* (format "Invalid PLaneT package specifier: ~e" spec)))
(match spec
[((? string? owner) (? string? package) ver-spec ...)
(match-let ([(maj min-lo min-hi) (version->bounds ver-spec fail*)])
(pkg package maj min-lo min-hi (list owner)))]
[((? (o not string?) owner) _ ...)
(fail* (format "Expected string [package owner] in first position, received: ~e" owner))]
[(_ (? (o not string?) pkg) _ ...)
(fail* (format "Expected string [package name] in second position, received: ~e" pkg))]
[_ (fail)]))
;; version->bounds : VER-SPEC -> (list (number | #f) number (number | #f)) | #f
;; determines the bounds for a given version-specifier
;; [technically this handles a slightly extended version of VER-SPEC where MAJ may
;; be in a list by itself, because that's slightly more convenient for the above fn]
(define (version->bounds spec-list fail)
(match spec-list
[() (list #f 0 #f)]
[(? number? maj) (version->bounds (list maj))]
[((? number? maj)) (list maj 0 #f)]
[((? number? maj) min-spec)
(let ((pkg (lambda (min max) (list maj min max))))
(match min-spec
[(? number? min) (pkg min #f)]
[((? number? lo) (? number? hi)) (pkg lo hi)]
[('= (? number? min)) (pkg min min)]
[('+ (? number? min)) (pkg min #f)]
[('- (? number? min)) (pkg 0 min)]
;; failure cases
[(? (o/and (o not number?)
(o/or (o not list?)
(λ (x) (not (= (length x) 2))))))
(fail (format "Expected number or version range specifier for minor version specification, received: ~e" min-spec))]
[((? (λ (x)
(and (not (number? x))
(not (memq x '(= + -)))))
range)
_)
(fail (format "Illegal range specifier in minor version specification. Legal range specifiers are numbers, =, +, -; given: ~e" range))]
[(_ (? (o not number?) bnd))
(fail (format "Expected number as range bound in minor version specification, given: ~e" bnd))]
[_ (fail (format "Illegal minor version specification: ~e" min-spec))]))]
;; failure cases
[(? (o/and (o not number?) (o not list?)) v)
(fail (format "Version specification expected number or sequence, received: ~e" v))]
[((? (o not number?) maj) _ ...)
(fail (format "Version specification expected number for major version, received: ~e" maj))]
[_ (fail "Invalid version specification")]))
(define (o f g) (λ (x) (f (g x))))
(define (o/and . es) (λ (x) (andmap (λ (f) (f x)) es)))
(define (o/or . es) (λ (x) (ormap (λ (f) (f x)) es)))

55
collects/planet/planet-short-syntax.ss
View File

@ -1,55 +0,0 @@
#lang scheme/base
#|
provides a shorthand syntax for planet files analagous to the (require net/url) syntax
for libraries.
Grammar:
SPEC ::= OWNER "/" PKGNAME MAJVERSPEC "/" PATH
MAJVERSPEC ::= "" | ":" [0-9]+ MINVERSPEC
MINVERSPEC ::= "" | ":" PMINVERSPEC
PMINVERSPEC ::= [0-9]+ | "<=" [0-9]+ | ">=" [0-9]+ | "=[0-9]+" | [0-9]+ "-" [0-9]+
OWNER ::= [string without /]
PKGNAME ::= [string without /, :]
PATH ::= string
Examples:
(require (planet planet/test-connection.plt/test-connection.ss))
(require (planet planet/test-connection/test-connection.ss))
(require (planet planet/test-connection:1/test-connection.ss))
(require (planet planet/test-connection:1:0/test-connection.ss))
(require (planet planet/test-connection:1:=0/test-connection.ss))
(require (planet planet/test-connection:1:0-10/test-connection.ss))
(require (planet planet/test-connection:1:>=0/test-connection.ss))
(require (planet planet/test-connection:1:<=0/test-connection.ss))
|#
(require scheme/require-syntax
(for-syntax scheme/base)
(for-syntax "private/short-syntax-helpers.ss"))
(provide (rename-out [plan planet]))
(define-require-syntax plan
(λ (stx)
(syntax-case stx ()
[(_ spec-sym)
(symbol? (syntax->datum #'spec-sym))
(let ([str (symbol->string (syntax->datum #'spec-sym))])
(define (yell msg) (λ (str) (raise-syntax-error #f (format msg str) #'spec-sym)))
(try-parsing str
([owner (get-next-slash #:on-error (yell "Illegal syntax; expected an owner, received ~e"))]
[package (get-next-slash #:on-error (yell "Illegal syntax; expected a package, received ~e"))])
(λ (final-path)
(let-values ([(pkg maj min) (parse-package package stx)])
(quasisyntax/loc stx
(planet #,final-path (#,owner
#,pkg
#,@(if maj (list maj) '())
#,@(if min (list min) '()))))))))]
[(_ . any)
#`(planet . any)])))

37
collects/planet/private/data.ss Normal file
View File

@ -0,0 +1,37 @@
#lang scheme/base
(provide (all-defined-out))
; ==========================================================================================
; DATA
; defines common data used by the PLaneT system
; ==========================================================================================
; exn:i/o:protocol: exception indicating that a protocol error occured
(define-struct (exn:i/o:protocol exn:fail:network) ())
; FULL-PKG-SPEC : struct pkg-spec
(define-struct pkg-spec
(name ; string
maj ; (Nat | #f)
minor-lo ; (Nat | #f)
minor-hi ; (Nat | #f)
path ; (listof string)
stx ; (syntax | #f)
core-version ; string
)
#:transparent)
; PKG : string (listof string) Nat Nat path ORIGIN
(define-struct pkg (name route maj min path origin))
; UNINSTALLED-PKG : path FULL-PKG-SPEC Nat Nat
(define-struct uninstalled-pkg (path spec maj min))
; PKG-PROMISE : PKG | UNINSTALLED-PKG
; ORIGIN : 'normal | 'development-link
(define (pkg-promise? p) (or (pkg? p) (uninstalled-pkg? p)))
(define (normally-installed-pkg? p)
(eq? (pkg-origin p) 'normal))
(define (development-link-pkg? p)
(eq? (pkg-origin p) 'development-link))

41
collects/planet/private/planet-shared.ss
View File

@ -9,44 +9,11 @@ Various common pieces of code that both the client and server need to access
mzlib/port
(lib "getinfo.ss" "setup")
(prefix-in srfi1: srfi/1)
"../config.ss")
"../config.ss"
"data.ss")
(provide (all-defined-out))
; ==========================================================================================
; DATA
; defines common data used by the PLaneT system
; ==========================================================================================
; exn:i/o:protocol: exception indicating that a protocol error occured
(define-struct (exn:i/o:protocol exn:fail:network) ())
; FULL-PKG-SPEC : struct pkg-spec
(define-struct pkg-spec
(name ; string
maj ; (Nat | #f)
minor-lo ; (Nat | #f)
minor-hi ; (Nat | #f)
path ; (listof string)
stx ; (syntax | #f)
core-version ; string
)
#:transparent)
; PKG : string (listof string) Nat Nat path ORIGIN
(define-struct pkg (name route maj min path origin))
; UNINSTALLED-PKG : path FULL-PKG-SPEC Nat Nat
(define-struct uninstalled-pkg (path spec maj min))
; PKG-PROMISE : PKG | UNINSTALLED-PKG
; ORIGIN : 'normal | 'development-link
(define (pkg-promise? p) (or (pkg? p) (uninstalled-pkg? p)))
(define (normally-installed-pkg? p)
(eq? (pkg-origin p) 'normal))
(define (development-link-pkg? p)
(eq? (pkg-origin p) 'development-link))
(provide (all-defined-out)
(all-from-out "data.ss"))
; ==========================================================================================
; CACHE LOGIC

1
collects/planet/private/short-syntax-helpers.ss
View File

@ -25,6 +25,7 @@
;; splits the given string into the nonempty substring before the first slash and the substring after it
;; on failure returns whatever the given #:on-error function returns when given the entire string
(define get-next-slash (get-next-fragment #rx"^([^/]+)/(.*)$"))
(define get-next-slash-or-end (get-next-fragment #rx"^([^/]+)/?(.*)$"))
;; get-to-next-colon-or-end : [#:on-error (string -> a)] -> string -> (union (values string string) a)
;; splits the given string into the nonempty substring before the initial : and the substring after it, or

102
collects/planet/resolver.ss
View File

@ -157,7 +157,8 @@ an appropriate subdirectory.
"config.ss"
"private/planet-shared.ss"
"private/linkage.ss")
"private/linkage.ss"
"parsereq.ss")
(provide (rename resolver planet-module-name-resolver)
resolve-planet-path
@ -314,29 +315,22 @@ an appropriate subdirectory.
(let-values ([(path pkg) (get-planet-module-path/pkg spec #f #f)])
path))
;; get-planet-module-path/pkg :PLANET-REQUEST symbol syntax[PLANET-REQUEST] -> path PKG
;; get-planet-module-path/pkg :PLANET-REQUEST symbol syntax[PLANET-REQUEST] -> (values path PKG)
;; returns the matching package and the file path to the specific request
(define (get-planet-module-path/pkg spec module-path stx)
(match (cdr spec)
[(file-name pkg-spec path ...)
(unless (string? file-name)
(raise-syntax-error #f (format "File name: expected a string, received: ~s" file-name) stx))
(unless (andmap string? path)
;; special-case to catch a possibly common error:
(if (ormap number? path)
(raise-syntax-error #f (format "Module path must consist of strings only, received a number (maybe you intended to specify a package version number?): ~s" path) stx)
(raise-syntax-error #f (format "Module path must consist of strings only, received: ~s" path) stx)))
(match-let* ([pspec (pkg-spec->full-pkg-spec pkg-spec stx)]
[result (get-package module-path pspec)])
(cond [(string? result)
(raise-syntax-error 'require result stx)]
[(pkg? result)
(values (apply build-path (pkg-path result)
(append path (list file-name)))
result)]))]
[_ (raise-syntax-error 'require (format "Illegal PLaneT invocation: ~e" (cdr spec)) stx)]))
(request->pkg (spec->req spec stx) module-path stx))
;; request->pkg : request symbol syntax[PLANET-REQUEST] -> (values path PKG)
(define (request->pkg req module-path stx)
(let* ([result (get-package module-path (request-full-pkg-spec req))])
(cond
[(string? result)
(raise-syntax-error 'require result stx)]
[(pkg? result)
(values (apply build-path (pkg-path result)
(append (request-path req) (list (request-file req))))
result)])))
;; PKG-GETTER ::= module-path pspec
;; (pkg -> A)
;; ((uninstalled-pkg -> void) (pkg -> void) ((string | #f) -> string | #f) -> A)
@ -348,8 +342,6 @@ an appropriate subdirectory.
;; is found eventually, and a function that gets to mess with the error message if the entire message
;; eventually fails.
;; get-package : module-path FULL-PKG-SPEC -> (PKG | string)
;; gets the package specified by pspec requested by the module in the given module path,
;; or returns a descriptive error message string if that's not possible
@ -386,68 +378,10 @@ an appropriate subdirectory.
(cons post-updater post-install-updaters)
(cons error-reporter error-reporters))))])))
(define (o f g) (λ (x) (f (g x))))
(define (o/and . es) (λ (x) (andmap (λ (f) (f x)) es)))
(define (o/or . es) (λ (x) (ormap (λ (f) (f x)) es)))
; pkg-spec->full-pkg-spec : PKG-SPEC syntax -> FULL-PKG-SPEC
(define (pkg-spec->full-pkg-spec spec stx)
(define (pkg name maj lo hi path) (make-pkg-spec name maj lo hi path stx (version)))
(define (fail* msg)
(raise-syntax-error 'require (string->immutable-string msg) stx))
(define (fail)
(fail* (format "Invalid PLaneT package specifier: ~e" spec)))
(match spec
[((? string? owner) (? string? package) ver-spec ...)
(match-let ([(maj min-lo min-hi) (version->bounds ver-spec fail*)])
(pkg package maj min-lo min-hi (list owner)))]
[((? (o not string?) owner) _ ...)
(fail* (format "Expected string [package owner] in first position, received: ~e" owner))]
[(_ (? (o not string?) pkg) _ ...)
(fail* (format "Expected string [package name] in second position, received: ~e" pkg))]
[_ (fail)]))
;; version->bounds : VER-SPEC -> (list (number | #f) number (number | #f)) | #f
;; determines the bounds for a given version-specifier
;; [technically this handles a slightly extended version of VER-SPEC where MAJ may
;; be in a list by itself, because that's slightly more convenient for the above fn]
(define (version->bounds spec-list fail)
(match spec-list
[() (list #f 0 #f)]
[(? number? maj) (version->bounds (list maj))]
[((? number? maj)) (list maj 0 #f)]
[((? number? maj) min-spec)
(let ((pkg (lambda (min max) (list maj min max))))
(match min-spec
[(? number? min) (pkg min #f)]
[((? number? lo) (? number? hi)) (pkg lo hi)]
[('= (? number? min)) (pkg min min)]
[('+ (? number? min)) (pkg min #f)]
[('- (? number? min)) (pkg 0 min)]
;; failure cases
[(? (o/and (o not number?)
(o/or (o not list?)
(λ (x) (not (= (length x) 2))))))
(fail (format "Expected number or version range specifier for minor version specification, received: ~e" min-spec))]
[((? (λ (x)
(and (not (number? x))
(not (memq x '(= + -)))))
range)
_)
(fail (format "Illegal range specifier in minor version specification. Legal range specifiers are numbers, =, +, -; given: ~e" range))]
[(_ (? (o not number?) bnd))
(fail (format "Expected number as range bound in minor version specification, given: ~e" bnd))]
[_ (fail (format "Illegal minor version specification: ~e" min-spec))]))]
;; failure cases
[(? (o/and (o not number?) (o not list?)) v)
(fail (format "Version specification expected number or sequence, received: ~e" v))]
[((? (o not number?) maj) _ ...)
(fail (format "Version specification expected number for major version, received: ~e" maj))]
[_ (fail "Invalid version specification")]))
; ==========================================================================================
; PHASE 2: CACHE SEARCH