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

Totally wrong implementation of the xlist builder. Commited for historical purposes, there might be some reusable bits of code there.

Browse Source
This commit is contained in:
Georges Dupéron 2016-09-22 04:00:51 +02:00
parent 4862bdb42f
commit c3ee40168c
3 changed files with 272 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

261
main.rkt
View File

@ -11,22 +11,24 @@
racket/match racket/match
(only-in phc-toolkit/typed-untyped when-typed) (only-in phc-toolkit/typed-untyped when-typed)
(only-in syntax/parse ...+) (only-in syntax/parse ...+)
(for-syntax (for-syntax (rename-in racket/base
(rename-in racket/base [* mul]
[* mul] [+ plus]
[+ plus] [compose ∘]
[compose ∘] [... …])
[... …]) racket/syntax
racket/syntax racket/match
racket/match racket/contract
racket/contract racket/list
racket/list racket/function
racket/function racket/string
racket/string (rename-in syntax/parse
(rename-in syntax/parse [...+ …+])
[...+ …+]) syntax/parse/experimental/template
syntax/stx syntax/stx
type-expander/expander)) type-expander/expander)
(for-meta 2 racket/base)
(for-meta 2 syntax/parse))
(provide xlist ^ ∞) (provide xlist ^ ∞)
@ -34,6 +36,15 @@
(λ (stx) (raise-syntax-error 'stop "This is a private marker" stx))) (λ (stx) (raise-syntax-error 'stop "This is a private marker" stx)))
(begin-for-syntax (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 number/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]+)$")
(define */rx #px"^(.*?)⃰$") (define */rx #px"^(.*?)⃰$")
(define +/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]*)⁺$") (define +/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]*)⁺$")
@ -132,7 +143,7 @@
(pattern {~and base {~not {~or ^ + *}}})) (pattern {~and base {~not {~or ^ + *}}}))
(define-splicing-syntax-class fixed-repeat (define-splicing-syntax-class fixed-repeat
(pattern {~seq :base {~literal ^} power:number} (pattern {~seq :base {~literal ^} power:nat}
#:with (expanded …) (map (const #'base) #:with (expanded …) (map (const #'base)
(range (syntax-e #'power)))) (range (syntax-e #'power))))
(pattern {~literal stop} (pattern {~literal stop}
@ -142,9 +153,9 @@
(define-syntax-class repeat-spec (define-syntax-class repeat-spec
#:literals (* + - ∞) #:literals (* + - ∞)
(pattern (:number)) (pattern (:nat))
(pattern ({~optional :number} +)) (pattern ({~optional :nat} +))
(pattern ({~optional :number} - {~optional {~or ∞ :number}})) (pattern ({~optional :nat} - {~optional {~or ∞ :nat}}))
(pattern (*))) (pattern (*)))
#;(define-splicing-syntax-class xlist-*-element #;(define-splicing-syntax-class xlist-*-element
@ -157,52 +168,54 @@
(pattern :split-superscript-+-id) (pattern :split-superscript-+-id)
(pattern (~seq base :superscript-ish-+))) (pattern (~seq base :superscript-ish-+)))
(define (xlist-type context) (define ((xlist-type context) stx)
;; The order of clauses is important, as they otherwise overlap. ;; The order of clauses is important, as they otherwise overlap.
(syntax-parser (define xl
#:context context (syntax-parser
#:literals (^ * + - ∞ stop) #:context context
[() #:literals (^ * + - ∞ stop)
#'Null] [()
[rest:not-stx-list #'Null]
#'rest] [rest:not-stx-list
[(stop . rest) ;; eliminate the private marker #'rest]
#'(xlist . rest)] [(stop . rest) ;; eliminate the private marker
[(s:with-superscripts . rest) (xl #'rest)]
#'(xlist s.expanded … . rest)] [(s:with-superscripts . rest)
[(:base {~optional ^} *) (xl #'(s.expanded … . rest))]
#'(Listof base)] [(:base {~optional ^} *)
[(:base {~optional ^} * . rest) #'(Listof base)]
#:with R (gensym 'R) [(:base {~optional ^} * . rest)
#'(Rec R (U (Pairof base R) #:with R (gensym 'R)
(xlist . rest)))] #`(Rec R (U (Pairof base R)
[(:base {~optional ^} + . rest) #,(xl #'rest)))]
#'(xlist base ^ 1 + . rest)] [(:base {~optional ^} + . rest)
[(:base ^ power:nat + . rest) (xl #'(base ^ 1 + . rest))]
#'(xlist base ^ power stop base * . rest)] [(:base ^ power:nat + . rest)
[(:base ^ - . rest) (xl #'(base ^ power stop base * . rest))]
#'(xlist base ^ 0 - . rest)] [(:base ^ - . rest)
[(:base ^ from:nat - ∞ . rest) (xl #'(base ^ 0 - . rest))]
#'(xlist base ^ from + . rest)] [(:base ^ from:nat - ∞ . rest)
[(:base ^ 0 - to:nat . rest) (xl #'(base ^ from + . rest))]
#`(U . #,(foldl (λ (iteration u*) [(:base ^ 0 - to:nat . rest)
(syntax-case u* () #`(U . #,(foldl (λ (iteration u*)
[[(_ . base…rest) . _] (syntax-case u* ()
#`[(xlist base . base…rest) . #,u*]])) [[(_ . base…rest) . _]
#'[(xlist . rest)] #`[(List* base . base…rest) . #,u*]]))
(range (syntax-e #'to))))] #`[(List* #,(xl #'rest))]
[(:base ^ from:nat - to:nat . rest) (range (syntax-e #'to))))]
#:with difference (- (syntax-e #'to) (syntax-e #'from)) [(:base ^ from:nat - to:nat . rest)
(when (< (syntax-e #'difference) 0) #:with difference (- (syntax-e #'to) (syntax-e #'from))
(raise-syntax-error 'xlist (when (< (syntax-e #'difference) 0)
"invalid range: m is larger than n" (raise-syntax-error 'xlist
#'-)) "invalid range: m is larger than n"
#`(xlist base ^ from stop base ^ 0 - difference . rest)] #'-))
[(:base ^ from:nat - . rest) (xl #'(base ^ from stop base ^ 0 - difference . rest))]
;; "-" is not followed by a number, nor by ∞, so default to ∞. [(:base ^ from:nat - . rest)
#`(xlist base ^ from - ∞ . rest)] ;; "-" is not followed by a number, nor by ∞, so default to ∞.
[(e:fixed-repeat . rest) (xl #'(base ^ from - ∞ . rest))]
#'(List* e.expanded … (xlist . rest))])) [(e:fixed-repeat . rest)
#`(List* e.expanded … #,(xl #'rest))]))
(xl stx))
@ -267,11 +280,118 @@
#`(list-rest-ish [] base ellipsis #,(xl #'rest))] #`(list-rest-ish [] base ellipsis #,(xl #'rest))]
[(e:fixed-repeat . rest) [(e:fixed-repeat . rest)
#`(list-rest-ish [] e.expanded … #,(xl #'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 (define-multi-id xlist
#:type-expander (λ (stx) ((xlist-type stx) (stx-cdr stx))) #: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 (define-match-expander list-rest-ish
(syntax-parser (syntax-parser
@ -288,6 +408,9 @@
c₁ …)])) c₁ …)]))
(when-typed (when-typed
(provide xList) (provide xList #;xListBuilder)
(define-type-expander (xList stx) (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)))))

72
scribblings/xlist.scrbl
View File

@ -41,10 +41,11 @@ To use the type expander, you must first require the
(code:line number +) (code:line number +)
(code:line +) (code:line +)
(code:line number - number) (code:line number - number)
(code:line number -)
(code:line number - ∞) (code:line number - ∞)
(code:line number -)
(code:line - number) (code:line - number)
(code:line -) (code:line -)
(code:line - ∞)
(code:line *))]]]]{ (code:line *))]]]]{
The notation @racket[type ^ _n], where @racket[_n] is a number, indicates that 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, 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 number +)
(code:line +) (code:line +)
(code:line number - number) (code:line number - number)
(code:line number -)
(code:line number - ∞) (code:line number - ∞)
(code:line number -)
(code:line - number) (code:line - number)
(code:line - ∞)
(code:line -) (code:line -)
(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 @racketmodname[typed/racket] (rest values and spliced lists are the most likely
to cause problems).} 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{xlist-untyped.scrbl}
@include-section{identifiers.scrbl} @include-section{identifiers.scrbl}

10
test/test-type.rkt
View File

@ -111,6 +111,16 @@
(ann '(1 1 1) (xlist Number ^ 3 +)) (ann '(1 1 1) (xlist Number ^ 3 +))
(void)) (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 (test-begin
"(xlist Number ^ x - y)" "(xlist Number ^ x - y)"
(ann '() (xlist Number ^ -)) (ann '() (xlist Number ^ -))