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

Implements FB case 116 "Allow declaring private (i.e. unique) variants, which inherit the more general shared ones with the same tag"

Browse Source
This commit is contained in:
Georges Dupéron 2016-03-11 16:43:53 +01:00
parent 7233cb85e9
commit 46b3785b47
4 changed files with 153 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
graph-lib/graph/__DEBUG_variant.rkt
View File

@ -21,6 +21,10 @@
(constructor dh1 Number String))
(constructor dh1 2 "y"))
(define-private-tagged txyz #:? txyz?
[a Number]
[b String])
(ann (constructor dk1 2 "y")
(constructor dk1 Number String))]

2
graph-lib/graph/remember.rkt
View File

@ -145,3 +145,5 @@
(variant . dj1)
(variant . dk1)
(variant . dl1)
(structure x y)
(variant . txyz)

110
graph-lib/graph/variant.lp2.rkt
View File

@ -39,7 +39,7 @@ example below where the second @tc[define-datatype] throws an error:
[Var (Symbol)]
[Lambda (Symbol Expr)])]
@section{The @racket[Variant] supertype}
@section[#:tag "variant|supertype"]{The @racket[Variant] supertype}
We define variants as instances of subtypes of the @tc[Tagged] structure:
@ -334,9 +334,9 @@ number of name collisions.
@section{@racket[define-tagged]}
@chunk[<define-tagged>
(define-syntax/parse (define-tagged tag:id [field type] …
(~optional #:type-noexpand)
(~maybe #:? tag?))
(define-syntax/parse (define-tagged tag:id
(~maybe #:? tag?)
[field type] …)
(define/with-syntax (pat …) (generate-temporaries #'(field …)))
(define/with-syntax (value …) (generate-temporaries #'(field …)))
(define/with-syntax default-tag? (format-id #'tag "~a?" #'tag))
@ -424,6 +424,103 @@ number of name collisions.
(check-not-equal?: (tagged-s2 4 "flob")
(tagged-s4 4 "flob"))]
@section{Uninterned tags}
We wish to be able to declare tags only visible to the
creator, unlike the ones above which are visible
everywhere.
We will define two flavours: one where uninterned tags
inherit the interned tag, os that the interned @tc[tag] is a
supertype of the uninterned @tc[tag] (but not the converse),
and a second, which we will call private tags, where the
private tag inherits directly from @tc[Tagged], the base
structure described in section @secref{variant|supertype},
and is therefore unrelated to the interned @tc[tag] (nor to
the uninterned @tc[tag] either).
@; TODO: this should be integrated a bit better with other function, for example
@; Tagged-predicate? (provided as Tagged?) is likely to not work on uninterned
@; tags.
@chunk[<define-uninterned-tagged>
(define-syntax/parse (define-private-tagged tag:id
(~maybe #:? tag?)
. (~and structure-type ([field type] …)))
(define/with-syntax default-tag? (format-id #'tag "~a?" #'tag))
(define-temp-ids "~a/struct" tag)
(define-temp-ids "~a/arg" (field …))
(define-temp-ids "~a/pat" (field …))
(template
(begin
(struct (T) tag/struct Tagged ()) ; Private
;(struct (T) tag/struct interned ()) ; Uninterned
(define-multi-id tag
#:type-expand-once
(tag/struct (structure . structure-type))
#:match-expander
(λ/syntax-parse (_ . (~and structure-pat
((~and field/pat :expr) …)))
(quasitemplate
(and (? (make-predicate (tag/struct Any)))
(app Tagged-value
#,(syntax/loc #'structure-pat
(structure [field field/pat] …))))))
#:call
(λ/syntax-parse (_ . (~and args ((~and field/arg :expr) …)))
(quasitemplate
(tag/struct #,(syntax/loc #'args
(structure #:instance
[field : type field/arg] …))))))
;; TODO: the return type is not precise enough, it should be:
;; #:+ (tag/struct (structure Any …))
;; #:- (! (tag/struct (structure Any …)))
(: (?? tag? default-tag?) (→ Any Boolean :
#:+ (tag/struct Any)))
(define ((?? tag? default-tag?) x)
(and ((make-predicate (tag/struct Any)) x)
((structure? field …) (Tagged-value x)))))))]
@chunk[<test-uninterned-tagged>
(define-syntax-rule (defp make mt)
(begin
(define-private-tagged txyz #:? txyz?
[a Number]
[b String])
(define (make) (txyz 1 "b"))
(define (mt v)
(match v
((txyz x y) (list 'macro y x))
(_ #f)))))
(defp make mt)
(define-private-tagged txyz #:? txyz?
[a Number]
[b String])
(check-equal?: (match (make)
((tagged txyz x y) (list 'out y x))
(_ #f))
#f)
(check-equal?: (mt (tagged txyz [x 1] [y "b"]))
#f)
(check-equal?: (mt (make))
'(macro "b" 1))
(check-not-equal?: (make) (txyz 1 "b"))
(check-equal?: (match (make)
((txyz x y) (list 'out y x))
(_ #f))
#f)
(check-equal?: (mt (txyz 1 "b"))
#f)]
@section{Conclusion}
@chunk[<*>
@ -444,6 +541,7 @@ number of name collisions.
define-variant
tagged
define-tagged
define-private-tagged
any-tagged)
<variant-supertype>
@ -457,6 +555,7 @@ number of name collisions.
<define-variant>
<tagged>
<define-tagged>
<define-uninterned-tagged>
(module+ test-helpers
(provide Tagged-value)))
@ -474,4 +573,5 @@ number of name collisions.
<test-constructor>
<test-define-variant>
<test-tagged>
<test-define-tagged>))]
<test-define-tagged>
<test-uninterned-tagged>))]

53
graph-lib/lib/low/syntax-parse.rkt
View File

@ -2,22 +2,25 @@
(require "typed-untyped.rkt")
(module m-stx-identifier racket
(require racket/stxparam)
(provide stx)
(define-syntax-parameter stx
(lambda (call-stx)
(raise-syntax-error
(syntax-e call-stx)
"Can only be used in define-syntax/parse or λ/syntax-parse"
call-stx))))
(require racket/stxparam)
(provide stx)
(define-syntax-parameter stx
(lambda (call-stx)
(raise-syntax-error
(syntax-e call-stx)
"Can only be used in define-syntax/parse or λ/syntax-parse"
call-stx))))
(define-typed/untyped-modules #:no-test
(provide stx
define-syntax/parse
λ/syntax-parse
~maybe
~maybe*
~optkw
~kw
~lit
~or-bug
define-simple-macro
@ -33,7 +36,7 @@
syntax/parse/experimental/template
(for-syntax racket/syntax
racket/stxparam)
(for-meta 2 racket/base)
(for-meta 2 racket/base racket/syntax)
racket/stxparam)
(define-syntax ~maybe
@ -44,6 +47,34 @@
(define (s stx) (datum->syntax #'self stx stx stx))
#`(#,(s #'~optional) (#,(s #'~seq) pat ...))]))))
(define-syntax ~maybe*
(pattern-expander
(λ (stx)
(syntax-parse stx
[(self name pat ...)
(define (s stx) (datum->syntax #'self stx stx stx))
#`(#,(s #'~and) name (#,(s #'~optional) (#,(s #'~seq) pat ...)))]))))
(define-syntax ~optkw
(pattern-expander
(λ (stx)
(syntax-parse stx
[(self kw:keyword)
(define (s stx) (datum->syntax #'self stx stx stx))
(define/with-syntax name
(format-id #'kw "~a" (keyword->string (syntax-e #'kw))))
#`(#,(s #'~optional) (#,(s #'~and) name kw))]))))
(define-syntax ~kw
(pattern-expander
(λ (stx)
(syntax-parse stx
[(self kw:keyword)
(define (s stx) (datum->syntax #'self stx stx stx))
(define/with-syntax name
(format-id #'kw "~a" (keyword->string (syntax-e #'kw))))
#`(#,(s #'~and) name kw)]))))
;; Circumvent the bug that causes "syntax-parse: duplicate attribute in: a" in
;; (syntax-parse #'(x y z) [((~or a (a b c)) ...) #'(a ...)])
(define-syntax ~or-bug