removed PLAI
svn: r2527
This commit is contained in:
Matthew Flatt
parent
c5492262fc
commit
923202a654
|
|
@ -1,10 +0,0 @@
|
|||
|
||||
(module datatype mzscheme
|
||||
(require "private/datatype.ss")
|
||||
|
||||
(define-type-case type-case else)
|
||||
|
||||
(provide type-case
|
||||
define-type
|
||||
provide-type))
|
||||
|
||||
|
|
@ -1,163 +0,0 @@
|
|||
|
||||
The _Programming Languages: Application and Interpretations_ languages
|
||||
are companion to the textbook of the same name.
|
||||
|
||||
In the language dialog box, you will find the four _PLAI_ language:
|
||||
|
||||
PLAI - Beginning Student
|
||||
PLAI - Intermediate Student with lambda
|
||||
PLAI - Advanced Student
|
||||
PLAI - Pretty Big
|
||||
|
||||
This language sequence follows the same progression as the book "How
|
||||
to Design Programs" (htdp). If you are learning Scheme with the book
|
||||
while taking the class, the PLAI languages will provide the same
|
||||
support as the HtDP languages. Namely, at each language level the
|
||||
error messages you receive are explained in term of the constructs you
|
||||
know so far, and are tailored to address the common errors done at that
|
||||
level.
|
||||
|
||||
--- Syntactic forms ---------------------------------------------------
|
||||
|
||||
> (define-type ID (VARIANT-ID (FIELD-ID CONTRACT-EXPR) ...) ...)
|
||||
|
||||
Defines the datatype ID and a function ID? that returns true for
|
||||
instances of the datatype, and false for any other value. Here, the
|
||||
name ID? means the given name ID, with an added question mark.
|
||||
|
||||
For each VARIANT-ID, a constructor VARIANT-ID is defined. The
|
||||
constructor takes as many arguments as the variant's FIELD-IDs, and
|
||||
it returns an instance of this datatype. Each argument to the
|
||||
constructor is checked by applying the contract produced by the
|
||||
variant's CONTRACT-EXPR.
|
||||
|
||||
In the PLAI Beginner language, a CONTRACT-EXPR should be the name of
|
||||
a predicate, i.e., a procedure of one argument that returns a
|
||||
boolean. In higher language levels, a CONTRACT-EXPR can produce
|
||||
anything that is allowed as a contract by MzLib's "contract.ss"
|
||||
library (which includes predicate procedures).
|
||||
|
||||
An instance constructed by the VARIANT-ID can be deconstructed using
|
||||
`type-case'. Also, for each FIELD-ID of a VARIANT-ID, `define-type'
|
||||
provides VARIANT-ID-FIELD-ID to access each field in an instance of
|
||||
each variant, and a predicate VARIANT-ID? to recognize instances of
|
||||
the variant.
|
||||
|
||||
In PLAI Intermediate and later, `define-type' produces additional
|
||||
contract-related bindings, and it also supports a generalization of
|
||||
ID. See "Datatypes and Contracts" below.
|
||||
|
||||
> (type-case DATATYPE-ID EXPR (VARIANT-ID (FIELD-ID ...) RESULT-EXPR ...) ...)
|
||||
> (type-case DATATYPE-ID EXPR (VARIANT-ID (FIELD-ID ...) RESULT-EXPR ...) ...
|
||||
(else ELSE-EXPR ...))
|
||||
|
||||
Branches on the datatype instance produced by EXPR, which must be an
|
||||
instance of the specified DATATYPE-ID (previously defined with
|
||||
`define-type'). Each clause pattern automatically extract the values
|
||||
stored in the fields of the structure. It binds the extracted values
|
||||
them to the names FIELD-IDs in the order that the fields were
|
||||
declared in the corresponding definition in the `define-type'.
|
||||
|
||||
The `type-case' form complains if you do not handle all the variants
|
||||
in a datatype. You can use the `else' keyword as the last clause of
|
||||
a `type-case' to create a catch-all clause. In that case, variants
|
||||
which are not handled by the other clauses will trigger the
|
||||
evaluation of the ELSE-EXPR.
|
||||
|
||||
If it should not be possible to reach the `else' clause according to
|
||||
the logic of your program, your ELSE-EXPR should be a call to
|
||||
`error', which will raise an exception. For example:
|
||||
|
||||
(type-case shape a-circle
|
||||
[circle (c r) (* pi (sqr r))]
|
||||
[else (error "expected a circle!")])
|
||||
|
||||
--- Datatypes and Contracts ------------------------------------------------
|
||||
|
||||
> (define-type (ID PARAM-ID ...) (VARIANT-ID (FIELD-ID CONTRACT-EXPR) ...) ...)
|
||||
|
||||
This form of `define-type' is supported only in the PLAI
|
||||
Intermediate langauge and higher.
|
||||
|
||||
Each PARAM-ID stands for a contract parameter, and can
|
||||
appear as a free variable in the CONTRACT-EXPRs. When VARIANT-ID is
|
||||
used directly, then `any/c' is substituted for each PARAM-ID to
|
||||
obtain the relevant field contracts. Using ID by itself after
|
||||
`define-type' is the same as (ID) with no PARAM-IDs.
|
||||
|
||||
VARIANT-ID-of is bound to a constructor generator for each
|
||||
VARIANT-ID. Given a contract for each PARAM-ID, it produces a
|
||||
constructor whose field contracts are the CONTRACT-EXPRs with
|
||||
PARAM-IDs replaced by the given contracts.
|
||||
|
||||
ID-of/c is bound to a contract generator. Given a contract for each
|
||||
PARAM-ID, it produces a contract that corresponds to the union of
|
||||
the variant contracts PARAM-IDs replaced by the given contracts in
|
||||
the CONTRACT-EXPRs.
|
||||
|
||||
Finally, VARIANT-ID-of/c is bound to a contract generator for each
|
||||
VARIANT-ID. Given a contract for each PARAM-ID, it produces a
|
||||
constructor whose field contracts are the CONTRACT-EXPRs with
|
||||
PARAM-IDs replaced by the given contracts.
|
||||
|
||||
--- Testing support ---------------------------------------------------
|
||||
|
||||
> (test result expected-value)
|
||||
|
||||
Compares the result of a test expression to the expected value, and
|
||||
return a list of three elements: the first element is the symbol
|
||||
'good (if the test passed) or 'bad (if the test failed), the second
|
||||
element is the result, and the third element is the expected value.
|
||||
|
||||
> (test/pred result predicate)
|
||||
|
||||
Applies the predicate to the result, and return a list of three
|
||||
elements: the first element is the symbol 'good (if the predicate
|
||||
returned true), or 'bad (if the predicate returned false), the
|
||||
second element is the result, and the third element is the expected
|
||||
values.
|
||||
|
||||
> (test/exn (lambda () expression) expected-error-message)
|
||||
|
||||
Evaluates the expression expecting an exception. This is useful to
|
||||
verify that your program correctly detects error conditions. If the
|
||||
expression does not raise an exception, TEST/PRED returns the list:
|
||||
|
||||
(list 'bad result expected-error-message)
|
||||
|
||||
If the evaluation of the expression did throw an exception, TEST/PRED
|
||||
will pattern match the error message against the
|
||||
expected-error-message, and return 'bad if the error was not the
|
||||
expected error. EXPECTED-ERROR-MESSAGE should be a few words from
|
||||
the expected error message. For example:
|
||||
|
||||
(text/exn (lambda () (/ 3 0)) "by zero")
|
||||
|
||||
evaluates to:
|
||||
|
||||
(list 'good #(struct:exn) "by zero")
|
||||
|
||||
> (print-tests false|true|'good|'bad|'stop)
|
||||
|
||||
PRINT-TESTS controls printing of test by TEST, TEST/PRED and TEST/EXN.
|
||||
You can pass one of five values to PRINT-TESTS:
|
||||
|
||||
false Test result are not printed, they are simply returned. The
|
||||
results of tests evaluated at the top-level will be
|
||||
printed by DrScheme in the interaction panel, as usual.
|
||||
(this is the default)
|
||||
|
||||
true all test results are printed
|
||||
|
||||
'good only successful test results are printed
|
||||
|
||||
'bad only failed test results are printed
|
||||
|
||||
'stop testing will stops at the first test that fails, by throwing
|
||||
an exn:test exception.
|
||||
|
||||
> (test-inexact-epsilon number)
|
||||
|
||||
Sets the precision used by TEST to check the correctness of inexact
|
||||
numbers. By default, floating-point results are considered correct
|
||||
if they fall within 0.01 from their the expected value.
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(require (lib "string-constant.ss" "string-constants"))
|
||||
|
||||
(define name "PLAI")
|
||||
(define doc.txt "doc.txt")
|
||||
(define tools (list "plai-tool.ss"))
|
||||
(define tool-names (list "Programming Languages: Application and Interpretation"))
|
||||
(define tool-urls (list "http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/"))
|
||||
|
||||
(define textbook-pls
|
||||
(list (list '("plai-icon.png" "plai")
|
||||
"Programming Languages: Application and Interpretation"
|
||||
(string-constant teaching-languages)
|
||||
"Programming Languages: Application and Interpretation"
|
||||
"PLAI - Beginning Student"))))
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
(module plai-advanced mzscheme
|
||||
(require (rename (lib "htdp-advanced.ss" "lang") plai-else else)
|
||||
(lib "contract.ss" "mzlib" "private")
|
||||
"private/datatype.ss"
|
||||
"test-harness.ss")
|
||||
|
||||
;; This macro requires & provides bindings without
|
||||
;; making them locally visible:
|
||||
(define-syntax (provide-advanced stx)
|
||||
#'(begin
|
||||
(require (lib "htdp-advanced.ss" "lang"))
|
||||
(provide (all-from-except (lib "htdp-advanced.ss" "lang")
|
||||
plai-else))))
|
||||
(provide-advanced)
|
||||
|
||||
(provide (rename advanced-type-case type-case)
|
||||
define-type
|
||||
require provide provide-type
|
||||
(all-from-except (lib "contract.ss" "mzlib" "private") contract)
|
||||
(all-from "test-harness.ss"))
|
||||
|
||||
(define-type-case advanced-type-case plai-else))
|
||||
|
|
@ -1,75 +0,0 @@
|
|||
(module plai-beginner mzscheme
|
||||
(require (rename (lib "htdp-beginner.ss" "lang") plai-else else)
|
||||
(lib "prim.ss" "lang")
|
||||
"private/datatype.ss"
|
||||
"private/datatype-core.ss"
|
||||
"test-harness.ss")
|
||||
|
||||
;; This macro requires & provides bindings without
|
||||
;; making them locally visible:
|
||||
(define-syntax (provide-beginner stx)
|
||||
#'(begin
|
||||
(require (lib "htdp-beginner.ss" "lang"))
|
||||
(provide (all-from-except (lib "htdp-beginner.ss" "lang")
|
||||
plai-else))))
|
||||
(provide-beginner)
|
||||
|
||||
(provide (rename beginner-type-case type-case)
|
||||
(rename beginner-define-type define-type)
|
||||
require provide provide-type
|
||||
(all-from "test-harness.ss"))
|
||||
|
||||
(define-syntax (name-it stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id expr)
|
||||
(identifier? #'id)
|
||||
#'(let ([id expr]) id)]
|
||||
[(_ non-id expr)
|
||||
#'expr]))
|
||||
|
||||
;; For beginner, `define-type' requires predicates for
|
||||
;; contracts, and it doesn't define contracts
|
||||
(define-syntax (beginner-define-type stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name (variant (field predicate) ...) ...)
|
||||
(let ([name #'name])
|
||||
(unless (identifier? name)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for the type name"
|
||||
stx
|
||||
name))
|
||||
(with-syntax ([orig-stx stx]
|
||||
[name name]
|
||||
[name? (datum->syntax-object name
|
||||
(string->symbol
|
||||
(format "~a?" (syntax-e name))))])
|
||||
#'(define-datatype-core orig-stx
|
||||
(define-selectors define-predicates (kind "type"))
|
||||
define-proc-values
|
||||
name () name?
|
||||
(variant (field (name-it predicate (lambda (x) (predicate x)))) ...)
|
||||
...)))]
|
||||
;; If the above pattern doesn't match, let `define-type' handle the syntax errors:
|
||||
[(_ name-stx . variants)
|
||||
(identifier? #'name-stx)
|
||||
#'(define-type name-stx . variants)]
|
||||
[(_ . __)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for the type name"
|
||||
stx)]))
|
||||
|
||||
(define-syntax (define-proc-values stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) expr)
|
||||
(with-syntax ([(alt-id ...) (generate-temporaries #'(id ...))])
|
||||
(with-syntax ([top-level-hack (if (eq? 'top-level (syntax-local-context))
|
||||
#'(define-syntaxes (alt-id ...) (values))
|
||||
#'(begin))])
|
||||
#'(begin
|
||||
top-level-hack
|
||||
(define-primitive id alt-id) ...
|
||||
(define-values (alt-id ...) expr))))]))
|
||||
|
||||
(define-type-case beginner-type-case plai-else))
|
||||
|
|
@ -1,122 +0,0 @@
|
|||
|
||||
;; Like PLAI advanced, but with dynamic scope.
|
||||
;; No `let', `let*', or `letrec'.
|
||||
;;`local' expects ;; all definitions to have the
|
||||
;; form `(define id expr)'.
|
||||
|
||||
(module plai-dynamic mzscheme
|
||||
(require (rename (lib "htdp-advanced.ss" "lang") plai-else else)
|
||||
(rename (lib "htdp-advanced.ss" "lang") advanced-define define)
|
||||
"private/datatype.ss"
|
||||
"test-harness.ss")
|
||||
|
||||
;; This macro requires & provides bindings without
|
||||
;; making them locally visible:
|
||||
(define-syntax (provide-advanced stx)
|
||||
#'(begin
|
||||
(require (all-except (lib "htdp-advanced.ss" "lang")
|
||||
#%top define local let let* letrec lambda))
|
||||
(provide (all-from-except (lib "htdp-advanced.ss" "lang")
|
||||
plai-else advanced-define))))
|
||||
(provide-advanced)
|
||||
|
||||
(define-for-syntax (make-dynamic k)
|
||||
(make-set!-transformer
|
||||
(lambda (stx)
|
||||
(syntax-case stx (set!)
|
||||
[id
|
||||
(identifier? #'id)
|
||||
#'(lookup-dynamic 'id)]
|
||||
[(set! id val)
|
||||
#'(set-dynamic! 'id val)]
|
||||
[(id expr ...)
|
||||
#'((lookup-dynamic 'id) expr ...)]))))
|
||||
|
||||
(define-syntax to-dynamic
|
||||
(syntax-rules ()
|
||||
[(_ (id ...) expr)
|
||||
(with-continuation-mark*
|
||||
('id ...) ((box id) ...)
|
||||
(let-syntax ([id (make-dynamic (quote-syntax id))]
|
||||
...)
|
||||
expr))]))
|
||||
|
||||
(define-syntax (dynamic-type-case stx)
|
||||
(syntax-case stx ()
|
||||
[(_ type expr
|
||||
[id (param ...) body-expr]
|
||||
...)
|
||||
#'(advanced-type-case
|
||||
type expr
|
||||
[id (param ...)
|
||||
(to-dynamic (param ...)
|
||||
body-expr)] ...)]
|
||||
[(_ . rest)
|
||||
#'(advanced-type-case . rest)]))
|
||||
|
||||
(define-syntax (dynamic-define stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id arg ...) body-expr)
|
||||
#'(advanced-define (id arg ...)
|
||||
(to-dynamic
|
||||
(arg ...)
|
||||
body-expr))]
|
||||
[(_ . rest)
|
||||
#'(advanced-define . rest)]))
|
||||
|
||||
(define-syntax (dynamic-lambda stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) expr)
|
||||
#'(lambda (id ...)
|
||||
(to-dynamic (id ...)
|
||||
expr))]))
|
||||
|
||||
(define-syntax (dynamic-local stx)
|
||||
(syntax-case stx (dynamic-define)
|
||||
[(_ [(dynamic-define id val) ...] body-expr)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
#'(let [(id val) ...]
|
||||
(to-dynamic (id ...)
|
||||
body-expr))]))
|
||||
|
||||
(define-syntax (dynamic-top stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . id)
|
||||
(identifier? #'id)
|
||||
#'(lookup-dynamic 'id)]))
|
||||
|
||||
(define (lookup-dynamic id)
|
||||
(let ([v (continuation-mark-set-first #f id)])
|
||||
(if v
|
||||
(unbox v)
|
||||
(namespace-variable-value id #f (lambda ()
|
||||
(error 'eval
|
||||
"no dynamic value for identifier: ~a"
|
||||
id))))))
|
||||
|
||||
(define (set-dynamic! id val)
|
||||
(let ([v (continuation-mark-set-first #f id)])
|
||||
(if v
|
||||
(set-box! v val)
|
||||
(namespace-set-variable-value! id val))))
|
||||
|
||||
(define-syntax with-continuation-mark*
|
||||
(syntax-rules ()
|
||||
[(_ () () expr) expr]
|
||||
[(_ (key . krest) (val . vrest) expr)
|
||||
(with-continuation-mark key val
|
||||
(with-continuation-mark* krest vrest expr))]))
|
||||
|
||||
(provide (rename dynamic-type-case type-case)
|
||||
(rename dynamic-define define)
|
||||
(rename dynamic-lambda lambda)
|
||||
(rename dynamic-local local)
|
||||
(rename dynamic-top #%top)
|
||||
define-type
|
||||
require provide provide-type
|
||||
(all-from "test-harness.ss")
|
||||
|
||||
;; Hack to avoid certification bug :(
|
||||
lookup-dynamic)
|
||||
|
||||
(define-type-case advanced-type-case plai-else))
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 336 B |
|
|
@ -1,22 +0,0 @@
|
|||
(module plai-intermediate mzscheme
|
||||
(require (rename (lib "htdp-intermediate-lambda.ss" "lang") plai-else else)
|
||||
(lib "contract.ss" "mzlib" "private")
|
||||
"private/datatype.ss"
|
||||
"test-harness.ss")
|
||||
|
||||
;; This macro requires & provides bindings without
|
||||
;; making them locally visible:
|
||||
(define-syntax (provide-intermediate stx)
|
||||
#'(begin
|
||||
(require (lib "htdp-intermediate-lambda.ss" "lang"))
|
||||
(provide (all-from-except (lib "htdp-intermediate-lambda.ss" "lang")
|
||||
plai-else))))
|
||||
(provide-intermediate)
|
||||
|
||||
(provide (rename intermediate-type-case type-case)
|
||||
define-type
|
||||
require provide provide-type
|
||||
(all-from (lib "contract.ss" "mzlib" "private"))
|
||||
(all-from "test-harness.ss"))
|
||||
|
||||
(define-type-case intermediate-type-case plai-else))
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
(module plai-pretty-big mzscheme
|
||||
(require "private/datatype.ss"
|
||||
"test-harness.ss"
|
||||
(lib "contract.ss" "mzlib" "private"))
|
||||
|
||||
;; This macro requires & provides bindings without
|
||||
;; making them locally visible:
|
||||
(define-syntax (provide-advanced stx)
|
||||
#'(begin
|
||||
(require (lib "plt-pretty-big.ss" "lang"))
|
||||
(provide (all-from (lib "plt-pretty-big.ss" "lang")))))
|
||||
(provide-advanced)
|
||||
|
||||
(provide (rename pretty-big-type-case type-case)
|
||||
define-type
|
||||
provide-type
|
||||
(all-from (lib "contract.ss" "mzlib" "private"))
|
||||
(all-from "test-harness.ss"))
|
||||
|
||||
(define-type-case pretty-big-type-case else))
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
(module plai-reader mzscheme
|
||||
(require (lib "etc.ss"))
|
||||
|
||||
(provide (rename plai-read-syntax read-syntax))
|
||||
|
||||
(define (read-syntax/namespace-introduce . args)
|
||||
(let ([v (apply read-syntax args)])
|
||||
(if (syntax? v)
|
||||
(namespace-syntax-introduce v)
|
||||
v)))
|
||||
|
||||
(define (plai-read-syntax . args)
|
||||
(parameterize ([read-case-sensitive #t])
|
||||
(apply read-syntax/namespace-introduce args)))
|
||||
|
||||
|
||||
)
|
||||
|
|
@ -1,83 +0,0 @@
|
|||
|
||||
#|
|
||||
|
||||
The PLAI languages can almost be specified via info.ss fields, but
|
||||
the default printing style shold be 'constructor instead of 'write
|
||||
|
||||
|#
|
||||
|
||||
(module plai-tool mzscheme
|
||||
(require (lib "unitsig.ss")
|
||||
(lib "class.ss")
|
||||
(lib "struct.ss")
|
||||
(lib "tool.ss" "drscheme")
|
||||
(lib "string-constant.ss" "string-constants"))
|
||||
|
||||
(provide tool@)
|
||||
|
||||
(define tool@
|
||||
(unit/sig drscheme:tool-exports^
|
||||
(import drscheme:tool^)
|
||||
|
||||
(define (add-language! modname lang langnum summary)
|
||||
(define base%
|
||||
(class* object% (drscheme:language:simple-module-based-language<%>)
|
||||
(define/public (get-language-numbers)
|
||||
langnum)
|
||||
(define/public (get-language-position)
|
||||
(list (string-constant teaching-languages)
|
||||
"Programming Languages: Application and Interpretation"
|
||||
lang))
|
||||
(define/public (get-module)
|
||||
modname)
|
||||
(define/public (get-one-line-summary)
|
||||
summary)
|
||||
(define/public (get-language-url)
|
||||
"http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/")
|
||||
(define/public (get-reader)
|
||||
(lambda (src port)
|
||||
(let ([v (read-syntax src port)])
|
||||
(if (eof-object? v)
|
||||
v
|
||||
(namespace-syntax-introduce v)))))
|
||||
(super-instantiate ())))
|
||||
(drscheme:language-configuration:add-language
|
||||
(make-object
|
||||
((drscheme:language:get-default-mixin)
|
||||
(class (drscheme:language:module-based-language->language-mixin
|
||||
(drscheme:language:simple-module-based-language->module-based-language-mixin
|
||||
base%))
|
||||
(define/override (use-namespace-require/copy?) #t)
|
||||
|
||||
;; Change print style in default settings from 'write to 'constructor:
|
||||
(define/override (default-settings)
|
||||
(let ([s (super default-settings)])
|
||||
(to-style s 'constructor)))
|
||||
|
||||
(define/private (to-style s v)
|
||||
(drscheme:language:make-simple-settings
|
||||
(drscheme:language:simple-settings-case-sensitive s)
|
||||
v
|
||||
(drscheme:language:simple-settings-fraction-style s)
|
||||
(drscheme:language:simple-settings-show-sharing s)
|
||||
(drscheme:language:simple-settings-insert-newlines s)
|
||||
(drscheme:language:simple-settings-annotations s)))
|
||||
|
||||
(super-instantiate ()))))))
|
||||
|
||||
(define (phase1) (void))
|
||||
(define (phase2)
|
||||
(map add-language!
|
||||
'((lib "plai-beginner.ss" "plai")
|
||||
(lib "plai-intermediate.ss" "plai")
|
||||
(lib "plai-advanced.ss" "plai")
|
||||
(lib "plai-pretty-big.ss" "plai"))
|
||||
'("PLAI - Beginning Student"
|
||||
"PLAI - Intermediate Student with lambda"
|
||||
"PLAI - Advanced Student"
|
||||
"PLAI - Pretty Big")
|
||||
'((-500 0 0) (-500 0 1) (-500 0 3) (-500 0 4))
|
||||
'("PLAI: beginning students"
|
||||
"PLAI: beginner plus lexical scope and higher-order functions"
|
||||
"PLAI: intermediate plus lambda and mutation"
|
||||
"PLAI: PLT Pretty Big plus define-type"))))))
|
||||
|
|
@ -1,46 +0,0 @@
|
|||
|
||||
;; Like PLAI Advanced, but all functions must accept one
|
||||
;; argument, and the result is always changed to void.
|
||||
;; To enforce void returns, tail call are broken, currently.
|
||||
;; No `lambda', `local', `let', `let*', or `letrec'.
|
||||
|
||||
(module plai-void mzscheme
|
||||
(require (rename (lib "htdp-advanced.ss" "lang") plai-else else)
|
||||
(rename (lib "htdp-advanced.ss" "lang") advanced-define define)
|
||||
"private/datatype.ss"
|
||||
"test-harness.ss")
|
||||
|
||||
;; This macro requires & provides bindings without
|
||||
;; making them locally visible:
|
||||
(define-syntax (provide-void stx)
|
||||
#'(begin
|
||||
(require (all-except (lib "htdp-advanced.ss" "lang")
|
||||
lambda define local let let* letrec))
|
||||
(provide (all-from-except (lib "htdp-advanced.ss" "lang")
|
||||
plai-else advanced-define))))
|
||||
(provide-void)
|
||||
|
||||
(provide (rename void-define define)
|
||||
(rename void-type-case type-case)
|
||||
define-type
|
||||
require provide provide-type
|
||||
(all-from "test-harness.ss"))
|
||||
|
||||
(define-syntax (void-define stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id v)
|
||||
(identifier? #'id)
|
||||
#'(advanced-define id v)]
|
||||
[(_ (id) body)
|
||||
(identifier? #'id)
|
||||
#'(advanced-define (id) (begin body (void)))]
|
||||
[(_ (id x0 x ...) . rest)
|
||||
(andmap identifier? (syntax->list #'(id x0 x ...)))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"defined functions must accept no arguments in this language"
|
||||
stx)]
|
||||
[(_ . rest)
|
||||
#'(advanced-define . rest)]))
|
||||
|
||||
(define-type-case void-type-case plai-else))
|
||||
|
|
@ -1,66 +0,0 @@
|
|||
|
||||
(module core-utils mzscheme
|
||||
(require-for-template mzscheme)
|
||||
|
||||
(define-values (struct:dt make-dt dt? dt-selector dt-accessor)
|
||||
(make-struct-type 'dt #f 3 0 #f null (current-inspector)
|
||||
(lambda (dt stx)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "illegal use of ~a name" (dt-kind dt))
|
||||
stx))))
|
||||
(define dt-pred-stx (make-struct-field-accessor dt-selector 0 'pred-stx))
|
||||
(define dt-variants (make-struct-field-accessor dt-selector 1 'variants))
|
||||
(define dt-kind (make-struct-field-accessor dt-selector 2 'kind))
|
||||
|
||||
(define-struct vt (name-stx predicate-stx accessor-stx selector-stxes field-count))
|
||||
|
||||
(define-values (struct:dtvt make-dtvt dtvt? dtvt-selector dtvt-accessor)
|
||||
(make-struct-type 'dtvt #f 3 0 #f null (current-inspector)
|
||||
(lambda (dtvt stx)
|
||||
(syntax-case stx (set!)
|
||||
[(set! id v)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"cannot assign to a variant name"
|
||||
stx
|
||||
#'id)]
|
||||
[(id . args)
|
||||
(let ([v (syntax-local-value (dtvt-orig-id dtvt)
|
||||
(lambda () #f))])
|
||||
(if (and (procedure? v)
|
||||
(procedure-arity-includes? v 1))
|
||||
;; Apply macro binding for orig id to this id:
|
||||
(v stx)
|
||||
;; Orig id is not bound to a macro:
|
||||
(datum->syntax-object
|
||||
stx
|
||||
(cons (dtvt-orig-id dtvt)
|
||||
(syntax args))
|
||||
stx)))]
|
||||
[else
|
||||
(let ([v (syntax-local-value (dtvt-orig-id dtvt)
|
||||
(lambda () #f))])
|
||||
(if (and (procedure? v)
|
||||
(procedure-arity-includes? v 1))
|
||||
;; Apply macro binding for orig id to this id:
|
||||
(v stx)
|
||||
;; Orig id is not bound to a macro:
|
||||
(dtvt-orig-id dtvt)))]))))
|
||||
|
||||
(define dtvt-dt (make-struct-field-accessor dtvt-selector 0 'dt))
|
||||
(define dtvt-vt (make-struct-field-accessor dtvt-selector 1 'vt))
|
||||
(define dtvt-orig-id (make-struct-field-accessor dtvt-selector 2 'orig-id))
|
||||
|
||||
;; Helper function:
|
||||
(define (variant-assq name-stx variants)
|
||||
(let loop ([l variants])
|
||||
(if (module-identifier=? name-stx
|
||||
(vt-name-stx (car l)))
|
||||
(car l)
|
||||
(loop (cdr l)))))
|
||||
|
||||
(provide make-dt dt? dt-pred-stx dt-variants
|
||||
(struct vt (name-stx predicate-stx accessor-stx selector-stxes field-count))
|
||||
make-dtvt dtvt? dtvt-dt dtvt-vt
|
||||
variant-assq))
|
||||
|
|
@ -1,557 +0,0 @@
|
|||
|
||||
;; Shared infrastructure for define-type and define-datatype (eventually)
|
||||
|
||||
;; NOTE: datatypes are currently transparent. This works with EoPL's
|
||||
;; use of `equal?', and also makes constructor-style printing show
|
||||
;; all fields.
|
||||
|
||||
(module datatype-core mzscheme
|
||||
(require (lib "pconvert-prop.ss")
|
||||
(lib "contract.ss"))
|
||||
(require-for-syntax "core-utils.ss")
|
||||
|
||||
(provide define-datatype-core
|
||||
cases-core
|
||||
provide-datatype-core)
|
||||
|
||||
(define-for-syntax (generate-dt-temporaries l)
|
||||
(generate-temporaries l))
|
||||
|
||||
(define (projection-contract name proc)
|
||||
(let ([name `(,(car name) ,@(map (lambda (c)
|
||||
(if (contract? c)
|
||||
(contract-name c)
|
||||
(or (object-name c)
|
||||
c)))
|
||||
(cdr name)))])
|
||||
(make-contract name
|
||||
(lambda (pos neg src-info orig-str)
|
||||
(let ([proc (proc pos neg src-info orig-str)])
|
||||
(lambda (v)
|
||||
(let ([v2 (proc v)])
|
||||
(unless v2
|
||||
(raise-contract-error
|
||||
src-info
|
||||
pos
|
||||
neg
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
name
|
||||
v))
|
||||
v2)))))))
|
||||
|
||||
(define (dt-contract-proc c)
|
||||
(contract-proc
|
||||
(if (contract? c)
|
||||
c
|
||||
(flat-contract c))))
|
||||
|
||||
;; Syntax:
|
||||
;; (define-datatype-core orig-form (option ...) d-v name (alpha ...) pred-name variant ...)
|
||||
;; where the syntax is like `define-datatype' starting with `pred-name'.
|
||||
;;
|
||||
;; The `orig-stx' part is used for syntax-error reporting.
|
||||
;; The `d-v' is used in place of `define-values' to bind procedures. Beware
|
||||
;; that variant-constructor procedures are bound as syntax and an different
|
||||
;; name is bound to the actual procedure; if this "actual" binding itself
|
||||
;; turns out to be a macro, then uses of the constructor name are expanded
|
||||
;; by directly calling the macro from the "actual" binding
|
||||
;; Each `alpha' is a parameter to the contract expressions of each variant field;
|
||||
;; using `x-of' for variant `x' allows the parameter contracts to be supplied,
|
||||
;; while using `x' directly instantiates each parameter as `any/c'.
|
||||
;; The syntax for each `variant' is checked here; perform other syntax
|
||||
;; checks before using `define-datatype-core'.
|
||||
;; The valid options are:
|
||||
;; define-predicates : include `x?' for each variant `x'
|
||||
;; define-selectors : include `x-f' for each field `f' of each variant `x'
|
||||
;; define-polymorphic : include a definition of `x-of' for each variant `x'
|
||||
;; define-contracts : include a definition of `x-of/c' for each variant `x'
|
||||
;; requires define-selectors
|
||||
;; define-compatibility: include `make-x' for each variant `x'
|
||||
;; (kind "str") : uses "str" to name the result, either "type" or "datatype"
|
||||
;;
|
||||
;; Internals:
|
||||
;; The `name' is bound as syntax to a dt record, which supplies an id
|
||||
;; for the datatype's predicate, and also lists the ;; datatype's variants
|
||||
;; through vt records.
|
||||
;; Each variant constructor name is bound as syntax to a dtvt record,
|
||||
;; which gives the variant's vt record as well as its datatype's dt
|
||||
;; record.
|
||||
;; (See "core-utils.ss" for the dt, vt, and dtvt records.)
|
||||
;;
|
||||
(define-syntax define-datatype-core
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ orig-stx (option ...) define-proc-values name (alpha ...) pred-name
|
||||
(variant-name (field-name field-pred) ...)
|
||||
...)
|
||||
(let ([stx #'orig-stx]
|
||||
[options (syntax-object->datum #'(option ...))]
|
||||
[variant-names (syntax->list (syntax (variant-name ...)))]
|
||||
[field-nameses (map syntax->list
|
||||
(syntax->list (syntax ((field-name ...) ...))))])
|
||||
;; More syntax checks...
|
||||
(unless (identifier? (syntax name))
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier for the datatype name"
|
||||
stx (syntax name)))
|
||||
(unless (identifier? (syntax pred-name))
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier for the predicate name"
|
||||
stx (syntax pred-name)))
|
||||
(for-each (lambda (vt fields)
|
||||
(unless (identifier? vt)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for the variant name"
|
||||
stx vt))
|
||||
(for-each (lambda (field)
|
||||
(unless (identifier? field)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for the field name"
|
||||
stx field)))
|
||||
fields))
|
||||
variant-names
|
||||
field-nameses)
|
||||
;; Count the fields for each variant:
|
||||
(with-syntax ([(variant-field-count ...)
|
||||
(map (lambda (n)
|
||||
(datum->syntax-object (quote-syntax here) n #f))
|
||||
(map length field-nameses))]
|
||||
[(orig-variant-name ...)
|
||||
(generate-dt-temporaries variant-names)]
|
||||
[(variant-name/no-contract ...)
|
||||
(generate-dt-temporaries variant-names)]
|
||||
[(variant-of ...)
|
||||
(map (lambda (variant-name)
|
||||
(datum->syntax-object variant-name
|
||||
(string->symbol
|
||||
(format "~a-of" (syntax-e variant-name)))))
|
||||
variant-names)]
|
||||
[(variant-of/c ...)
|
||||
(map (lambda (variant-name)
|
||||
(datum->syntax-object variant-name
|
||||
(string->symbol
|
||||
(format "~a-of/c" (syntax-e variant-name)))))
|
||||
variant-names)]
|
||||
[type-of/c (datum->syntax-object #'name
|
||||
(string->symbol
|
||||
(format "~a-of/c" (syntax-e #'name))))]
|
||||
[(variant? ...)
|
||||
(map (lambda (vn)
|
||||
(datum->syntax-object
|
||||
vn
|
||||
((if (memq 'define-predicates options) string->symbol string->uninterned-symbol)
|
||||
(format "~a?" (syntax-e vn)))))
|
||||
variant-names)]
|
||||
[(variant-accessor ...)
|
||||
(map (lambda (vn)
|
||||
(datum->syntax-object
|
||||
vn
|
||||
(string->uninterned-symbol
|
||||
(format "~a-accessor" (syntax-e vn)))))
|
||||
variant-names)]
|
||||
[(variant-mutator ...)
|
||||
(generate-dt-temporaries variant-names)]
|
||||
[(make-variant ...)
|
||||
(generate-dt-temporaries variant-names)]
|
||||
[(struct:variant ...)
|
||||
(generate-dt-temporaries variant-names)]
|
||||
[((selector-name ...) ...)
|
||||
(map (lambda (variant-name field-names)
|
||||
(if (memq 'define-selectors options)
|
||||
(map (lambda (field-name)
|
||||
(datum->syntax-object
|
||||
variant-name
|
||||
(string->symbol
|
||||
(format "~a-~a"
|
||||
(syntax-e variant-name)
|
||||
(syntax-e field-name)))))
|
||||
field-names)
|
||||
null))
|
||||
variant-names
|
||||
field-nameses)]
|
||||
[((sub-contract-proc ...) ...)
|
||||
(map (lambda (field-names)
|
||||
(generate-dt-temporaries field-names))
|
||||
field-nameses)]
|
||||
[((field-pos ...) ...)
|
||||
(map (lambda (field-names)
|
||||
(let loop ([l field-names][i 0])
|
||||
(if (null? l)
|
||||
null
|
||||
(cons i (loop (cdr l) (add1 i))))))
|
||||
field-nameses)]
|
||||
[(make-variant-name ...)
|
||||
(map (lambda (vn)
|
||||
(datum->syntax-object
|
||||
vn
|
||||
(string->symbol
|
||||
(format "make-~a" (syntax-e vn)))))
|
||||
variant-names)]
|
||||
[datatype-str (or (ormap (lambda (option)
|
||||
(and (pair? option)
|
||||
(eq? 'kind (car option))
|
||||
(cadr option)))
|
||||
options)
|
||||
"datatype")])
|
||||
(quasisyntax
|
||||
(begin
|
||||
(define-syntaxes (name variant-name ...)
|
||||
;; Note: we're back to the transformer environment, here.
|
||||
;; Also, this isn't a transformer function, so any direct
|
||||
;; use of the name will trigger a syntax error. The name
|
||||
;; can be found by `syntax-local-value', though.
|
||||
(let ([cert (syntax-local-certifier)])
|
||||
(let-values ([(variant-name ...)
|
||||
(values
|
||||
(make-vt (cert (quote-syntax variant-name))
|
||||
(cert (quote-syntax variant?))
|
||||
(cert (quote-syntax variant-accessor))
|
||||
(list (quote-syntax selector-name) ...)
|
||||
variant-field-count)
|
||||
...)])
|
||||
(let ([dt (make-dt (cert (syntax pred-name))
|
||||
(list variant-name ...)
|
||||
datatype-str)])
|
||||
(values
|
||||
(make-set!-transformer dt)
|
||||
(make-set!-transformer
|
||||
(make-dtvt dt variant-name (quote-syntax orig-variant-name)))
|
||||
...)))))
|
||||
;; Bind the predicate and selector functions:
|
||||
(define-proc-values (pred-name
|
||||
variant-name/no-contract ...
|
||||
variant? ...
|
||||
variant-accessor ...
|
||||
selector-name ... ...
|
||||
orig-variant-name ...)
|
||||
;; Create a new structure for the datatype (using the
|
||||
;; datatype name in `struct', so it prints nicely).
|
||||
(let-values ([(struct:x make-x x? acc mut)
|
||||
(make-struct-type 'name #f 0 0 #f null (make-inspector))])
|
||||
(let-values ([(struct:variant make-variant variant?
|
||||
variant-accessor variant-mutator)
|
||||
(make-struct-type 'variant-name struct:x variant-field-count 0
|
||||
#f
|
||||
`((,prop:print-convert-constructor-name . variant-name))
|
||||
(make-inspector))]
|
||||
...)
|
||||
(let-values #,(if (memq 'define-selectors options)
|
||||
#`([(selector-name ...)
|
||||
(let ([accessor variant-accessor])
|
||||
(values (make-struct-field-accessor accessor field-pos 'field-name)
|
||||
...))]
|
||||
...)
|
||||
())
|
||||
;; User-available functions:
|
||||
(values
|
||||
x? ;; The datatype predicate
|
||||
;; Rename the constructor:
|
||||
make-variant ...
|
||||
variant? ...
|
||||
variant-accessor ...
|
||||
selector-name ... ...
|
||||
;; Constructors:
|
||||
(let ([f (delay (contract (let ([alpha any/c] ...) (-> field-pred ... x?))
|
||||
make-variant
|
||||
'definition 'use (quote-syntax variant-name)))])
|
||||
(let ([variant-name (lambda (field-name ...) ((force f) field-name ...))])
|
||||
variant-name))
|
||||
...)))))
|
||||
#,@(if (memq 'define-contracts options)
|
||||
#`((define (type-of/c alpha ...)
|
||||
(projection-contract
|
||||
`(type-of/c ,alpha ...)
|
||||
(lambda (pos neg src-info orig-str)
|
||||
(let ([sub-contract-proc (delay
|
||||
((dt-contract-proc field-pred) pos neg src-info orig-str))]
|
||||
... ...)
|
||||
(lambda (x)
|
||||
(and (pred-name x)
|
||||
(or (and (variant? x)
|
||||
(variant-name/no-contract
|
||||
((force sub-contract-proc) (selector-name x)) ...))
|
||||
...)))))))
|
||||
(define (variant-of/c alpha ...)
|
||||
(projection-contract
|
||||
`(variant-of/c ,alpha ...)
|
||||
(lambda (pos neg src-info orig-str)
|
||||
(let ([sub-contract-proc (delay
|
||||
((dt-contract-proc field-pred) pos neg src-info orig-str))]
|
||||
...)
|
||||
(lambda (x)
|
||||
(and (variant? x)
|
||||
(variant-name/no-contract
|
||||
((force sub-contract-proc) (selector-name x)) ...)))))))
|
||||
...)
|
||||
null)
|
||||
#,@(if (memq 'define-polymorphic options)
|
||||
#`((define (variant-of alpha ...)
|
||||
(let ([f (contract (-> field-pred ... pred-name)
|
||||
variant-name/no-contract
|
||||
'definition 'use (quote-syntax variant-name))])
|
||||
(let ([variant-name (lambda (field-name ...)
|
||||
(f field-name ...))])
|
||||
variant-name)))
|
||||
...)
|
||||
null)
|
||||
;; Compatibility bindings
|
||||
#,@(if (memq 'define-compatibility options)
|
||||
#`((define-proc-values (make-variant-name ...) (values variant-name ...)))
|
||||
null)))))]
|
||||
[(_ orig-stx (option ...) define-proc-values name (alpha ...) pred-name variant ...)
|
||||
;; Must be a bad variant...
|
||||
(for-each (lambda (variant)
|
||||
(syntax-case variant ()
|
||||
[(variant-name field ...)
|
||||
(let ([name (syntax variant-name)])
|
||||
(unless (identifier? name)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for the variant name"
|
||||
#'orig-stx
|
||||
name))
|
||||
;; Must be a bad field:
|
||||
(for-each (lambda (field)
|
||||
(syntax-case field ()
|
||||
[(field-name field-pred)
|
||||
(let ([name (syntax field-name)])
|
||||
(unless (identifier? name)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for the field name"
|
||||
#'orig-stx
|
||||
name)))]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected a field name followed by a predicate expression, all in parentheses"
|
||||
#'orig-stx
|
||||
field)]))
|
||||
(syntax->list (syntax (field ...)))))]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected a variant name followed by a sequence of field declarations, all in parentheses"
|
||||
#'orig-stx
|
||||
variant)]))
|
||||
(syntax->list (syntax (variant ...))))]
|
||||
[(_ orig_stx . __)
|
||||
;; trigger "bad syntax" error:
|
||||
(syntax-case #'orig-stx ())])))
|
||||
|
||||
(define-for-syntax (lookup-datatype datatype)
|
||||
(let ([v (and (identifier? datatype)
|
||||
(syntax-local-value datatype (lambda () #f)))])
|
||||
(and v
|
||||
(set!-transformer? v)
|
||||
(set!-transformer-procedure v))))
|
||||
|
||||
(define-syntax cases-core
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ orig-stx datatype-str case-begin cases-else
|
||||
datatype expr
|
||||
clause
|
||||
...)
|
||||
;; Get datatype information:
|
||||
(let ([stx #'orig-stx]
|
||||
[dt (lookup-datatype #'datatype)])
|
||||
(unless (dt? dt)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "not a ~a name" (syntax-e #'datatype-str))
|
||||
stx
|
||||
(syntax datatype)))
|
||||
|
||||
;; Parse clauses:
|
||||
(let-values ([(vts field-idss bodys else-body)
|
||||
(let loop ([clauses (syntax->list (syntax (clause ...)))][saw-cases null])
|
||||
(cond
|
||||
[(null? clauses)
|
||||
(values null null null #f)]
|
||||
[else
|
||||
(let ([clause (car clauses)])
|
||||
(syntax-case* clause (else) (lambda (a b)
|
||||
(module-identifier=? a #'cases-else))
|
||||
[(variant (field-id ...) body0 body1 ...)
|
||||
(let* ([variant (syntax variant)]
|
||||
[vt
|
||||
(ormap (lambda (dtv)
|
||||
(let ([vt-name (vt-name-stx dtv)])
|
||||
(and (module-identifier=? variant vt-name)
|
||||
dtv)))
|
||||
(dt-variants dt))]
|
||||
[orig-variant (and vt (vt-name-stx vt))])
|
||||
(unless orig-variant
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "not a variant of `~a'"
|
||||
(syntax-object->datum (syntax datatype)))
|
||||
stx
|
||||
variant))
|
||||
|
||||
(let ([field-ids (syntax->list (syntax (field-id ...)))])
|
||||
(for-each (lambda (fid)
|
||||
(unless (identifier? fid)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for a field"
|
||||
stx
|
||||
fid)))
|
||||
field-ids)
|
||||
(let ([dtv (variant-assq variant (dt-variants dt))])
|
||||
(unless (= (length field-ids)
|
||||
(vt-field-count dtv))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format
|
||||
"variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)"
|
||||
(syntax-object->datum variant)
|
||||
(syntax-object->datum (syntax datatype))
|
||||
(vt-field-count dtv)
|
||||
(length field-ids))
|
||||
stx
|
||||
clause)))
|
||||
|
||||
;; Check for duplicate local field ids:
|
||||
(let ([dup (check-duplicate-identifier field-ids)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate field identifier"
|
||||
stx
|
||||
dup)))
|
||||
|
||||
;; Check for redundant case:
|
||||
(when (memq orig-variant saw-cases)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate case"
|
||||
stx
|
||||
clause))
|
||||
|
||||
;; This clause is ok:
|
||||
(let-values ([(vts idss bodys else)
|
||||
(loop (cdr clauses) (cons orig-variant saw-cases))])
|
||||
(values (cons vt vts)
|
||||
(cons field-ids idss)
|
||||
(cons (with-syntax ([clause clause])
|
||||
(syntax (case-begin orig-stx clause body0 body1 ...)))
|
||||
bodys)
|
||||
else))))]
|
||||
[(else body0 body1 ...)
|
||||
(begin
|
||||
(unless (null? (cdr clauses))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"else clause must be last"
|
||||
stx
|
||||
clause))
|
||||
(values null null null (syntax (begin body0 body1 ...))))]
|
||||
[_else (raise-syntax-error
|
||||
#f
|
||||
"bad clause"
|
||||
stx
|
||||
clause)]))]))])
|
||||
|
||||
;; Missing any variants?
|
||||
(unless (or else-body
|
||||
(= (length vts) (length (dt-variants dt))))
|
||||
(let* ([here (map vt-name-stx vts)]
|
||||
[missing (let loop ([l (dt-variants dt)])
|
||||
(cond
|
||||
[(null? l) ""]
|
||||
[(ormap (lambda (i) (module-identifier=? (vt-name-stx (car l)) i)) here)
|
||||
(loop (cdr l))]
|
||||
[else
|
||||
(format " ~a~a"
|
||||
(syntax-e (vt-name-stx (car l)))
|
||||
(loop (cdr l)))]))])
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "missing cases for the following variants:~a" missing)
|
||||
stx)))
|
||||
|
||||
(with-syntax ([form-name (syntax-case stx () [(name . _) #'name])])
|
||||
|
||||
;; Create the result:
|
||||
(with-syntax ([pred (dt-pred-stx dt)]
|
||||
[(variant? ...) (map vt-predicate-stx vts)]
|
||||
[((field-extraction ...) ...)
|
||||
(map (lambda (vt)
|
||||
(with-syntax ([accessor (vt-accessor-stx vt)])
|
||||
(let loop ([n 0])
|
||||
(if (= n (vt-field-count vt))
|
||||
null
|
||||
(cons (with-syntax ([n n])
|
||||
(syntax (accessor v n)))
|
||||
(loop (add1 n)))))))
|
||||
vts)]
|
||||
[((field-id ...) ...) field-idss]
|
||||
[(body ...) bodys]
|
||||
[else-body (or else-body
|
||||
(syntax
|
||||
(error 'form-name "no variant case matched")))])
|
||||
(syntax/loc stx
|
||||
(let ([v expr])
|
||||
(if (not (pred v))
|
||||
(error 'form-name "not a ~a: ~e"
|
||||
(quote datatype) v)
|
||||
(cond
|
||||
[(variant? v)
|
||||
(let ([field-id field-extraction] ...)
|
||||
body)]
|
||||
...
|
||||
[else else-body]))))))))]
|
||||
[(_ orig-stx datatype-str cases-else datatype)
|
||||
(begin
|
||||
(unless (dt? (lookup-datatype #'datatype))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "not a ~a name" (syntax-e #'datatype-str))
|
||||
#'orig-stx
|
||||
(syntax datatype)))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "expected an expression after the ~a name" (syntax-e #'datatype-str))
|
||||
#'orig-stx))]
|
||||
[(_ orig-stx datatype-str cases-else)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "expected a ~a name" (syntax-e #'datatype-str))
|
||||
#'orig-stx)]
|
||||
[(_ orig_stx . __)
|
||||
;; trigger "bad syntax" error:
|
||||
(syntax-case #'orig-stx ())])))
|
||||
|
||||
(define-syntax provide-datatype-core
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ orig-stx datatype)
|
||||
(let ([stx #'orig-stx]
|
||||
[dt (syntax-local-value (syntax datatype) (lambda () #f))])
|
||||
(unless (dt? dt)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a datatype name"
|
||||
stx
|
||||
(syntax datatype)))
|
||||
(with-syntax ([pred (dt-pred-stx dt)]
|
||||
[(orig-variant ...)
|
||||
(map vt-name-stx (dt-variants dt))]
|
||||
[((selector ...) ...)
|
||||
(map vt-selector-stxes (dt-variants dt))]
|
||||
[(variant? ...)
|
||||
(map vt-predicate-stx (dt-variants dt))])
|
||||
(syntax
|
||||
(provide datatype
|
||||
pred
|
||||
orig-variant ...
|
||||
variant? ...
|
||||
selector ... ...))))]
|
||||
[(_ orig_stx . __)
|
||||
;; trigger "bad syntax" error:
|
||||
(syntax-case #'orig-stx ())]))))
|
||||
|
|
@ -1,71 +0,0 @@
|
|||
|
||||
(module datatype mzscheme
|
||||
|
||||
(require "datatype-core.ss")
|
||||
|
||||
(define-for-syntax (do-define-type stx name type-params variants)
|
||||
(unless (identifier? name)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for the type name"
|
||||
stx
|
||||
name))
|
||||
(for-each (lambda (type-param)
|
||||
(unless (identifier? type-param)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for a type parameter"
|
||||
stx
|
||||
type-param)))
|
||||
type-params)
|
||||
(with-syntax ([orig-stx stx]
|
||||
[name name]
|
||||
[name? (datum->syntax-object name
|
||||
(string->symbol
|
||||
(format "~a?" (syntax-e name))))]
|
||||
[(type-param ...) type-params]
|
||||
[variants variants])
|
||||
#'(define-datatype-core orig-stx
|
||||
(define-selectors define-predicates define-polymorphic define-contracts (kind "type"))
|
||||
define-values
|
||||
name (type-param ...) name?
|
||||
. variants)))
|
||||
|
||||
(define-syntax (define-type stx)
|
||||
(syntax-case stx (represented-as)
|
||||
[(_ (name-stx type-param-stx ...) . variants)
|
||||
(do-define-type stx #'name-stx (syntax->list #'(type-param-stx ...)) #'variants)]
|
||||
[(_ name-stx . variants)
|
||||
(do-define-type stx #'name-stx null #'variants)]
|
||||
[(_ . __)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for the type name"
|
||||
stx)]))
|
||||
|
||||
(define-syntax (case-begin stx)
|
||||
(syntax-case stx ()
|
||||
[(_ orig-stx orig-clause expr) #'expr]
|
||||
[(_ orig-stx orig-clause expr0 expr ...)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "expected only one result expression, found ~a"
|
||||
(add1 (length (syntax->list #'(expr ...)))))
|
||||
#'orig-stx
|
||||
#'orig-clause)]))
|
||||
|
||||
(define-syntax define-type-case
|
||||
(syntax-rules ()
|
||||
[(_ type-case else)
|
||||
(define-syntax (type-case stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . rest) #`(cases-core #,stx "type" case-begin else . rest)]))]))
|
||||
|
||||
(define-syntax (provide-type stx)
|
||||
(syntax-case stx ()
|
||||
[(provide-type . rest)
|
||||
#`(provide-datatype-core #,stx . rest)]))
|
||||
|
||||
(provide provide-type
|
||||
define-type
|
||||
define-type-case))
|
||||
|
|
@ -1,73 +0,0 @@
|
|||
(module test-harness mzscheme
|
||||
(provide (all-defined))
|
||||
(require (lib "list.ss")
|
||||
(lib "pretty.ss"))
|
||||
|
||||
(define print-tests (make-parameter #f))
|
||||
(define test-inspector (make-parameter (current-inspector)))
|
||||
(define test-inexact-epsilon (make-parameter 0.01))
|
||||
|
||||
(define-struct (exn:test exn) ())
|
||||
|
||||
(define (install-test-inspector)
|
||||
(test-inspector (current-inspector))
|
||||
(current-inspector (make-inspector))
|
||||
(print-struct #t))
|
||||
|
||||
(define (may-print-result result)
|
||||
(parameterize ([current-inspector (test-inspector)]
|
||||
[print-struct #t])
|
||||
(when (or (eq? (print-tests) (first result))
|
||||
(eq? (print-tests) #t))
|
||||
|
||||
(pretty-print result))
|
||||
(when (and (eq? (print-tests) 'stop)
|
||||
(eq? (first result) 'bad))
|
||||
(raise (make-exn:test (string->immutable-string (format "test failed: ~a" result))
|
||||
(current-continuation-marks))))))
|
||||
|
||||
|
||||
(define (test result expected)
|
||||
(let* ([test-result
|
||||
(cond [(or (and (number? result) (not (exact? result)))
|
||||
(and (number? expected) (not (exact? expected))))
|
||||
(< (abs (- result expected)) (test-inexact-epsilon))]
|
||||
[else
|
||||
(parameterize ([current-inspector (test-inspector)])
|
||||
(equal? result expected))])]
|
||||
[to-print (if test-result
|
||||
(list 'good result expected)
|
||||
(list 'bad result expected))])
|
||||
|
||||
(may-print-result to-print)
|
||||
to-print))
|
||||
|
||||
(define (test/pred result pred)
|
||||
(let* ([test-result (pred result)]
|
||||
[to-print (if test-result
|
||||
(list 'good result test-result)
|
||||
(list 'bad result test-result))])
|
||||
(may-print-result to-print)
|
||||
to-print))
|
||||
|
||||
(define (test/exn thunk expected-exception-msg)
|
||||
(unless (and (procedure? thunk)
|
||||
(procedure-arity-includes? thunk 0))
|
||||
(error (format
|
||||
"the first argument to test/exn should be a function of no arguments (a \"thunk\"), got ~a"
|
||||
thunk)))
|
||||
(let* ([result
|
||||
(with-handlers
|
||||
([exn:fail? (lambda (exn) exn)])
|
||||
(thunk))]
|
||||
[test-result
|
||||
(if (and (exn? result)
|
||||
(regexp-match expected-exception-msg (exn-message result)))
|
||||
(list 'good result expected-exception-msg)
|
||||
(list 'bad result expected-exception-msg))])
|
||||
(may-print-result test-result)
|
||||
test-result))
|
||||
|
||||
(install-test-inspector))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user