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

Moved most of the planet-related bindings from unstable/scribble and

Browse Source 
unstable/planet to planet/scribble and planet/util.  Did not move
define-planet-package; it is not as crucial as the "this-package" macros.
This commit is contained in:
Carl Eastlund 2011-01-05 20:29:05 -05:00
parent 8d36436465
commit debad064e7
7 changed files with 243 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

192
collects/planet/scribble.rkt Normal file
View File

@ -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 ...)])))

9
collects/planet/syntax.rkt
View File

@ -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))

39
collects/planet/util.rkt
View File

@ -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))

46
collects/unstable/planet-syntax.rkt
View File

@ -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)

11
collects/unstable/planet.rkt
View File

@ -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

8
collects/unstable/require.rkt
View File

@ -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)

6
collects/unstable/scribblings/planet.scrbl
View File

@ -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}