From debad064e7310cfd24d08b33250439fea22f276c Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Wed, 5 Jan 2011 20:29:05 -0500 Subject: [PATCH] Moved most of the planet-related bindings from unstable/scribble and unstable/planet to planet/scribble and planet/util. Did not move define-planet-package; it is not as crucial as the "this-package" macros. --- collects/planet/scribble.rkt | 192 +++++++++++++++++++++ collects/planet/syntax.rkt | 9 +- collects/planet/util.rkt | 39 ++++- collects/unstable/planet-syntax.rkt | 46 +---- collects/unstable/planet.rkt | 11 +- collects/unstable/require.rkt | 8 +- collects/unstable/scribblings/planet.scrbl | 6 +- 7 files changed, 243 insertions(+), 68 deletions(-) create mode 100644 collects/planet/scribble.rkt diff --git a/collects/planet/scribble.rkt b/collects/planet/scribble.rkt new file mode 100644 index 0000000000..61a4e16d34 --- /dev/null +++ b/collects/planet/scribble.rkt @@ -0,0 +1,192 @@ +#lang racket/base + +(provide + this-package-in + racketmod/this-package + racketmodname/this-package + racketmodlink/this-package + defmodule/this-package + defmodulelang/this-package + defmodulereader/this-package + defmodule*/this-package + defmodulelang*/this-package + defmodulereader*/this-package + defmodule*/no-declare/this-package + defmodulelang*/no-declare/this-package + defmodulereader*/no-declare/this-package + declare-exporting/this-package) + +(require + scribble/manual + planet/util + planet/version + (for-label + racket/base) + (for-syntax + racket/base + racket/block + syntax/parse + planet/syntax)) + +(define-syntax-rule (define-syntaxes-with [name ...] body ...) + (define-syntaxes [name ...] (block body ... (values name ...)))) + +(define-syntaxes-with + [ racketmod/this-package + racketmodname/this-package + racketmodlink/this-package + defmodule/this-package + defmodulelang/this-package + defmodulereader/this-package + defmodule*/this-package + defmodulelang*/this-package + defmodulereader*/this-package + defmodule*/no-declare/this-package + defmodulelang*/no-declare/this-package + defmodulereader*/no-declare/this-package + declare-exporting/this-package ] + + (define-syntax-class id/this-package + #:attributes [planet-id] + (pattern (~and src (~datum main)) + #:attr planet-id + (datum->syntax + #'src + (syntax-source-planet-package-symbol #'src #f) + #'src)) + (pattern suffix:id + #:attr planet-id + (datum->syntax + #'suffix + (syntax-source-planet-package-symbol #'suffix #'suffix) + #'suffix))) + + (define-splicing-syntax-class (maybe-option kw) + #:attributes [(option 1)] + (pattern (~seq + (~and key:keyword + (~fail #:unless (eq? (syntax-e #'key) kw))) + arg:expr) + #:attr (option 1) (list #'key #'arg)) + (pattern (~seq) #:attr (option 1) (list))) + + (define-splicing-syntax-class maybe-sources + #:attributes [(option 1)] + (pattern (~seq #:use-sources [src:id/this-package ...]) + #:attr (option 1) (list #'#:use-sources #'[(planet src.planet-id) ...])) + (pattern (~seq) #:attr (option 1) (list))) + + (define racketmod/this-package + (syntax-parser + [(_ filename lang:id/this-package . body) + #:declare filename (maybe-option '#:file) + (with-syntax ([spec (syntax/loc #'lang + (code:line planet lang.planet-id))]) + #'(racketmod filename.option ... spec . body))])) + + (define racketmodname/this-package + (syntax-parser #:literals [unsyntax] + [(~and orig (_ (unsyntax e:expr))) + #'(racketmodname + (unsyntax `(planet ,(make-planet-symbol (syntax-quote orig) e))))] + [(_ suffix:id/this-package) + #'(racketmodname (planet suffix.planet-id))])) + + (define racketmodlink/this-package + (syntax-parser + [(_ suffix:id/this-package . body) + #'(racketmodlink (planet suffix.planet-id) . body)])) + + (define defmodule/this-package + (syntax-parser + [(_ req-form suffix:id/this-package src:maybe-sources . body) + #:declare req-form (maybe-option '#:require-form) + #'(defmodule + req-form.option ... + (planet suffix.planet-id) + src.option ... + . body)])) + + (define defmodule*/this-package + (syntax-parser + [(_ req-form [suffix:id/this-package ...] src:maybe-sources . body) + #:declare req-form (maybe-option '#:require-form) + #'(defmodule* + req-form.option ... + [(planet suffix.planet-id) ...] + src.option ... + . body)])) + + (define defmodule*/no-declare/this-package + (syntax-parser + [(_ req-form [suffix:id/this-package ...] . body) + #:declare req-form (maybe-option '#:require-form) + #'(defmodule*/no-declare + req-form.option ... + [(planet suffix.planet-id) ...] + . body)])) + + (define defmodulelang/this-package + (syntax-parser + [(_ suffix:id/this-package #:module-paths [path:id/this-package ...] + src:maybe-sources + . body) + #'(defmodulelang (racket (code:line planet suffix.planet-id)) + #:module-paths [(planet path.planet-id) ...] + src.option ... + . body)] + [(_ suffix:id/this-package src:maybe-sources . body) + #'(defmodulelang (racket (code:line planet suffix.planet-id)) + #:module-paths [(planet suffix.planet-id)] + src.option ... + . body)])) + + (define defmodulelang*/this-package + (syntax-parser + [(_ [suffix:id/this-package ...] #:module-paths [path:id/this-package ...] + src:maybe-sources + . body) + #'(defmodulelang* [(racket (code:line planet suffix.planet-id)) ...] + #:module-paths [(planet path.planet-id) ...] + src.option ... + . body)] + [(_ [suffix:id/this-package ...] src:maybe-sources . body) + #'(defmodulelang* [(racket (code:line planet suffix.planet-id)) ...] + #:module-paths [(planet suffix.planet-id) ...] + src.option ... + . body)])) + + (define defmodulelang*/no-declare/this-package + (syntax-parser + [(_ [suffix:id/this-package ...] #:module-paths [path:id/this-package ...] + . body) + #'(defmodulelang*/no-declare + [(racket (code:line planet suffix.planet-id)) ...] + #:module-paths [(planet path.planet-id) ...] + . body)] + [(_ [suffix:id/this-package ...] . body) + #'(defmodulelang*/no-declare + [(racket (code:line planet suffix.planet-id)) ...] + #:module-paths [(planet suffix.planet-id) ...] + . body)])) + + (define defmodulereader/this-package + (syntax-parser + [(_ suffix:id/this-package src:maybe-sources . body) + #'(defmodulereader (planet suffix.planet-id) src.option ... . body)])) + + (define defmodulereader*/this-package + (syntax-parser + [(_ [suffix:id/this-package ...] src:maybe-sources . body) + #'(defmodulereader* [(planet suffix.planet-id) ...] src.option ... + . body)])) + + (define defmodulereader*/no-declare/this-package + (syntax-parser + [(_ [suffix:id/this-package ...] . body) + #'(defmodulereader*/no-declare [(planet suffix.planet-id) ...] . body)])) + + (define declare-exporting/this-package + (syntax-parser + [(_ suffix:id/this-package ... src:maybe-sources) + #'(declare-exporting (planet suffix.planet-id) ... src.option ...)]))) diff --git a/collects/planet/syntax.rkt b/collects/planet/syntax.rkt index 722b899d93..812ac71729 100644 --- a/collects/planet/syntax.rkt +++ b/collects/planet/syntax.rkt @@ -8,7 +8,12 @@ syntax-source-planet-package-minor syntax-source-planet-package-symbol) -(require racket/match planet/util unstable/syntax) +(require racket/match + planet/util + syntax/parse + unstable/syntax + (for-template racket/base) + (for-label racket/base)) (define (syntax-source-planet-package stx) (let* ([dir (syntax-source-directory stx)]) @@ -46,7 +51,7 @@ (if suffix (format-symbol "/~a" suffix) "")))] [#f #f])) -(define (make-planet-require-spec stx id/f) +(define (make-planet-require-spec stx [id/f #f]) (datum->syntax stx (list #'planet (syntax-source-planet-package-symbol stx id/f)) diff --git a/collects/planet/util.rkt b/collects/planet/util.rkt index d76d6b15ab..ed5a32eac3 100644 --- a/collects/planet/util.rkt +++ b/collects/planet/util.rkt @@ -24,8 +24,9 @@ setup/plt-single-installer setup/getinfo setup/unpack - - (for-syntax racket/base) + + unstable/syntax + (for-syntax racket/base syntax/parse) (prefix-in srfi1: srfi/1) ) @@ -784,13 +785,16 @@ this-package-version-owner this-package-version-maj this-package-version-min + this-package-version-symbol + package-version->symbol + make-planet-symbol (rename-out [this-package-version/proc path->package-version])) (define-syntax (this-package-version stx) (syntax-case stx () [(_) - #`(this-package-version/proc - #,(datum->syntax stx `(,#'this-expression-source-directory)))])) + #`(this-package-version/proc + (this-expression-source-directory #,stx))])) (define-syntax define-getters (syntax-rules () @@ -809,8 +813,35 @@ (this-package-version-maj pd->maj) (this-package-version-min pd->min)) +(define-syntax (this-package-version-symbol stx) + (syntax-parse stx + [(_ (~optional suffix:id)) + #`(package-version->symbol + (this-package-version/proc + (this-expression-source-directory #,stx)) + #,@(if (attribute suffix) #'['suffix] #'[]))])) + ;; ---------------------------------------- +(define (make-planet-symbol stx [suffix #f]) + (match (syntax-source-directory stx) + [#f #f] + [dir (match (this-package-version/proc dir) + [#f #f] + [ver (package-version->symbol ver suffix)])])) + +(define (package-version->symbol ver [suffix #f]) + (match ver + [(list owner name major minor) + (string->symbol + (format "~a/~a:~a:~a~a" + owner + (regexp-replace #rx"\\.plt$" name "") + major + minor + (if suffix (format-symbol "/~a" suffix) "")))] + [#f #f])) + (define (this-package-version/proc srcdir) (let* ([package-roots (get-all-planet-packages)] [thepkg (ormap (predicate->projection (contains-dir? srcdir)) diff --git a/collects/unstable/planet-syntax.rkt b/collects/unstable/planet-syntax.rkt index a14de1f0df..fb65cbcb16 100644 --- a/collects/unstable/planet-syntax.rkt +++ b/collects/unstable/planet-syntax.rkt @@ -1,6 +1,6 @@ #lang racket/base -(provide make-planet-path +(provide (rename-out [make-planet-require-spec make-planet-path]) syntax-source-planet-package syntax-source-planet-package-owner syntax-source-planet-package-name @@ -8,46 +8,4 @@ syntax-source-planet-package-minor syntax-source-planet-package-symbol) -(require racket/match planet/util unstable/syntax) - -(define (syntax-source-planet-package stx) - (let* ([dir (syntax-source-directory stx)]) - (and dir (path->package-version dir)))) - -(define (syntax-source-planet-package-owner stx) - (match (syntax-source-planet-package stx) - [(list owner name major minor) owner] - [_ #f])) - -(define (syntax-source-planet-package-name stx) - (match (syntax-source-planet-package stx) - [(list owner name major minor) name] - [_ #f])) - -(define (syntax-source-planet-package-major stx) - (match (syntax-source-planet-package stx) - [(list owner name major minor) major] - [_ #f])) - -(define (syntax-source-planet-package-minor stx) - (match (syntax-source-planet-package stx) - [(list owner name major minor) minor] - [_ #f])) - -(define (syntax-source-planet-package-symbol stx [suffix #f]) - (match (syntax-source-planet-package stx) - [(list owner name major minor) - (string->symbol - (format "~a/~a:~a:~a~a" - owner - (regexp-replace "\\.plt$" name "") - major - minor - (if suffix (format-symbol "/~a" suffix) "")))] - [#f #f])) - -(define (make-planet-path stx id/f) - (datum->syntax - stx - (list #'planet (syntax-source-planet-package-symbol stx id/f)) - (or id/f stx))) +(require planet/util planet/syntax) diff --git a/collects/unstable/planet.rkt b/collects/unstable/planet.rkt index b7ef1aa891..76851cb74a 100644 --- a/collects/unstable/planet.rkt +++ b/collects/unstable/planet.rkt @@ -1,19 +1,10 @@ #lang racket/base (require (for-syntax racket/base unstable/planet-syntax) + planet/version unstable/planet-syntax unstable/require) -(define-syntax (this-package-version-symbol stx) - (syntax-case stx () - [(tpvi) - (quasisyntax/loc stx - '#,(syntax-source-planet-package-symbol stx #f))] - [(tpvi name) - (identifier? #'name) - (quasisyntax/loc stx - '#,(syntax-source-planet-package-symbol stx #'name))])) - (provide this-package-version-symbol this-package-in define-planet-package diff --git a/collects/unstable/require.rkt b/collects/unstable/require.rkt index c98dcffe75..540a4a6611 100644 --- a/collects/unstable/require.rkt +++ b/collects/unstable/require.rkt @@ -6,6 +6,7 @@ racket/provide-transform syntax/parse unstable/planet-syntax) + planet/version unstable/define) (define-syntax (define-planet-package stx) @@ -39,13 +40,6 @@ [spec (datum->syntax stx* sym)]) (expand-import spec))]))))])) -(define-syntax this-package-in - (make-require-transformer - (lambda (stx) - (syntax-parse stx - [(_ file:id) - (expand-import (make-planet-path stx #'file))])))) - (define-syntax this-package-out (make-provide-transformer (lambda (stx modes) diff --git a/collects/unstable/scribblings/planet.scrbl b/collects/unstable/scribblings/planet.scrbl index 7208e42e56..ea2187a39c 100644 --- a/collects/unstable/scribblings/planet.scrbl +++ b/collects/unstable/scribblings/planet.scrbl @@ -2,7 +2,11 @@ @(require scribble/eval scribble/bnf "utils.rkt" - (for-label racket/base scribble/manual unstable/planet planet/util)) + (for-label racket/base + scribble/manual + unstable/planet + (except-in planet/util + this-package-version-symbol))) @title[#:style 'quiet #:tag "cce-planet"]{@|PLaneT| Packages}