commit c3ee40168cc8c2e598306cf2fab3aa54d0bb245a
parent 4862bdb42f6b5294524b0fe6b59d59effab8fe19
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 22 Sep 2016 04:00:51 +0200
Totally wrong implementation of the xlist builder. Commited for historical purposes, there might be some reusable bits of code there.
Diffstat:
3 files changed, 272 insertions(+), 71 deletions(-)
diff --git a/main.rkt b/main.rkt
@@ -11,22 +11,24 @@
racket/match
(only-in phc-toolkit/typed-untyped when-typed)
(only-in syntax/parse ...+)
- (for-syntax
- (rename-in racket/base
- [* mul]
- [+ plus]
- [compose ∘]
- [... …])
- racket/syntax
- racket/match
- racket/contract
- racket/list
- racket/function
- racket/string
- (rename-in syntax/parse
- [...+ …+])
- syntax/stx
- type-expander/expander))
+ (for-syntax (rename-in racket/base
+ [* mul]
+ [+ plus]
+ [compose ∘]
+ [... …])
+ racket/syntax
+ racket/match
+ racket/contract
+ racket/list
+ racket/function
+ racket/string
+ (rename-in syntax/parse
+ [...+ …+])
+ syntax/parse/experimental/template
+ syntax/stx
+ type-expander/expander)
+ (for-meta 2 racket/base)
+ (for-meta 2 syntax/parse))
(provide xlist ^ ∞)
@@ -34,6 +36,15 @@
(λ (stx) (raise-syntax-error 'stop "This is a private marker" stx)))
(begin-for-syntax
+ (define-syntax ~^
+ (pattern-expander
+ (λ (stx)
+ (syntax-case stx ()
+ [(_ pat ...)
+ #`{~or {~seq #,(syntax-local-introduce #'^) pat ...}
+ {~seq {~optional #,(syntax-local-introduce #'^)}
+ (pat ...)}}]))))
+
(define number/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]+)$")
(define */rx #px"^(.*?)⃰$")
(define +/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]*)⁺$")
@@ -132,7 +143,7 @@
(pattern {~and base {~not {~or ^ + *}}}))
(define-splicing-syntax-class fixed-repeat
- (pattern {~seq :base {~literal ^} power:number}
+ (pattern {~seq :base {~literal ^} power:nat}
#:with (expanded …) (map (const #'base)
(range (syntax-e #'power))))
(pattern {~literal stop}
@@ -142,9 +153,9 @@
(define-syntax-class repeat-spec
#:literals (* + - ∞)
- (pattern (:number))
- (pattern ({~optional :number} +))
- (pattern ({~optional :number} - {~optional {~or ∞ :number}}))
+ (pattern (:nat))
+ (pattern ({~optional :nat} +))
+ (pattern ({~optional :nat} - {~optional {~or ∞ :nat}}))
(pattern (*)))
#;(define-splicing-syntax-class xlist-*-element
@@ -157,52 +168,54 @@
(pattern :split-superscript-+-id)
(pattern (~seq base :superscript-ish-+)))
- (define (xlist-type context)
+ (define ((xlist-type context) stx)
;; The order of clauses is important, as they otherwise overlap.
- (syntax-parser
- #:context context
- #:literals (^ * + - ∞ stop)
- [()
- #'Null]
- [rest:not-stx-list
- #'rest]
- [(stop . rest) ;; eliminate the private marker
- #'(xlist . rest)]
- [(s:with-superscripts . rest)
- #'(xlist s.expanded … . rest)]
- [(:base {~optional ^} *)
- #'(Listof base)]
- [(:base {~optional ^} * . rest)
- #:with R (gensym 'R)
- #'(Rec R (U (Pairof base R)
- (xlist . rest)))]
- [(:base {~optional ^} + . rest)
- #'(xlist base ^ 1 + . rest)]
- [(:base ^ power:nat + . rest)
- #'(xlist base ^ power stop base * . rest)]
- [(:base ^ - . rest)
- #'(xlist base ^ 0 - . rest)]
- [(:base ^ from:nat - ∞ . rest)
- #'(xlist base ^ from + . rest)]
- [(:base ^ 0 - to:nat . rest)
- #`(U . #,(foldl (λ (iteration u*)
- (syntax-case u* ()
- [[(_ . base…rest) . _]
- #`[(xlist base . base…rest) . #,u*]]))
- #'[(xlist . rest)]
- (range (syntax-e #'to))))]
- [(:base ^ from:nat - to:nat . rest)
- #:with difference (- (syntax-e #'to) (syntax-e #'from))
- (when (< (syntax-e #'difference) 0)
- (raise-syntax-error 'xlist
- "invalid range: m is larger than n"
- #'-))
- #`(xlist base ^ from stop base ^ 0 - difference . rest)]
- [(:base ^ from:nat - . rest)
- ;; "-" is not followed by a number, nor by ∞, so default to ∞.
- #`(xlist base ^ from - ∞ . rest)]
- [(e:fixed-repeat . rest)
- #'(List* e.expanded … (xlist . rest))]))
+ (define xl
+ (syntax-parser
+ #:context context
+ #:literals (^ * + - ∞ stop)
+ [()
+ #'Null]
+ [rest:not-stx-list
+ #'rest]
+ [(stop . rest) ;; eliminate the private marker
+ (xl #'rest)]
+ [(s:with-superscripts . rest)
+ (xl #'(s.expanded … . rest))]
+ [(:base {~optional ^} *)
+ #'(Listof base)]
+ [(:base {~optional ^} * . rest)
+ #:with R (gensym 'R)
+ #`(Rec R (U (Pairof base R)
+ #,(xl #'rest)))]
+ [(:base {~optional ^} + . rest)
+ (xl #'(base ^ 1 + . rest))]
+ [(:base ^ power:nat + . rest)
+ (xl #'(base ^ power stop base * . rest))]
+ [(:base ^ - . rest)
+ (xl #'(base ^ 0 - . rest))]
+ [(:base ^ from:nat - ∞ . rest)
+ (xl #'(base ^ from + . rest))]
+ [(:base ^ 0 - to:nat . rest)
+ #`(U . #,(foldl (λ (iteration u*)
+ (syntax-case u* ()
+ [[(_ . base…rest) . _]
+ #`[(List* base . base…rest) . #,u*]]))
+ #`[(List* #,(xl #'rest))]
+ (range (syntax-e #'to))))]
+ [(:base ^ from:nat - to:nat . rest)
+ #:with difference (- (syntax-e #'to) (syntax-e #'from))
+ (when (< (syntax-e #'difference) 0)
+ (raise-syntax-error 'xlist
+ "invalid range: m is larger than n"
+ #'-))
+ (xl #'(base ^ from stop base ^ 0 - difference . rest))]
+ [(:base ^ from:nat - . rest)
+ ;; "-" is not followed by a number, nor by ∞, so default to ∞.
+ (xl #'(base ^ from - ∞ . rest))]
+ [(e:fixed-repeat . rest)
+ #`(List* e.expanded … #,(xl #'rest))]))
+ (xl stx))
@@ -267,11 +280,118 @@
#`(list-rest-ish [] base ellipsis #,(xl #'rest))]
[(e:fixed-repeat . rest)
#`(list-rest-ish [] e.expanded … #,(xl #'rest))]))
- (xl stx)))
+ (xl stx))
+
+ #;("This is completely wrong"
+ ;; Expands 0 or more mandatory-doms for ->*
+ (define-splicing-syntax-class fixed-repeated-type
+ #:attributes ([mandatory 1])
+ #:literals (^ * + - ∞ stop)
+ (pattern {~seq :base {~^ power:nat}}
+ #:with (mandatory …) (map (const #'base)
+ (range (syntax-e #'power))))
+ (pattern {~seq :base {~^ from:nat - to:nat}}
+ #:when (= (syntax-e #'from) (syntax-e #'to))
+ #:with (mandatory …) (map (const #'base)
+ (range (syntax-e #'from))))
+ (pattern s:with-superscripts
+ #:with (:fixed-repeated-type) #'(s.expanded …))
+ (pattern (~seq {~peek-not :mandatory-bounded-variadic-repeated-type}
+ {~peek-not :optional-bounded-variadic-repeated-type}
+ {~peek-not :mandatory-variadic-repeated-type}
+ {~peek-not :optional-variadic-repeated-type}
+ :base)
+ #:with (mandatory …) #'(base)))
+
+ ;; Expands to 0 or more mandatory-doms and 0 or more optional-doms
+ ;; for ->*
+ (define-splicing-syntax-class mandatory-bounded-variadic-repeated-type
+ #:attributes ([mandatory 1] [optional 1])
+ #:literals (^ * + - ∞ stop)
+ (pattern {~seq :base {~^ {~and from:nat {~not 0}} - to:nat}}
+ #:with (mandatory …) (map (const #'base)
+ (range (syntax-e #'from)))
+ #:with (optional …) (map (const #'base)
+ (range (- (syntax-e #'to)
+ (syntax-e #'from)))))
+ (pattern s:with-superscripts
+ #:with (:mandatory-bounded-variadic-repeated-type)
+ #'(s.expanded …)))
+
+ ;; Expands to 1 or more optional-doms for ->*
+ (define-splicing-syntax-class optional-bounded-variadic-repeated-type
+ #:attributes ([optional 1])
+ #:literals (^ * + - ∞ stop)
+ (pattern {~seq :base {~^ {~optional 0} - to:nat}}
+ #:with (optional …) (map (const #'base)
+ (range (syntax-e #'to))))
+ (pattern s:with-superscripts
+ #:with (:optional-bounded-variadic-repeated-type)
+ #'(s.expanded …)))
+
+ ;; Expands to 0 or more mandatory-doms for ->* and possibly a rest clause
+ (define-splicing-syntax-class mandatory-variadic-repeated-type
+ #:attributes ([mandatory 1] [rest-clause 1])
+ (pattern {~seq :base {~^ from:nat +}}
+ #:with (mandatory …) (map (const #'base)
+ (range (syntax-e #'from)))
+ #:with (rest-clause …) #'(#:rest base))
+ (pattern {~seq :base {~or + {~^ +}}}
+ #:with (:mandatory-variadic-repeated-type) #'(base ^ 1 +))
+ (pattern {~seq :base {~^ from:nat - {~optional ∞}}}
+ #:with (:mandatory-variadic-repeated-type) #'(base ^ from +))
+ (pattern s:with-superscripts
+ #:with (:mandatory-variadic-repeated-type)
+ #'(s.expanded …)))
+
+ ;; Expands to a #:rest clause for ->*
+ (define-splicing-syntax-class optional-variadic-repeated-type
+ #:attributes ([rest-clause 1])
+ #:literals (^ * + - ∞ stop)
+ (pattern {~or {~seq :base {~^ {~optional 0} - {~optional ∞}}}
+ {~seq :base {~^ *}}
+ {~seq :base *}}
+ #:with (rest-clause …) #'(#:rest base))
+ (pattern s:with-superscripts
+ #:with (:optional-variadic-repeated-type)
+ #'(s.expanded …)))
+
+ (define ((xlist-builder-type context) stx)
+ ;; The order of clauses is important, as they otherwise overlap.
+ (syntax-parse stx
+ #:context context
+ #:literals (^ * + - ∞ stop)
+ [(τᵢ:fixed-repeated-type
+ …
+ (~or (~seq τₘᵥ:mandatory-variadic-repeated-type)
+ (~seq {~optional τⱼ:mandatory-bounded-variadic-repeated-type}
+ τₖ:optional-bounded-variadic-repeated-type
+ …
+ {~optional τₙ:optional-variadic-repeated-type})))
+ #:with range ((xlist-type context) stx)
+ (template (->*
+ ;; mandatory
+ (τᵢ.mandatory
+ … …
+ {?? {?@ τₘᵥ.mandatory …}}
+ {?? {?@ τⱼ.mandatory …}})
+ ;; optional
+ ({?? {?@ τⱼ.optional …}}
+ τₖ.optional … …)
+ ;; #:rest
+ {?? {?@ τₘᵥ.rest-clause …}}
+ {?? {?@ τₙ.rest-clause …}}
+ ;; range
+ range))]))
+
+ (define ((xlist-builder context) stx)
+ #`(cast list
+ #,((xlist-builder-type context) stx)))))
(define-multi-id xlist
#:type-expander (λ (stx) ((xlist-type stx) (stx-cdr stx)))
- #:match-expander (λ (stx) ((xlist-match stx) (stx-cdr stx))))
+ #:match-expander (λ (stx) ((xlist-match stx) (stx-cdr stx)))
+ #;{#:call (λ (stx) ((xlist-builder stx) (stx-cdr stx)))})
(define-match-expander list-rest-ish
(syntax-parser
@@ -288,6 +408,9 @@
c₁ …)]))
(when-typed
- (provide xList)
+ (provide xList #;xListBuilder)
(define-type-expander (xList stx)
- ((xlist-type stx) (stx-cdr stx)))))
+ ((xlist-type stx) (stx-cdr stx)))
+
+ #;(define-type-expander (xListBuilder stx)
+ ((xlist-builder-type stx) (stx-cdr stx)))))
diff --git a/scribblings/xlist.scrbl b/scribblings/xlist.scrbl
@@ -41,10 +41,11 @@ To use the type expander, you must first require the
(code:line number +)
(code:line +)
(code:line number - number)
- (code:line number -)
(code:line number - ∞)
+ (code:line number -)
(code:line - number)
(code:line -)
+ (code:line - ∞)
(code:line *))]]]]{
The notation @racket[type ^ _n], where @racket[_n] is a number, indicates that
the given type should be repeated @racket[_n] times within the list. Therefore,
@@ -147,9 +148,10 @@ To use the type expander, you must first require the
(code:line number +)
(code:line +)
(code:line number - number)
- (code:line number -)
(code:line number - ∞)
+ (code:line number -)
(code:line - number)
+ (code:line - ∞)
(code:line -)
(code:line *)
(code:line ...)
@@ -197,5 +199,71 @@ To use the type expander, you must first require the
@racketmodname[typed/racket] (rest values and spliced lists are the most likely
to cause problems).}
+@;{This is completely wrong.
+ @defform*[#:link-target? #f
+ #:literals (^ *)
+ [(xlist τᵢ … maybe-τⱼ τₖ … maybe-τₙ)
+ (xlist τᵢ … τₘᵥ)]
+ #:grammar
+ [(τᵢ type
+ fixed-repeated-type)
+ (τₘᵥ mandatory-variadic-repeated-type)
+ (maybe-τⱼ (code:line)
+ mandatory-bounded-variadic-repeated-type)
+ (τₖ optional-bounded-variadic-repeated-type)
+ (maybe-τₙ (code:line)
+ optional-variadic-repeated-type)
+ (fixed-repeated-type
+ (code:line type ^ fixed-repeat)
+ (code:line type ^ {fixed-repeat})
+ (code:line type {fixed-repeat})
+ (code:line type superscripted-fixed-repeat)
+ (code:line superscripted-fixed-id))
+ (mandatory-bounded-variadic-repeated-type
+ (code:line type ^ mandatory-bounded-variadic-repeat)
+ (code:line type ^ {mandatory-bounded-variadic-repeat})
+ (code:line type {mandatory-bounded-variadic-repeat})
+ (code:line type superscripted-mandatory-bounded-variadic-repeat)
+ (code:line superscripted-mandatory-bounded-variadic-id))
+ (optional-bounded-variadic-repeated-type
+ (code:line type ^ optional-bounded-variadic-repeat)
+ (code:line type ^ {optional-bounded-variadic-repeat})
+ (code:line type {optional-bounded-variadic-repeat})
+ (code:line type superscripted-optional-bounded-variadic-repeat)
+ (code:line superscripted-optional-bounded-variadic-id))
+ (mandatory-variadic-repeated-type
+ (code:line type ^ mandatory-variadic-repeat)
+ (code:line type ^ {mandatory-variadic-repeat})
+ (code:line type {mandatory-variadic-repeat})
+ (code:line type superscripted-mandatory-variadic-repeat)
+ (code:line superscripted-mandatory-variadic-id)
+ (code:line type +))
+ (optional-variadic-repeated-type
+ (code:line type ^ optional-variadic-repeat)
+ (code:line type ^ {optional-variadic-repeat})
+ (code:line type {optional-variadic-repeat})
+ (code:line type superscripted-optional-variadic-repeat)
+ (code:line superscripted-optional-variadic-id)
+ (code:line type *))
+ (fixed-repeat (code:line number)
+ (code:line from - to (code:comment "from = to")))
+ (mandatory-bounded-variadic-repeat (code:line number - number))
+ (optional-bounded-variadic-repeat (code:line 0 - number)
+ (code:line - number))
+ (mandatory-variadic-repeat (code:line number +)
+ (code:line +)
+ (code:line number -)
+ (code:line number - ∞))
+ (optional-variadic-repeat (code:line 0 - ∞)
+ (code:line 0 -)
+ (code:line - ∞)
+ (code:line -)
+ (code:line *))]]{
+
+ Macro form which returns a builder function for a list with the given type.
+ The simplified syntax compared to @racket[xList] is due to the fact that there
+ are some function types that Typed/Racket cannot express (yet).}
+}
+
@include-section{xlist-untyped.scrbl}
@include-section{identifiers.scrbl}
\ No newline at end of file
diff --git a/test/test-type.rkt b/test/test-type.rkt
@@ -112,6 +112,16 @@
(void))
(test-begin
+ "(xlist Number ^ x)"
+ (ann '() (xlist Number ^ 0))
+ (ann '(1) (xlist Number ^ 1))
+ (ann '(1 1) (xlist Number ^ 2))
+ (ann '(1 1 1) (xlist Number ^ 3))
+ (ann '(1 1 1 1) (xlist Number ^ 4))
+ (ann '(1 1 1 1 1) (xlist Number ^ 5))
+ (void))
+
+(test-begin
"(xlist Number ^ x - y)"
(ann '() (xlist Number ^ -))
(ann '(1 1 1) (xlist Number ^ -))
