Totally wrong implementation of the xlist builder. Commited for historical purposes, there might be some reusable bits of code there.
This commit is contained in:
Georges Dupéron
parent
4862bdb42f
commit
c3ee40168c
261
main.rkt
261
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)))))
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
|
@ -111,6 +111,16 @@
|
|||
(ann '(1 1 1) (xlist Number ^ 3 +))
|
||||
(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 ^ -))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user