From 68f35e8b25a2b58d318ee2a1b2e94a8ea0dad5a4 Mon Sep 17 00:00:00 2001 From: Jacob Matthews Date: Tue, 15 Apr 2008 20:09:46 +0000 Subject: [PATCH] #lang planet new-style syntax svn: r9323 --- collects/planet/lang/reader.ss | 32 ++------ collects/planet/parsereq.ss | 81 +++++++++++++++---- .../planet/private/short-syntax-helpers.ss | 58 ++++++------- 3 files changed, 103 insertions(+), 68 deletions(-) diff --git a/collects/planet/lang/reader.ss b/collects/planet/lang/reader.ss index e46e67437a..55d64755a1 100644 --- a/collects/planet/lang/reader.ss +++ b/collects/planet/lang/reader.ss @@ -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 diff --git a/collects/planet/parsereq.ss b/collects/planet/parsereq.ss index d445cd09ff..797619efec 100644 --- a/collects/planet/parsereq.ss +++ b/collects/planet/parsereq.ss @@ -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)] diff --git a/collects/planet/private/short-syntax-helpers.ss b/collects/planet/private/short-syntax-helpers.ss index 55e2e467a5..df517cca4f 100644 --- a/collects/planet/private/short-syntax-helpers.ss +++ b/collects/planet/private/short-syntax-helpers.ss @@ -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))])]))