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

Partially reverted the last two commits, identifiers bound by list-rest and list are available in later patterns with match, I do not know what went wrong previously.

Browse Source
This commit is contained in:
Georges Dupéron 2016-09-25 09:58:20 +02:00
parent 03e284cde1
commit cd704f574f
3 changed files with 81 additions and 118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

192
main.rkt
View File

@ -10,7 +10,7 @@
"between.rkt" "between.rkt"
match-string match-string
racket/match racket/match
(only-in phc-toolkit/typed-untyped if-typed when-typed) (only-in phc-toolkit/typed-untyped when-typed)
(only-in syntax/parse ...+) (only-in syntax/parse ...+)
(for-syntax (rename-in racket/base (for-syntax (rename-in racket/base
[* mul] [* mul]
@ -35,9 +35,6 @@
(provide xlist ^ ∞ (for-syntax normalize-xlist-type)) (provide xlist ^ ∞ (for-syntax normalize-xlist-type))
(define-syntax stop
(λ (stx) (raise-syntax-error 'stop "This is a private marker" stx)))
(begin-for-syntax (begin-for-syntax
(define-syntax ~^ (define-syntax ~^
(pattern-expander (pattern-expander
@ -52,7 +49,14 @@
(define */rx #px"^(.*?)⃰$") (define */rx #px"^(.*?)⃰$")
(define +/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]*)⁺$") (define +/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]*)⁺$")
(define -/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]*)⁻([⁰¹²³⁴⁵⁶⁷⁸⁹]*)$") (define -/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]*)⁻([⁰¹²³⁴⁵⁶⁷⁸⁹]*)$")
(define (regexp-match/c rx)
(and/c string? (λ (s) (regexp-match? rx s))))
(define (id/c id)
(and/c identifier? (λ (i) (free-identifier=? i id))))
(define string-superscript-number/c (regexp-match/c number/rx)) (define string-superscript-number/c (regexp-match/c number/rx))
(define string-superscript-*/c (regexp-match/c */rx)) (define string-superscript-*/c (regexp-match/c */rx))
(define string-superscript-+/c (regexp-match/c +/rx)) (define string-superscript-+/c (regexp-match/c +/rx))
@ -139,11 +143,9 @@
(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:nat} (pattern {~seq :base {~^ power:nat}}
#:with (expanded …) (map (const #'base) #:with (expanded …) (map (const #'base)
(range (syntax-e #'power)))) (range (syntax-e #'power))))
(pattern {~literal stop}
#:with (expanded …) #'())
(pattern e:base (pattern e:base
#:with (expanded …) #'(e))) #:with (expanded …) #'(e)))
@ -169,15 +171,13 @@
(define xl (define xl
(syntax-parser (syntax-parser
#:context context #:context context
#:literals (^ * + - ∞ stop) #:literals (^ * + - ∞)
[() [()
#'Null] #'Null]
[rest:not-stx-pair [rest:not-stx-pair
#'rest] #'rest]
[(#:rest rest) [(#:rest rest)
#'rest] #'rest]
[(stop . rest) ;; eliminate the private marker
(xl #'rest)]
[(s:with-superscripts . rest) [(s:with-superscripts . rest)
(xl #'(s.expanded … . rest))] (xl #'(s.expanded … . rest))]
[(:base {~or * {~^ *}}) [(:base {~or * {~^ *}})
@ -189,9 +189,11 @@
[(:base {~or + {~^ +}} . rest) [(:base {~or + {~^ +}} . rest)
(xl #'(base ^ 1 + . rest))] (xl #'(base ^ 1 + . rest))]
[(:base {~^ power:nat +} . rest) [(:base {~^ power:nat +} . rest)
(xl #'(base ^ power stop base * . rest))] (xl #'(base ^ {power} base * . rest))]
[(:base {~^ -} . rest) ;; TODO: if there was ^ {-}, then it should keep the braces because the next thing may be a number [(:base {~optional ^} {-} . rest) ;; If it is ^ {-}, the next thing may be a number but should be used as a pattern, not a repeat
(xl #'(base {~^ 0 -} . rest))] (xl #'(base ^ * . rest))]
[(:base ^ - . rest) ;; not with {}, check if there's stuff after
(xl #'(base ^ 0 - . rest))]
[(:base {~^ from:nat - ∞} . rest) [(:base {~^ from:nat - ∞} . rest)
(xl #'(base ^ from + . rest))] (xl #'(base ^ from + . rest))]
[(:base {~^ 0 - to:nat} . rest) [(:base {~^ 0 - to:nat} . rest)
@ -207,7 +209,7 @@
(raise-syntax-error 'xlist (raise-syntax-error 'xlist
"invalid range: m is larger than n" "invalid range: m is larger than n"
#'-)) #'-))
(xl #'(base ^ from stop base ^ 0 - difference . rest))] (xl #'(base ^ {from} base ^ 0 - difference . rest))]
[(:base {~^ from:nat -} . rest) [(:base {~^ from:nat -} . rest)
;; "-" is not followed by a number, nor by ∞, so default to ∞. ;; "-" is not followed by a number, nor by ∞, so default to ∞.
(xl #'(base ^ from - ∞ . rest))] (xl #'(base ^ from - ∞ . rest))]
@ -278,68 +280,69 @@
#:context context #:context context
#:literals (^ * + - ∞) #:literals (^ * + - ∞)
[() [()
#'(#:proper-list)] #'(list)]
[rest:not-stx-pair [rest:not-stx-pair
#'(#:rest rest)] #'rest]
[(#:rest ((~literal ?) (~literal null?)))
#'(#:proper-list)]
[(#:rest rest) [(#:rest rest)
#'(#:rest rest)] #'rest]
[(({~literal unquote-splicing} splice) …+ . rest) [(({~literal unquote-splicing} splice) …+ . rest)
#`(#:rest (append splice … #,(xl #'rest)))] #`(append splice … #,(xl #'rest))]
[(s:with-superscripts . rest) [(s:with-superscripts . rest)
(xl #'(s.expanded … . rest))] (xl #'(s.expanded … . rest))]
[(:base {~optional ^} * . rest) [(:base {~or * {~^ *}} . rest)
#:with R (gensym 'R) #:with R (gensym 'R)
#`([[] base ooo] . #,(xl #'rest))] #`(list-rest-ish [] base ooo #,(xl #'rest))]
[(:base {~optional ^} + . rest) [(:base {~or + {~^ +}} . rest)
(xl #'(base ^ 1 + . rest))] (xl #'(base ^ 1 + . rest))]
[(:base ^ power:nat + . rest) [(:base {~^ power:nat +} . rest)
#:with ..power (format-id #'power "..~a" (syntax-e #'power)) #:with ..power (format-id #'power "..~a" (syntax-e #'power))
#`([[] base ..power] . #,(xl #'rest))] #`(list-rest-ish [] base ..power #,(xl #'rest))]
[(:base ^ - . rest) [(:base {~optional ^} {-} . rest) ;; If it is ^ {-}, the next thing may be a number but should be used as a pattern, not a repeat
(xl #'(base ^ {*} . rest))]
[(:base ^ - . rest) ;; not with {}, check if there's stuff after
(xl #'(base ^ 0 - . rest))] (xl #'(base ^ 0 - . rest))]
[(:base ^ from:nat - ∞ . rest) [(:base {~^ from:nat - ∞} . rest)
(xl #'(base ^ from + . rest))] (xl #'(base ^ {from +} . rest))]
[(:base ^ from:nat - to:nat . rest) [(:base {~^ from:nat - to:nat} . rest)
#:with occurrences (gensym 'occurrences)
(when (> (syntax-e #'from) (syntax-e #'to)) (when (> (syntax-e #'from) (syntax-e #'to))
(raise-syntax-error 'xlist (raise-syntax-error 'xlist
"invalid range: m is larger than n" "invalid range: m is larger than n"
#'-)) #'-))
(define/with-syntax occurrences (gensym 'occurrences)) #`(list-rest-ish
#`([[((between/c from to) (length occurrences))] [(? (λ (_) ((between/c from to) (length occurrences))))]
(and occurrences base) (and occurrences base) ooo
ooo] #,(xl #'rest))]
. #,(xl #'rest))] [(:base {~^ from:nat -} . rest)
[(:base ^ from:nat - . rest)
;; "-" is not followed by a number, nor by ∞, so default to ∞. ;; "-" is not followed by a number, nor by ∞, so default to ∞.
(xl #'(base ^ from - ∞ . rest))] (xl #'(base ^ {from - ∞} . rest))]
;; aliases ;; aliases
[(:base {~or {~literal ...} {~literal ___}} . rest) [(:base {~or {~literal ...} {~literal ___}
#`([[] base ooo] . #,(xl #'rest))] {~^ {~literal ...}} {~^ {~literal ___}}}
[(:base {~literal ...+} . rest) . rest)
#`([[] base ..1] . #,(xl #'rest))] #`(list-rest-ish [] base ooo #,(xl #'rest))]
[(:base ellipsis:id . rest) [(:base {~or {~literal ...+} {~^ {~literal ...+}}} . rest)
#`(list-rest-ish base ..1 #,(xl #'rest))]
[(:base {~or ellipsis:id {~^ ellipsis:id}} . rest)
#:when (regexp-match? #px"^\\.\\.[0-9]+$" #:when (regexp-match? #px"^\\.\\.[0-9]+$"
(symbol->string (syntax-e #'ellipsis))) (symbol->string (syntax-e #'ellipsis)))
#`([[] base ellipsis] . #,(xl #'rest))] #`(list-rest-ish [] base ellipsis #,(xl #'rest))]
[(:base {~^ 1}) [(:base {~^ 1})
#`([[] base #|no ellipsis|#] . #,(xl #'rest))] #`(list-rest-ish [] base #|no ellipsis|# . #,(xl #'rest))]
[(:base {~^ power:nat}) [(:base {~^ power:nat})
(define/with-syntax occurrences (gensym 'occurrences)) #:with occurrences (gensym 'occurrences)
#`([[(= (length occurrences) power)] #`(list-rest-ish [(? (λ (_) (= (length occurrences) power)))]
(and occurrences base) ooo] (and occurrences base) ooo
. #,(xl #'rest))] #,(xl #'rest))]
[(:base . rest) [(:base . rest)
#`([[] base #|no ellipsis|#] . #,(xl #'rest))])) #`(list-rest-ish [] base #|no ellipsis|# #,(xl #'rest))]))
((λ (x) (pretty-write (syntax->datum x)) x) (xl stx))
#`(list-rest-ish . #,(xl stx))))
#;("This is completely wrong" #;("This is completely wrong"
;; Expands 0 or more mandatory-doms for ->* ;; Expands 0 or more mandatory-doms for ->*
(define-splicing-syntax-class fixed-repeated-type (define-splicing-syntax-class fixed-repeated-type
#:attributes ([mandatory 1]) #:attributes ([mandatory 1])
#:literals (^ * + - ∞ stop) #:literals (^ * + - ∞)
(pattern {~seq :base {~^ power:nat}} (pattern {~seq :base {~^ power:nat}}
#:with (mandatory …) (map (const #'base) #:with (mandatory …) (map (const #'base)
(range (syntax-e #'power)))) (range (syntax-e #'power))))
@ -360,7 +363,7 @@
;; for ->* ;; for ->*
(define-splicing-syntax-class mandatory-bounded-variadic-repeated-type (define-splicing-syntax-class mandatory-bounded-variadic-repeated-type
#:attributes ([mandatory 1] [optional 1]) #:attributes ([mandatory 1] [optional 1])
#:literals (^ * + - ∞ stop) #:literals (^ * + - ∞)
(pattern {~seq :base {~^ {~and from:nat {~not 0}} - to:nat}} (pattern {~seq :base {~^ {~and from:nat {~not 0}} - to:nat}}
#:with (mandatory …) (map (const #'base) #:with (mandatory …) (map (const #'base)
(range (syntax-e #'from))) (range (syntax-e #'from)))
@ -374,7 +377,7 @@
;; Expands to 1 or more optional-doms for ->* ;; Expands to 1 or more optional-doms for ->*
(define-splicing-syntax-class optional-bounded-variadic-repeated-type (define-splicing-syntax-class optional-bounded-variadic-repeated-type
#:attributes ([optional 1]) #:attributes ([optional 1])
#:literals (^ * + - ∞ stop) #:literals (^ * + - ∞)
(pattern {~seq :base {~^ {~optional 0} - to:nat}} (pattern {~seq :base {~^ {~optional 0} - to:nat}}
#:with (optional …) (map (const #'base) #:with (optional …) (map (const #'base)
(range (syntax-e #'to)))) (range (syntax-e #'to))))
@ -400,7 +403,7 @@
;; Expands to a #:rest clause for ->* ;; Expands to a #:rest clause for ->*
(define-splicing-syntax-class optional-variadic-repeated-type (define-splicing-syntax-class optional-variadic-repeated-type
#:attributes ([rest-clause 1]) #:attributes ([rest-clause 1])
#:literals (^ * + - ∞ stop) #:literals (^ * + - ∞)
(pattern {~or {~seq :base {~^ {~optional 0} - {~optional ∞}}} (pattern {~or {~seq :base {~^ {~optional 0} - {~optional ∞}}}
{~seq :base {~^ *}} {~seq :base {~^ *}}
{~seq :base *}} {~seq :base *}}
@ -413,7 +416,7 @@
;; The order of clauses is important, as they otherwise overlap. ;; The order of clauses is important, as they otherwise overlap.
(syntax-parse stx (syntax-parse stx
#:context context #:context context
#:literals (^ * + - ∞ stop) #:literals (^ * + - ∞)
[(τᵢ:fixed-repeated-type [(τᵢ:fixed-repeated-type
… …
(~or (~seq τₘᵥ:mandatory-variadic-repeated-type) (~or (~seq τₘᵥ:mandatory-variadic-repeated-type)
@ -446,67 +449,22 @@
#: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)))}) #;{#:call (λ (stx) ((xlist-builder stx) (stx-cdr stx)))})
(if-typed (define-match-expander list-rest-ish
(begin (λ (stx)
;(require "split-list.rkt") ((λ (x) (pretty-write (syntax->datum x)) x)
(define-match-expander list-rest-ish ((syntax-parser
(λ (stx) #:literals (list list-rest-ish)
((λ (x) (pretty-write (syntax->datum x)) x) #:datum-literals (list-rest)
((syntax-parser [(_ [c₁ …] e₁ … (list-rest-ish [c₂ …] e₂ … r))
#:literals (list list-rest-ish) #'(list-rest-ish [c₁ … c₂ …] e₁ … e₂ … r)]
;#:datum-literals (list-rest) [(_ [c₁ …] e₁ … (list-rest e₂ … r))
;[(_ [c₁ …] e₁ … (list-rest e₂ … r)) #'(list-rest-ish [c₁ …] e₁ … e₂ … r)]
; #'(list-rest-ish [c₁ …] e₁ … e₂ … r)] [(_ [c₁ …] e₁ … (list e₂ …))
;[(_ [c₁ …] e₁ … (list e₂ …)) #'(and (list e₁ … e₂ …) c₁ …)]
; #'(list-rest-ish [c₁ …] e₁ … e₂ …)] [(_ [c₁ …] e₁ … r)
[(_ [[c₁ …] e₁ ooo₁ …] … #:proper-list) #'(and (list-rest e₁ … r)
#:with whole (gensym 'whole) c₁ …)])
#'TODO stx))))
#;#'(? (λ (whole)
(match whole
[(list e₁ … e₂ …) (and c₁ …)])))
#;#'(and (list e₁ … e₂ …) c₁ …)]
[(_ [[c₁ …] e₁ ooo₁ …] … #:rest r)
#'TODO
#;#'(and (list-rest e₁ … r)
c₁ …)])
stx)))))
(define-match-expander list-rest-ish
(λ (stx)
((λ (x) (pretty-write (syntax->datum x)) x)
((syntax-parser
#:literals (list list-rest-ish)
;#:datum-literals (list-rest)
;[(_ [c₁ …] e₁ … (list-rest e₂ … r))
; #'(list-rest-ish [c₁ …] e₁ … e₂ … r)]
;[(_ [c₁ …] e₁ … (list e₂ …))
; #'(list-rest-ish [c₁ …] e₁ … e₂ …)]
[(_ [[c₁ …] e₁ {~optional ooo₁}] … #:proper-list)
(define-temp-ids "~a/copy" (e₁ …))
;; like below, but without the r pattern
(template
(app (λ (l)
(match l
[(list (?@ (and e₁ e₁/copy) (?? ooo₁)) …)
#:when (and c₁ … …)
(list e₁/copy …)]
[_ #f]))
(list (?? (list e₁ ooo₁) e₁)
…)))]
[(_ [[c₁ …] e₁ {~optional ooo₁}] … #:rest r)
(define-temp-ids "~a/copy" (e₁ …))
(template
(app (λ (l)
(match l
[(list-rest (?@ (and e₁ e₁/copy) (?? ooo₁)) … (and the-r r))
#:when (and c₁ … …)
(list e₁/copy … the-r)]))
(list (?? (list e₁ ooo₁) e₁)
…
r)))
#;#'(and (list-rest e₁ … r)
c₁ …)])
stx)))))
(when-typed (when-typed
(provide xList #;xListBuilder) (provide xList #;xListBuilder)

5
scribblings/xlist.scrbl
View File

@ -145,6 +145,11 @@ To use the type expander, you must first require the
(code:line pattern-or-spliced superscripted-repeat) (code:line pattern-or-spliced superscripted-repeat)
(code:line pattern-or-spliced *) (code:line pattern-or-spliced *)
(code:line pattern-or-spliced +) (code:line pattern-or-spliced +)
(code:line pattern-or-spliced ...)
(code:line pattern-or-spliced ..k)
(code:line pattern-or-spliced ____)
(code:line pattern-or-spliced ___k)
(code:line pattern-or-spliced ...+)
(code:line superscripted-id)) (code:line superscripted-id))
(repeat (code:line number) (repeat (code:line number)
(code:line number +) (code:line number +)

2
test/test-match-typed.rkt
View File

@ -1,6 +1,6 @@
#lang typed/racket #lang typed/racket
(require xlist/untyped (require xlist
typed/rackunit) typed/rackunit)
(define-syntax-rule (check-match v clause result) (define-syntax-rule (check-match v clause result)