commit cd704f574f42e42678047884447531c5f0cb53bb
parent 03e284cde1b6a3c10d01404ef626905defd55840
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sun, 25 Sep 2016 09:58:20 +0200
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.
Diffstat:
3 files changed, 81 insertions(+), 118 deletions(-)
diff --git a/main.rkt b/main.rkt
@@ -10,7 +10,7 @@
"between.rkt"
match-string
racket/match
- (only-in phc-toolkit/typed-untyped if-typed when-typed)
+ (only-in phc-toolkit/typed-untyped when-typed)
(only-in syntax/parse ...+)
(for-syntax (rename-in racket/base
[* mul]
@@ -35,9 +35,6 @@
(provide xlist ^ ∞ (for-syntax normalize-xlist-type))
- (define-syntax stop
- (λ (stx) (raise-syntax-error 'stop "This is a private marker" stx)))
-
(begin-for-syntax
(define-syntax ~^
(pattern-expander
@@ -52,7 +49,14 @@
(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-*/c (regexp-match/c */rx))
(define string-superscript-+/c (regexp-match/c +/rx))
@@ -139,11 +143,9 @@
(pattern {~and base {~not {~or ^ + *}}}))
(define-splicing-syntax-class fixed-repeat
- (pattern {~seq :base {~literal ^} power:nat}
+ (pattern {~seq :base {~^ power:nat}}
#:with (expanded …) (map (const #'base)
(range (syntax-e #'power))))
- (pattern {~literal stop}
- #:with (expanded …) #'())
(pattern e:base
#:with (expanded …) #'(e)))
@@ -169,15 +171,13 @@
(define xl
(syntax-parser
#:context context
- #:literals (^ * + - ∞ stop)
+ #:literals (^ * + - ∞)
[()
#'Null]
[rest:not-stx-pair
#'rest]
[(#:rest rest)
#'rest]
- [(stop . rest) ;; eliminate the private marker
- (xl #'rest)]
[(s:with-superscripts . rest)
(xl #'(s.expanded … . rest))]
[(:base {~or * {~^ *}})
@@ -189,9 +189,11 @@
[(:base {~or + {~^ +}} . rest)
(xl #'(base ^ 1 + . rest))]
[(:base {~^ power:nat +} . rest)
- (xl #'(base ^ power stop base * . rest))]
- [(:base {~^ -} . rest) ;; TODO: if there was ^ {-}, then it should keep the braces because the next thing may be a number
- (xl #'(base {~^ 0 -} . rest))]
+ (xl #'(base ^ {power} 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))]
[(:base {~^ from:nat - ∞} . rest)
(xl #'(base ^ from + . rest))]
[(:base {~^ 0 - to:nat} . rest)
@@ -207,7 +209,7 @@
(raise-syntax-error 'xlist
"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)
;; "-" is not followed by a number, nor by ∞, so default to ∞.
(xl #'(base ^ from - ∞ . rest))]
@@ -278,68 +280,69 @@
#:context context
#:literals (^ * + - ∞)
[()
- #'(#:proper-list)]
+ #'(list)]
[rest:not-stx-pair
- #'(#:rest rest)]
- [(#:rest ((~literal ?) (~literal null?)))
- #'(#:proper-list)]
+ #'rest]
[(#:rest rest)
- #'(#:rest rest)]
+ #'rest]
[(({~literal unquote-splicing} splice) …+ . rest)
- #`(#:rest (append splice … #,(xl #'rest)))]
+ #`(append splice … #,(xl #'rest))]
[(s:with-superscripts . rest)
(xl #'(s.expanded … . rest))]
- [(:base {~optional ^} * . rest)
+ [(:base {~or * {~^ *}} . rest)
#:with R (gensym 'R)
- #`([[] base ooo] . #,(xl #'rest))]
- [(:base {~optional ^} + . rest)
+ #`(list-rest-ish [] base ooo #,(xl #'rest))]
+ [(:base {~or + {~^ +}} . rest)
(xl #'(base ^ 1 + . rest))]
- [(:base ^ power:nat + . rest)
+ [(:base {~^ power:nat +} . rest)
#:with ..power (format-id #'power "..~a" (syntax-e #'power))
- #`([[] base ..power] . #,(xl #'rest))]
- [(:base ^ - . rest)
+ #`(list-rest-ish [] base ..power #,(xl #'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))]
- [(:base ^ from:nat - ∞ . rest)
- (xl #'(base ^ from + . rest))]
- [(:base ^ from:nat - to:nat . rest)
+ [(:base {~^ from:nat - ∞} . rest)
+ (xl #'(base ^ {from +} . rest))]
+ [(:base {~^ from:nat - to:nat} . rest)
+ #:with occurrences (gensym 'occurrences)
(when (> (syntax-e #'from) (syntax-e #'to))
(raise-syntax-error 'xlist
"invalid range: m is larger than n"
#'-))
- (define/with-syntax occurrences (gensym 'occurrences))
- #`([[((between/c from to) (length occurrences))]
- (and occurrences base)
- ooo]
- . #,(xl #'rest))]
- [(:base ^ from:nat - . rest)
+ #`(list-rest-ish
+ [(? (λ (_) ((between/c from to) (length occurrences))))]
+ (and occurrences base) ooo
+ #,(xl #'rest))]
+ [(:base {~^ from:nat -} . rest)
;; "-" is not followed by a number, nor by ∞, so default to ∞.
- (xl #'(base ^ from - ∞ . rest))]
+ (xl #'(base ^ {from - ∞} . rest))]
;; aliases
- [(:base {~or {~literal ...} {~literal ___}} . rest)
- #`([[] base ooo] . #,(xl #'rest))]
- [(:base {~literal ...+} . rest)
- #`([[] base ..1] . #,(xl #'rest))]
- [(:base ellipsis:id . rest)
+ [(:base {~or {~literal ...} {~literal ___}
+ {~^ {~literal ...}} {~^ {~literal ___}}}
+ . rest)
+ #`(list-rest-ish [] base ooo #,(xl #'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]+$"
(symbol->string (syntax-e #'ellipsis)))
- #`([[] base ellipsis] . #,(xl #'rest))]
+ #`(list-rest-ish [] base ellipsis #,(xl #'rest))]
[(:base {~^ 1})
- #`([[] base #|no ellipsis|#] . #,(xl #'rest))]
+ #`(list-rest-ish [] base #|no ellipsis|# . #,(xl #'rest))]
[(:base {~^ power:nat})
- (define/with-syntax occurrences (gensym 'occurrences))
- #`([[(= (length occurrences) power)]
- (and occurrences base) ooo]
- . #,(xl #'rest))]
+ #:with occurrences (gensym 'occurrences)
+ #`(list-rest-ish [(? (λ (_) (= (length occurrences) power)))]
+ (and occurrences base) ooo
+ #,(xl #'rest))]
[(:base . rest)
- #`([[] base #|no ellipsis|#] . #,(xl #'rest))]))
- ((λ (x) (pretty-write (syntax->datum x)) x)
- #`(list-rest-ish . #,(xl stx))))
+ #`(list-rest-ish [] base #|no ellipsis|# #,(xl #'rest))]))
+ (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)
+ #:literals (^ * + - ∞)
(pattern {~seq :base {~^ power:nat}}
#:with (mandatory …) (map (const #'base)
(range (syntax-e #'power))))
@@ -360,7 +363,7 @@
;; for ->*
(define-splicing-syntax-class mandatory-bounded-variadic-repeated-type
#:attributes ([mandatory 1] [optional 1])
- #:literals (^ * + - ∞ stop)
+ #:literals (^ * + - ∞)
(pattern {~seq :base {~^ {~and from:nat {~not 0}} - to:nat}}
#:with (mandatory …) (map (const #'base)
(range (syntax-e #'from)))
@@ -374,7 +377,7 @@
;; Expands to 1 or more optional-doms for ->*
(define-splicing-syntax-class optional-bounded-variadic-repeated-type
#:attributes ([optional 1])
- #:literals (^ * + - ∞ stop)
+ #:literals (^ * + - ∞)
(pattern {~seq :base {~^ {~optional 0} - to:nat}}
#:with (optional …) (map (const #'base)
(range (syntax-e #'to))))
@@ -400,7 +403,7 @@
;; Expands to a #:rest clause for ->*
(define-splicing-syntax-class optional-variadic-repeated-type
#:attributes ([rest-clause 1])
- #:literals (^ * + - ∞ stop)
+ #:literals (^ * + - ∞)
(pattern {~or {~seq :base {~^ {~optional 0} - {~optional ∞}}}
{~seq :base {~^ *}}
{~seq :base *}}
@@ -413,7 +416,7 @@
;; The order of clauses is important, as they otherwise overlap.
(syntax-parse stx
#:context context
- #:literals (^ * + - ∞ stop)
+ #:literals (^ * + - ∞)
[(τᵢ:fixed-repeated-type
…
(~or (~seq τₘᵥ:mandatory-variadic-repeated-type)
@@ -446,67 +449,22 @@
#:match-expander (λ (stx) ((xlist-match stx) (stx-cdr stx)))
#;{#:call (λ (stx) ((xlist-builder stx) (stx-cdr stx)))})
- (if-typed
- (begin
- ;(require "split-list.rkt")
- (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₁ ooo₁ …] … #:proper-list)
- #:with whole (gensym 'whole)
- #'TODO
- #;#'(? (λ (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)))))
+ (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-ish [c₂ …] e₂ … r))
+ #'(list-rest-ish [c₁ … c₂ …] e₁ … e₂ … r)]
+ [(_ [c₁ …] e₁ … (list-rest e₂ … r))
+ #'(list-rest-ish [c₁ …] e₁ … e₂ … r)]
+ [(_ [c₁ …] e₁ … (list e₂ …))
+ #'(and (list e₁ … e₂ …) c₁ …)]
+ [(_ [c₁ …] e₁ … r)
+ #'(and (list-rest e₁ … r)
+ c₁ …)])
+ stx))))
(when-typed
(provide xList #;xListBuilder)
diff --git a/scribblings/xlist.scrbl b/scribblings/xlist.scrbl
@@ -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 *)
(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))
(repeat (code:line number)
(code:line number +)
diff --git a/test/test-match-typed.rkt b/test/test-match-typed.rkt
@@ -1,6 +1,6 @@
#lang typed/racket
-(require xlist/untyped
+(require xlist
typed/rackunit)
(define-syntax-rule (check-match v clause result)
