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

#lang planet new-style syntax

Browse Source 
svn: r9323
This commit is contained in:
Jacob Matthews 2008-04-15 20:09:46 +00:00
parent a34dcade58
commit 68f35e8b25
3 changed files with 103 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/planet/lang/reader.ss
View File

@ -1,34 +1,18 @@
#lang scheme/base
(require "../parsereq.ss")
(provide (rename-out [planet-read read]
[planet-read-syntax read-syntax]))
(define (planet-read-fn in spec->read-data)
(let* ([spec (read-line in)]
[pkgname (regexp-match #rx"^[ ]*([^ ]+)[ ]*([^ ]+)[ ]*([^ ]*)[ ]*([^ ]*)[ ]*$" spec)])
(unless pkgname
(raise-syntax-error 'read "bad syntax, oops"))
(let-values ([(_ owner pkgname majstr minstr) (apply values pkgname)])
(let ([maj (string->number majstr)]
[min (string->number minstr)])
(unless (or maj (string=? majstr ""))
(raise-syntax-error 'read "bad maj"))
(unless (or min (string=? minstr ""))
(raise-syntax-error 'read "bad min"))
(unless (or maj (not min))
(raise-syntax-error 'read "bad version number pair"))
(values
`(planet "lang/main.ss"
(,owner
,pkgname
,@(if maj `(,maj) '())
,@(if min `(,min) '())))
(spec->read-data
`(planet "lang/reader.ss"
(,owner
,pkgname
,@(if maj `(,maj) '())
,@(if min `(,min) '())))))))))
[parsed-spec
(with-handlers ([exn:parse-failure? (λ (e) (raise-syntax-error 'read "bad syntax"))])
(parse-package-string spec))])
(values
`(planet "lang/main.ss" ,parsed-spec)
(spec->read-data `(planet "lang/reader.ss" ,parsed-spec)))))
(define (wrap port spec read)
(let* ([body

81
collects/planet/parsereq.ss
View File

@ -5,12 +5,51 @@
"private/data.ss")
(provide (struct-out request)
parse-package-string
(struct-out exn:parse-failure)
spec->req
pkg-spec->full-pkg-spec
version->bounds)
version->bounds
string->longpkg
string->shortpkg
short-pkg-string->spec)
(define-struct request (full-pkg-spec file path))
(define (tospec owner pkg maj min)
`(,owner ,pkg ,@(if maj (list maj) '()) ,@(if min (list min) '())))
(define-struct (exn:parse-failure exn:fail) ())
(define (string->longpkg s)
(let ([mtch (regexp-match #rx"^[ ]*([^ :/]+)[ ]+([^ :/]+)[ ]*([0-9]*)[ ]*([0-9]*)[ ]*$" s)])
(if mtch
(let-values ([(owner pkg majstr minstr) (apply values (cdr mtch))])
(tospec owner pkg
(if (string=? majstr "") #f (string->number majstr))
(if (string=? minstr "") #f (string->number minstr))))
#f)))
(define (string->shortpkg s)
(define ((yell fmt) x) (raise (make-exn:parse-failure (format fmt x) (current-continuation-marks))))
(with-handlers ([exn:parse-failure? (λ (e) #f)])
(let* ([pkg-spec/tail (short-pkg-string->spec s yell)]
[pkg-spec (car pkg-spec/tail)]
[tail (cadr pkg-spec/tail)])
(if (regexp-match #rx"^[ ]*$" tail) pkg-spec #f))))
(define all-parsers (list string->longpkg string->shortpkg))
;; parse-package-string : string -> pkg-spec
;; parses a "package name string", the kind of string that shows up in places where we're only interested
;; in naming a particular package, not a full path
(define (parse-package-string str)
(define (yell str) (raise (make-exn:parse-failure str (current-continuation-marks))))
(ormap (λ (p) (p str)) all-parsers))
;; spec->req : sexp[require sexp] stx -> request
;; maps the given require spec to a planet package request structure
(define (spec->req spec stx)
(match (cdr spec)
[(file-name pkg-spec path ...)
@ -27,19 +66,29 @@
[((? (lambda (x) (or (symbol? x) (string? x))) s))
(let ([str (if (symbol? s) (symbol->string s) 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 '()))))))]
(let* ([pkg-spec/tail (short-pkg-string->spec str yell)]
[pkg-spec (car pkg-spec/tail)]
[tail (cadr pkg-spec/tail)]
[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)]))
;; short-pkg-string->spec : string (string -> string -> 'a) -> (list pkg-spec string)
;; extracts the named package from the given short-style string, returning
;; both that package spec and the leftover string
(define (short-pkg-string->spec str yell)
(try-parsing str
([(consume-whitespace)]
[owner (get-next-slash #:on-error (yell "expected an owner, received ~e"))]
[package (get-next-slash-or-end #:on-error (yell "expected a package, received ~e"))])
(λ (tail)
(let*-values ([(yell!) (yell "~a")]
[(pkg maj min) (parse-package package yell!)])
(list (tospec owner pkg maj min) tail)))))
; pkg-spec->full-pkg-spec : PKG-SPEC syntax -> FULL-PKG-SPEC
(define (pkg-spec->full-pkg-spec spec stx)
@ -60,10 +109,10 @@
[_ (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]
;; 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)]

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

@ -2,13 +2,16 @@
(provide (all-defined-out))
;; specialized version of haskell do notation for the particular parsing monad i'm using
(define-syntax try-parsing
(syntax-rules ()
[(_ v () body) (body v)]
[(_ v ([id expr] [id2 expr2] ...) body)
(let-values ([(this rest) (expr v)])
(let ([id this])
(try-parsing rest ([id2 expr2] ...) body)))]))
[(_ v ([expr] clause ...) body)
(let-values ([(dummy rest) (expr v)])
(try-parsing rest (clause ...) body))]
[(_ v ([id expr] clause ...) body)
(let-values ([(id rest) (expr v)])
(try-parsing rest (clause ...) body))]))
;; get-next-fragment : regexp -> [#:on-error (string -> a)] -> string -> (union (values string string) a)
;; helper for the below two functions
@ -24,38 +27,39 @@
;; get-next-slash : [#:on-error (string -> a)] -> string -> (union (values string string) a)
;; 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 consume-whitespace (get-next-fragment #rx"^([ ]*)(.*)$"))
(define get-next-slash (get-next-fragment #rx"^([^/]+)/(.*)$"))
(define get-next-slash-or-end (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
;; (values [initial-string] "") if the given string has no : in it.
(define get-to-next-colon-or-end (get-next-fragment #rx"^([^:]+):?(.*)$"))
;; parse-package : string stx -> (values string nat min-spec)
;; parse-package : string (string -> 'a) -> (values string nat min-spec)
;; given a package specifier, returns the package name, the package major version, and a descriptor
;; for the acceptible minor versions
(define (parse-package package stx)
(define (parse-package package yell)
(try-parsing package
([pkgname (get-to-next-colon-or-end)]
[maj (get-to-next-colon-or-end)])
(λ (min)
(values (parse-pkgname pkgname stx)
(parse-majspec maj stx)
(parse-minspec min stx)))))
(values (parse-pkgname pkgname yell)
(parse-majspec maj yell)
(parse-minspec min yell)))))
;; parse-pkgname : string stx -> string
;; parse-pkgname : string (string -> 'a) -> string
;; given a literal package name string as it would appear in shorthand syntax, returns
;; a fully-embellished name for the package being specified. stx is provided as an object
;; to blame in syntax errors if something goes wrong
(define (parse-pkgname pn stx)
;; a fully-embellished name for the package being specified. yell is provided as a function
;; to call to generate an error message if something goes wrong
(define (parse-pkgname pn yell)
(let ([m (regexp-match #rx"\\.plt$" pn)])
(if m pn (string-append pn ".plt"))))
;; parse-majspec : (#f stx -> #f) intersect (string stx -> number)
;; parse-majspec : (#f (string -> 'a) -> #f) intersect (string (string -> 'a) -> number)
;; given the literal major version string (or #f) returns the major version corresponding
;; to that string. stx is the syntax object to blame if something goes wrong
(define (parse-majspec majstr stx)
;; to that string. yell is the function to call with an error message if something goes wrong
(define (parse-majspec majstr yell)
(cond
[(not majstr) #f]
[else
@ -64,11 +68,10 @@
(let ([n (string->number majstr)])
(if (> n 0)
n
(raise-syntax-error #f
(format "Illegal major version specifier; expected version number greater than 0, received ~e" majstr))))]
[else (raise-syntax-error #f
(format "Illegal major version specifier; expected positive integer, received ~e" majstr)
stx)])]))
(yell (format "Illegal major version specifier; expected version number greater than 0, received ~e"
majstr))))]
[else
(yell (format "Illegal major version specifier; expected positive integer, received ~e" majstr))])]))
;; regexp-case : SYNTAX
;; provides a case operation for trying different regular expressions in sequence on a test string,
@ -90,10 +93,10 @@
(let-values ([(id ...) (apply values (cdr args))]) body)
(regexp-case* str c ...)))]))
;; parse-minspec : string stx -> min-spec
;; parse-minspec : string (string -> 'a) -> min-spec
;; returns the minor-version specification corresponding to the given string as an s-expression.
;; stx is the syntax object to blame if the string doesn't correspond to minor-version spec.
(define (parse-minspec minstr stx)
;; yell is the function to call if the string doesn't correspond to minor-version spec.
(define (parse-minspec minstr yell)
(cond
[(not minstr) #f]
[else
@ -105,6 +108,5 @@
[#rx"^([0-9]+)$" ((n) (string->number n))]
[#rx"^$" (() #f)] ;; here for convenience reasons. a bit gross, i know
[else
(raise-syntax-error #f
(format "Illegal minor version specifier; expected <=n, >=n, =n, n-m, or n, where n, m are positive integers; received ~e" minstr)
stx)])]))
(yell (format "Illegal minor version specifier; expected <=n, >=n, =n, n-m, or n, where n, m are positive integers; received ~e"
minstr))])]))