commit b672228539eb0a34b9ef332eee87f81ec95cb8ae
parent cd704f574f42e42678047884447531c5f0cb53bb
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sun, 25 Sep 2016 15:53:21 +0200
Documented split-xlist, improved prcision of inference for fixed-length and bounded-length sublists
Diffstat:
11 files changed, 983 insertions(+), 587 deletions(-)
diff --git a/implementation.rkt b/implementation.rkt
@@ -0,0 +1,483 @@
+#lang typed/racket/base
+
+(require phc-toolkit/typed-untyped)
+(define-typed/untyped-modules #:no-test
+ (require racket/require
+ (only-in type-expander define-type-expander)
+ multi-id
+ "caret-identifier.rkt"
+ "infinity-identifier.rkt"
+ "once-identifier.rkt"
+ "between.rkt"
+ match-string
+ racket/match
+ (only-in phc-toolkit/typed-untyped when-typed)
+ (only-in syntax/parse ...+)
+ (for-syntax "caret-identifier.rkt"
+ (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
+ (subtract-in syntax/stx phc-toolkit/untyped)
+ type-expander/expander
+ phc-toolkit/untyped
+ racket/pretty)
+ (for-meta 2 racket/base)
+ (for-meta 2 syntax/parse))
+
+ (provide xlist ^ ∞ once (for-syntax normalize-xlist-type))
+
+ (begin-for-syntax
+ (define-syntax ~^
+ (pattern-expander
+ (λ (stx)
+ (syntax-case stx ()
+ [(_ pat ...)
+ #`{~or {~seq {~literal ^} pat ...}
+ {~seq {~optional {~literal ^}}
+ (pat ...)}}]))))
+
+ (define number/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-*/c (regexp-match/c */rx))
+ (define string-superscript-+/c (regexp-match/c +/rx))
+ (define string-superscript--/c (regexp-match/c -/rx))
+
+ (define string-superscript-any/c
+ (or/c string-superscript-number/c
+ string-superscript-*/c
+ string-superscript-+/c
+ string-superscript--/c))
+
+ (define normal-rest/c
+ (or/c (list/c (id/c #'^) exact-nonnegative-integer?)
+ (list/c (id/c #'^) (id/c #'*))
+ (list/c (id/c #'^) exact-nonnegative-integer? (id/c #'+))
+ (list/c (id/c #'^)
+ exact-nonnegative-integer?
+ (id/c #'-)
+ (or/c (id/c #'∞) exact-nonnegative-integer?))))
+
+ (define normal-string/c (cons/c string?
+ normal-rest/c))
+ (define normal-id/c (cons/c (and/c identifier? (not/c (syntax/c '||)))
+ normal-rest/c))
+
+ (define/contract (string-superscripts->number superscripts)
+ (-> string-superscript-number/c exact-nonnegative-integer?)
+ (string->number
+ (string-join
+ (map (match-lambda ["⁰" "0"] ["¹" "1"] ["²" "2"] ["³" "3"] ["⁴" "4"]
+ ["⁵" "5"] ["⁶" "6"] ["⁷" "7"] ["⁸" "8"] ["⁹" "9"])
+ (map string (string->list superscripts))))))
+
+ (define/contract (string-superscripts->normal superscripts)
+ (-> string-superscript-any/c
+ normal-string/c)
+ (define ->num string-superscripts->number)
+ (match superscripts
+ ;; Order is important, the regexpes overlap
+ [(regexp -/rx (list _ base n m))
+ (list base
+ #'^
+ (if (string=? n "") 0 (->num n))
+ #'-
+ (if (string=? m "") #'∞ (->num m)))]
+ [(regexp number/rx (list _ base n)) (list base #'^ (->num n))]
+ [(regexp */rx (list _ base)) (list base #'^ #'*)]
+ [(regexp +/rx (list _ base n))
+ (list base #'^ (if (string=? n "") 1 (->num n)) #'+)]))
+
+ (define/contract (id-superscripts->normal id)
+ (-> identifier? (or/c #f normal-id/c))
+ (define str (symbol->string (syntax-e id)))
+ (if (string-superscript-any/c str)
+ (match (string-superscripts->normal str)
+ [(cons "" _) #f]
+ [(cons base rest) (cons (format-id id "~a" base) rest)])
+ #f))
+
+ (define/contract (only-superscripts->normal id)
+ (-> identifier? (or/c #f normal-rest/c))
+ (define str (symbol->string (syntax-e id)))
+ (if (string-superscript-any/c str)
+ (match (string-superscripts->normal str)
+ [(cons "" rest) rest]
+ [_ #f])
+ #f))
+
+ (define-splicing-syntax-class with-superscripts
+ (pattern (~seq id:id)
+ #:do [(define normal (id-superscripts->normal #'id))]
+ #:when normal
+ #:with (expanded …) normal)
+ (pattern (~seq base:expr super:id)
+ #:do [(define normal (only-superscripts->normal #'super))]
+ #:when normal
+ #:with (expanded …) (cons #'base normal)))
+
+ (define-syntax-class not-stx-pair
+ (pattern {~not (_ . _)}))
+
+ (define-syntax-class base
+ #:literals (^ + *)
+ (pattern {~and base {~not {~or ^ + *}}}))
+
+ (define-splicing-syntax-class fixed-repeat
+ (pattern {~seq :base {~^ power:nat}}
+ #:with (expanded …) (map (const #'base)
+ (range (syntax-e #'power))))
+ (pattern e:base
+ #:with (expanded …) #'(e)))
+
+ (define-syntax-class repeat-spec
+ #:literals (* + - ∞)
+ (pattern (:nat))
+ (pattern ({~optional :nat} +))
+ (pattern ({~optional :nat} - {~optional {~or ∞ :nat}}))
+ (pattern (*)))
+
+ #;(define-splicing-syntax-class xlist-*-element
+ #:attributes (base)
+ (pattern :split-superscript-*-id)
+ (pattern (~seq base :superscript-ish-*)))
+
+ #;(define-splicing-syntax-class xlist-+-element
+ #:attributes (base min)
+ (pattern :split-superscript-+-id)
+ (pattern (~seq base :superscript-ish-+)))
+
+ (define ((xlist-type context) stx)
+ ;; The order of clauses is important, as they otherwise overlap.
+ (define xl
+ (syntax-parser
+ #:context context
+ #:literals (^ * + - ∞ once)
+ [()
+ #'Null]
+ [rest:not-stx-pair
+ #'rest]
+ [(#:rest rest)
+ #'rest]
+ [(s:with-superscripts . rest)
+ (xl #'(s.expanded … . rest))]
+ [(:base {~or * {~^ *}})
+ #'(Listof base)]
+ [(:base {~or * {~^ *}} . rest)
+ #:with R (gensym 'R)
+ #`(Rec R (U (Pairof base R)
+ #,(xl #'rest)))]
+ [(:base {~or + {~^ +}} . rest)
+ (xl #'(base ^ 1 + . rest))]
+ [(:base {~^ power:nat +} . 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)
+ #`(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} base ^ 0 - difference . rest))]
+ [(:base {~^ from:nat -} . rest)
+ ;; "-" is not followed by a number, nor by ∞, so default to ∞.
+ (xl #'(base ^ from - ∞ . rest))]
+ [(:base {~^ power:nat} . rest)
+ #:with (expanded …) (map (const #'base)
+ (range (syntax-e #'power)))
+ #`(List* expanded … #,(xl #'rest))]
+ [(:base {~optional {~^ once}} . rest)
+ #`(Pairof base #,(xl #'rest))]))
+ (xl stx))
+
+ ;; normalize the xlist type
+ ;; The normalized form has one type followed by ^ followed by a repeat
+ ;; within braces (possibly {1}) for each position in the original type. It
+ ;; always finishes with #:rest rest-type
+
+ (define (normalize-xlist-type stx context)
+ (define nt
+ (syntax-parser
+ #:context context
+ #:literals (^ * + - ∞ once)
+ [()
+ #'(#:rest Null)]
+ [rest:not-stx-pair
+ #'(#:rest rest)]
+ [(#:rest rest)
+ #'(#:rest rest)]
+ [(s:with-superscripts . rest)
+ (nt #'(s.expanded … . rest))]
+ [(:base {~or * {~^ *}} . rest)
+ #`(base ^ {*} . #,(nt #'rest))]
+ [(:base {~or + {~^ +}} . rest)
+ #`(base ^ {1 +} . #,(nt #'rest))]
+ [(:base {~^ 0 +} . rest)
+ #`(base ^ {*} . #,(nt #'rest))]
+ [(:base {~^ power:nat +} . rest)
+ #`(base ^ {power +} . #,(nt #'rest))]
+ [(:base {~optional ^} {-} . rest)
+ #`(base ^ {*} . #,(nt #'rest))]
+ [(:base ^ - . rest) ;; not with {}, check if there's stuff after
+ (nt #'(base ^ 0 - . rest))]
+ [(:base {~^ 0 - ∞} . rest)
+ #`(base ^ {*} . #,(nt #'rest))]
+ [(:base {~^ from:nat - ∞} . rest)
+ (nt #'(base ^ from + . rest))]
+ [(:base {~^ from:nat - to:nat} . rest)
+ #`(base ^ {from - to} . #,(nt #'rest))]
+ [(:base {~^ from:nat -} . rest)
+ ;; "-" is not followed by a number, nor by ∞, so default to ∞.
+ (nt #'(base ^ from - ∞ . rest))]
+ [(:base {~^ power:nat} . rest)
+ #`(base ^ {power} . #,(nt #'rest))]
+ [(:base {~^ once} . rest)
+ #`(base ^ {once} . #,(nt #'rest))]
+ [(:base . rest)
+ #`(base ^ {once} . #,(nt #'rest))]))
+ (nt stx))
+
+
+
+ ;; Match
+
+ (define-syntax-class xlist-pattern
+ (pattern (({~literal unquote-splicing} splice))
+ #:with expanded #'splice)
+ (pattern (pat)
+ #:with expanded #'(list pat)))
+
+ (define ((xlist-match context) stx)
+ ;; The order of clauses is important, as they otherwise overlap.
+ (define/with-syntax ooo #'(... ...))
+ (define xl
+ (syntax-parser
+ #:context context
+ #:literals (^ * + - ∞)
+ [()
+ #'(list)]
+ [rest:not-stx-pair
+ #'rest]
+ [(#:rest rest)
+ #'rest]
+ [(({~literal unquote-splicing} splice) …+ . rest)
+ #`(append splice … #,(xl #'rest))]
+ [(s:with-superscripts . rest)
+ (xl #'(s.expanded … . rest))]
+ [(:base {~or * {~^ *}} . rest)
+ #:with R (gensym 'R)
+ #`(list-rest-ish [] base ooo #,(xl #'rest))]
+ [(:base {~or + {~^ +}} . rest)
+ (xl #'(base ^ 1 + . rest))]
+ [(:base {~^ power:nat +} . rest)
+ #:with ..power (format-id #'power "..~a" (syntax-e #'power))
+ #`(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)
+ #:with occurrences (gensym 'occurrences)
+ (when (> (syntax-e #'from) (syntax-e #'to))
+ (raise-syntax-error 'xlist
+ "invalid range: m is larger than n"
+ #'-))
+ #`(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))]
+ ;; aliases
+ [(: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)))
+ #`(list-rest-ish [] base ellipsis #,(xl #'rest))]
+ [(:base {~^ once})
+ #`(list-rest-ish [] base #|no ellipsis|# . #,(xl #'rest))]
+ [(:base {~^ power:nat})
+ #:with occurrences (gensym 'occurrences)
+ #`(list-rest-ish [(? (λ (_) (= (length occurrences) power)))]
+ (and occurrences base) ooo
+ #,(xl #'rest))]
+ [(:base . rest)
+ #`(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 (^ * + - ∞)
+ (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 (^ * + - ∞)
+ (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 (^ * + - ∞)
+ (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 (^ * + - ∞)
+ (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 (^ * + - ∞)
+ [(τᵢ: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)))
+ #;{#:call (λ (stx) ((xlist-builder stx) (stx-cdr 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)
+ (define-type-expander (xList stx)
+ ((xlist-type stx) (stx-cdr stx)))
+
+ #;(define-type-expander (xListBuilder stx)
+ ((xlist-builder-type stx) (stx-cdr stx)))))
diff --git a/main.rkt b/main.rkt
@@ -1,475 +1,5 @@
-#lang typed/racket/base
-
-(require phc-toolkit/typed-untyped)
-(define-typed/untyped-modules #:no-test
- (require racket/require
- (only-in type-expander define-type-expander)
- multi-id
- "caret-identifier.rkt"
- "infinity-identifier.rkt"
- "between.rkt"
- match-string
- 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/parse/experimental/template
- (subtract-in syntax/stx phc-toolkit/untyped)
- type-expander/expander
- phc-toolkit/untyped
- racket/pretty)
- (for-meta 2 racket/base)
- (for-meta 2 syntax/parse))
-
- (provide xlist ^ ∞ (for-syntax normalize-xlist-type))
-
- (begin-for-syntax
- (define-syntax ~^
- (pattern-expander
- (λ (stx)
- (syntax-case stx ()
- [(_ pat ...)
- #`{~or {~seq {~literal #,(syntax-local-introduce #'^)} pat ...}
- {~seq {~optional {~literal #,(syntax-local-introduce #'^)}}
- (pat ...)}}]))))
-
- (define number/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-*/c (regexp-match/c */rx))
- (define string-superscript-+/c (regexp-match/c +/rx))
- (define string-superscript--/c (regexp-match/c -/rx))
-
- (define string-superscript-any/c
- (or/c string-superscript-number/c
- string-superscript-*/c
- string-superscript-+/c
- string-superscript--/c))
-
- (define normal-rest/c
- (or/c (list/c (id/c #'^) exact-nonnegative-integer?)
- (list/c (id/c #'^) (id/c #'*))
- (list/c (id/c #'^) exact-nonnegative-integer? (id/c #'+))
- (list/c (id/c #'^)
- exact-nonnegative-integer?
- (id/c #'-)
- (or/c (id/c #'∞) exact-nonnegative-integer?))))
-
- (define normal-string/c (cons/c string?
- normal-rest/c))
- (define normal-id/c (cons/c (and/c identifier? (not/c (syntax/c '||)))
- normal-rest/c))
-
- (define/contract (string-superscripts->number superscripts)
- (-> string-superscript-number/c exact-nonnegative-integer?)
- (string->number
- (string-join
- (map (match-lambda ["⁰" "0"] ["¹" "1"] ["²" "2"] ["³" "3"] ["⁴" "4"]
- ["⁵" "5"] ["⁶" "6"] ["⁷" "7"] ["⁸" "8"] ["⁹" "9"])
- (map string (string->list superscripts))))))
-
- (define/contract (string-superscripts->normal superscripts)
- (-> string-superscript-any/c
- normal-string/c)
- (define ->num string-superscripts->number)
- (match superscripts
- ;; Order is important, the regexpes overlap
- [(regexp -/rx (list _ base n m))
- (list base
- #'^
- (if (string=? n "") 0 (->num n))
- #'-
- (if (string=? m "") #'∞ (->num m)))]
- [(regexp number/rx (list _ base n)) (list base #'^ (->num n))]
- [(regexp */rx (list _ base)) (list base #'^ #'*)]
- [(regexp +/rx (list _ base n))
- (list base #'^ (if (string=? n "") 1 (->num n)) #'+)]))
-
- (define/contract (id-superscripts->normal id)
- (-> identifier? (or/c #f normal-id/c))
- (define str (symbol->string (syntax-e id)))
- (if (string-superscript-any/c str)
- (match (string-superscripts->normal str)
- [(cons "" _) #f]
- [(cons base rest) (cons (format-id id "~a" base) rest)])
- #f))
-
- (define/contract (only-superscripts->normal id)
- (-> identifier? (or/c #f normal-rest/c))
- (define str (symbol->string (syntax-e id)))
- (if (string-superscript-any/c str)
- (match (string-superscripts->normal str)
- [(cons "" rest) rest]
- [_ #f])
- #f))
-
- (define-splicing-syntax-class with-superscripts
- (pattern (~seq id:id)
- #:do [(define normal (id-superscripts->normal #'id))]
- #:when normal
- #:with (expanded …) normal)
- (pattern (~seq base:expr super:id)
- #:do [(define normal (only-superscripts->normal #'super))]
- #:when normal
- #:with (expanded …) (cons #'base normal)))
-
- (define-syntax-class not-stx-pair
- (pattern {~not (_ . _)}))
-
- (define-syntax-class base
- #:literals (^ + *)
- (pattern {~and base {~not {~or ^ + *}}}))
-
- (define-splicing-syntax-class fixed-repeat
- (pattern {~seq :base {~^ power:nat}}
- #:with (expanded …) (map (const #'base)
- (range (syntax-e #'power))))
- (pattern e:base
- #:with (expanded …) #'(e)))
-
- (define-syntax-class repeat-spec
- #:literals (* + - ∞)
- (pattern (:nat))
- (pattern ({~optional :nat} +))
- (pattern ({~optional :nat} - {~optional {~or ∞ :nat}}))
- (pattern (*)))
-
- #;(define-splicing-syntax-class xlist-*-element
- #:attributes (base)
- (pattern :split-superscript-*-id)
- (pattern (~seq base :superscript-ish-*)))
-
- #;(define-splicing-syntax-class xlist-+-element
- #:attributes (base min)
- (pattern :split-superscript-+-id)
- (pattern (~seq base :superscript-ish-+)))
-
- (define ((xlist-type context) stx)
- ;; The order of clauses is important, as they otherwise overlap.
- (define xl
- (syntax-parser
- #:context context
- #:literals (^ * + - ∞)
- [()
- #'Null]
- [rest:not-stx-pair
- #'rest]
- [(#:rest rest)
- #'rest]
- [(s:with-superscripts . rest)
- (xl #'(s.expanded … . rest))]
- [(:base {~or * {~^ *}})
- #'(Listof base)]
- [(:base {~or * {~^ *}} . rest)
- #:with R (gensym 'R)
- #`(Rec R (U (Pairof base R)
- #,(xl #'rest)))]
- [(:base {~or + {~^ +}} . rest)
- (xl #'(base ^ 1 + . rest))]
- [(:base {~^ power:nat +} . 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)
- #`(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} 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))
-
- ;; normalize the xlist type
- ;; The normalized form has one type followed by ^ followed by a repeat
- ;; within braces (possibly {1}) for each position in the original type. It
- ;; always finishes with #:rest rest-type
-
- (define (normalize-xlist-type stx context)
- (define nt
- (syntax-parser
- #:context context
- #:literals (^ * + - ∞)
- [()
- #'(#:rest Null)]
- [rest:not-stx-pair
- #'(#:rest rest)]
- [(#:rest rest)
- #'(#:rest rest)]
- [(s:with-superscripts . rest)
- (nt #'(s.expanded … . rest))]
- [(:base {~or * {~^ *}} . rest)
- #`(base ^ {*} . #,(nt #'rest))]
- [(:base {~or + {~^ +}} . rest)
- #`(base ^ {1 +} . #,(nt #'rest))]
- [(:base {~^ 0 +} . rest)
- #`(base ^ {*} . #,(nt #'rest))]
- [(:base {~^ power:nat +} . rest)
- #`(base ^ {power +} . #,(nt #'rest))]
- [(:base {~optional ^} {-} . rest)
- #`(base ^ {*} . #,(nt #'rest))]
- [(:base ^ - . rest) ;; not with {}, check if there's stuff after
- (nt #'(base ^ 0 - . rest))]
- [(:base {~^ 0 - ∞} . rest)
- #`(base ^ {*} . #,(nt #'rest))]
- [(:base {~^ from:nat - ∞} . rest)
- (nt #'(base ^ from + . rest))]
- [(:base {~^ from:nat - to:nat} . rest)
- #`(base ^ {from - to} . #,(nt #'rest))]
- [(:base {~^ from:nat -} . rest)
- ;; "-" is not followed by a number, nor by ∞, so default to ∞.
- (nt #'(base ^ from - ∞ . rest))]
- [(:base {~^ power:nat})
- #`(base ^ {power} . #,(nt #'rest))]
- [(:base . rest)
- #`(base ^ {1} . #,(nt #'rest))]))
- (nt stx))
-
-
-
- ;; Match
-
- (define-syntax-class xlist-pattern
- (pattern (({~literal unquote-splicing} splice))
- #:with expanded #'splice)
- (pattern (pat)
- #:with expanded #'(list pat)))
-
- (define ((xlist-match context) stx)
- ;; The order of clauses is important, as they otherwise overlap.
- (define/with-syntax ooo #'(... ...))
- (define xl
- (syntax-parser
- #:context context
- #:literals (^ * + - ∞)
- [()
- #'(list)]
- [rest:not-stx-pair
- #'rest]
- [(#:rest rest)
- #'rest]
- [(({~literal unquote-splicing} splice) …+ . rest)
- #`(append splice … #,(xl #'rest))]
- [(s:with-superscripts . rest)
- (xl #'(s.expanded … . rest))]
- [(:base {~or * {~^ *}} . rest)
- #:with R (gensym 'R)
- #`(list-rest-ish [] base ooo #,(xl #'rest))]
- [(:base {~or + {~^ +}} . rest)
- (xl #'(base ^ 1 + . rest))]
- [(:base {~^ power:nat +} . rest)
- #:with ..power (format-id #'power "..~a" (syntax-e #'power))
- #`(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)
- #:with occurrences (gensym 'occurrences)
- (when (> (syntax-e #'from) (syntax-e #'to))
- (raise-syntax-error 'xlist
- "invalid range: m is larger than n"
- #'-))
- #`(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))]
- ;; aliases
- [(: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)))
- #`(list-rest-ish [] base ellipsis #,(xl #'rest))]
- [(:base {~^ 1})
- #`(list-rest-ish [] base #|no ellipsis|# . #,(xl #'rest))]
- [(:base {~^ power:nat})
- #:with occurrences (gensym 'occurrences)
- #`(list-rest-ish [(? (λ (_) (= (length occurrences) power)))]
- (and occurrences base) ooo
- #,(xl #'rest))]
- [(:base . rest)
- #`(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 (^ * + - ∞)
- (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 (^ * + - ∞)
- (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 (^ * + - ∞)
- (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 (^ * + - ∞)
- (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 (^ * + - ∞)
- [(τᵢ: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)))
- #;{#:call (λ (stx) ((xlist-builder stx) (stx-cdr 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)
- (define-type-expander (xList stx)
- ((xlist-type stx) (stx-cdr stx)))
-
- #;(define-type-expander (xListBuilder stx)
- ((xlist-builder-type stx) (stx-cdr stx)))))
+#lang typed/racket
+(require (submod "implementation.rkt" typed)
+ "split-xlist.rkt")
+(provide (all-from-out (submod "implementation.rkt" typed))
+ split-xlist)
+\ No newline at end of file
diff --git a/once-identifier.rkt b/once-identifier.rkt
@@ -0,0 +1,11 @@
+#lang racket/base
+(provide once)
+
+(require (for-syntax racket/base))
+
+(define-syntax once
+ (λ (stx)
+ (raise-syntax-error
+ 'once
+ "The \"once\" identifier can only be used in some contexts"
+ stx)))
+\ No newline at end of file
diff --git a/scribblings/identifiers.scrbl b/scribblings/identifiers.scrbl
@@ -10,10 +10,13 @@
#:link-target? #f
#:use-sources
[(lib "xlist/infinity-identifier.rkt")
- (lib "xlist/caret-identifier.rkt")]]
+ (lib "xlist/caret-identifier.rkt")
+ (lib "xlist/once-identifier.rkt")]]
@defidform[^]{This identifier can only be used within xlist forms.}
+@defidform[once]{This identifier can only be used within xlist forms.}
+
@defidform[∞]{
This identifier is meant to be used within xlist forms, but is also equal to
@racket[+inf.0] as a convenience. In the future, this package will make it
diff --git a/scribblings/split-xlist.scrbl b/scribblings/split-xlist.scrbl
@@ -0,0 +1,55 @@
+#lang scribble/manual
+@require[phc-toolkit/scribblings/utils
+ @for-label[xlist
+ typed/racket/base]]
+
+@title{Splitting an xlist in its constituent sublists}
+@(declare-exporting xlist)
+
+@defform*[#:kind "match-expander"
+ #:literals (^ * + - ∞)
+ [(split-xlist pat τᵢ ...)
+ (split-xlist pat τᵢ ... . rest)
+ (split-xlist pat τᵢ ... #:rest rest)]
+ #:grammar
+ [(τᵢ type
+ repeated-type)
+ (repeated-type (code:line type ^ repeat)
+ (code:line type ^ {repeat})
+ (code:line type {repeat})
+ (code:line type superscripted-repeat)
+ (code:line type *)
+ (code:line type +)
+ (code:line superscripted-id))
+ (repeat (code:line once)
+ (code:line nat)
+ (code:line nat +)
+ (code:line +)
+ (code:line nat - nat)
+ (code:line nat - ∞)
+ (code:line nat -)
+ (code:line - nat)
+ (code:line -)
+ (code:line - ∞)
+ (code:line *))]
+ #:contracts
+ [(nat (syntax/c exact-nonnegative-integer?))]]{
+
+ This match patterns splits an xlist into a list of lists, and matches the
+ result against @racket[pat]. Each repeated element of the xlist is extracted
+ into one of these sublists. The type for each sublist is determined base on
+ the element's type and its @racket[_repeat]:
+ @itemlist[
+ @item{If the @racket[_repeat] for that element is @racket[once], then the
+ element is inserted directly, without nesting it within a sublist. In
+ contrast, it the @racket[_repeat] were @racket[1], the element would be
+ inserted in a sublist of length one.}
+ @item{If the @racket[_repeat] for that element is @racket[*] or an
+ equivalent, the type of the sublist will be @racket[(Listof type)]}
+ @item{If the @racket[_repeat] for that element is @racket[_n +] or an
+ equivalent, the type of the sublist will be @racket[(xList type ^ _n +)]}
+ @item{If the @racket[_repeat] for that element is @racket[_n] or an
+ equivalent, the type of the sublist will be @racket[(xList type ^ _n)]}
+ @item{If the @racket[_repeat] for that element is @racket[_from - _to] or an
+ equivalent, the type of the sublist will be
+ @racket[(xList type ^ _from - _to)]}]}
diff --git a/scribblings/xlist-untyped.scrbl b/scribblings/xlist-untyped.scrbl
@@ -7,6 +7,6 @@
@title{Untyped versions of xlist}
@defmodule[xlist/untyped
#:use-sources
- [(submod (lib "xlist/main.rkt") untyped)]]
+ [(submod (lib "xlist/implementation.rkt") untyped)]]
@defidform[xlist]{Untyped version of @|typed:xlist|.}
diff --git a/scribblings/xlist.scrbl b/scribblings/xlist.scrbl
@@ -11,6 +11,8 @@
@title[#:style (with-html5 manual-doc-style)]{xlist}
@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]]
+@(define ddd (racket ...))
+
@defmodule[xlist]
Fancy lists, with bounded or unbounded repetition of elements. Can be used as a
@@ -23,9 +25,9 @@ To use the type expander, you must first require the
[@defform*[#:kind "type-expander"
[(xList τᵢ ...)
(xList τᵢ ... . rest)
- (xList τᵢ ... #:rest . rest)]]
+ (xList τᵢ ... #:rest rest)]]
@defform*[#:kind "type-expander"
- #:literals (^ *)
+ #:literals (^ * + - ∞ once)
[(xlist τᵢ ...)
(xlist τᵢ ... . rest)]
#:grammar
@@ -38,22 +40,26 @@ To use the type expander, you must first require the
(code:line type *)
(code:line type +)
(code:line superscripted-id))
- (repeat (code:line number)
- (code:line number +)
+ (repeat (code:line once)
+ (code:line nat)
+ (code:line nat +)
(code:line +)
- (code:line number - number)
- (code:line number - ∞)
- (code:line number -)
- (code:line - number)
+ (code:line nat - nat)
+ (code:line nat - ∞)
+ (code:line nat -)
+ (code:line - nat)
(code:line -)
(code:line - ∞)
- (code:line *))]]]]{
+ (code:line *))]
+ #:contracts
+ [(nat (syntax/c exact-nonnegative-integer?))]]]]{
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 following two types are equivalent:
@racketblock[
(xList Number ^ 3 Symbol String ^ 2)
+
(List Number Number Number Symbol String String)]
The notation @racket[type *] indicates that the given type may be repeated zero
@@ -61,6 +67,7 @@ To use the type expander, you must first require the
@racketblock[
(xList Number * Symbol String *)
+
(Rec R1 (U (Pairof Number R1)
(List* Symbol (Rec R2 (U (Pairof String R2)
Null)))))]
@@ -70,17 +77,24 @@ To use the type expander, you must first require the
@racketblock[
(xList Number ^ {2 +} String)
+
(List* Number Number (Rec R1 (U (Pairof Number R1)
(List String))))]
When the number preceding @racket[+] is omitted, it defaults to @racket[1].
+ The notation @racket[type ^ once] yields the same type as @racket[type ^ 1],
+ but other forms recognise @racket[once] and treat it specially. For example,
+ @racket[xlist-split] splits the corresponding element as a standalone value,
+ not as a list of length one.
+
The notation @racket[type ^ _n - _m] indicates that the given type may be
repeated between @racket[_n] (inclusive) and @racket[_m] (inclusive) times.
Therefore, the following two types are equivalent:
@racketblock[
(xList Number ^ {2 - 5} String)
+
(U (List Number Number String)
(List Number Number Number String)
(List Number Number Number Number String)
@@ -129,10 +143,10 @@ To use the type expander, you must first require the
@defform*[#:kind "match-expander"
#:link-target? #f
- #:literals (^ *)
+ #:literals (^ * + - ...+ ∞)
[(xlist patᵢ ...)
(xlist patᵢ ... . rest)
- (xlist patᵢ ... #:rest . rest)]
+ (xlist patᵢ ... #:rest rest)]
#:grammar
[(patᵢ pattern-or-spliced
repeated-pattern
@@ -145,27 +159,27 @@ 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 pattern-or-spliced ooo)
(code:line superscripted-id))
- (repeat (code:line number)
- (code:line number +)
+ (repeat (code:line once)
+ (code:line nat)
+ (code:line nat +)
(code:line +)
- (code:line number - number)
- (code:line number - ∞)
- (code:line number -)
- (code:line - number)
+ (code:line nat - nat)
+ (code:line nat - ∞)
+ (code:line nat -)
+ (code:line - nat)
(code:line - ∞)
(code:line -)
(code:line *)
- (code:line ...)
- (code:line ..k)
- (code:line ____)
- (code:line ___k)
- (code:line ...+))]]{
+ (code:line ooo))
+ (ooo #,ddd
+ ..k
+ ____
+ ___k
+ ...+)]
+ #:contracts
+ [(nat (syntax/c exact-nonnegative-integer?))]]{
This match expander works like the @racket[xList] type expander, but instead
controls the repetition of match patterns. The repeated patterns are not
@@ -173,6 +187,11 @@ To use the type expander, you must first require the
attributes. Instead, the @racket[repeat] forms control the number of times a
pattern may be bound, like @racket[...] does.
+ If the @racket[_repeat] is @racket[once], or if the pattern does not have a
+ @racket[_repeat], then the pattern is not put under ellipses, so that
+ @racket[(match '(42) [(xlist a ^ once) a])] returns @racket[42], whereas
+ @racket[(match '(42) [(xlist a ^ 1) a])] returns @racket['(42)].
+
For convenience and compatibility with existing match patterns, the following
equivalences are provided:
@itemlist[
@@ -191,6 +210,7 @@ To use the type expander, you must first require the
@racketblock[
(xlist number?³⁻⁵ ,@(list-no-order number? string?) symbol?⁺)
+
(append (and (list number? ...) (app length (? (between/c 3 5))))
(list-no-order number? string?)
(list symbol? ..1))]
@@ -203,8 +223,10 @@ To use the type expander, you must first require the
library which would help with that (yet). This means that although by
construction @racket[xlist] tries to avoid to generate such patterns, a few of
the patterns supported by @racket[xlist] will not work in
- @racketmodname[typed/racket] (rest values and spliced lists are the most likely
- to cause problems).}
+ @racketmodname[typed/racket] (rest values and spliced lists are the most
+ likely to cause problems). As an alternative, try the @racket[split-xlist]
+ pattern, which produces code which should propagate type information to the
+ different sub-lists.}
@;{This is completely wrong.
@defform*[#:link-target? #f
@@ -252,21 +274,20 @@ To use the type expander, you must first require the
(code:line type superscripted-optional-variadic-repeat)
(code:line superscripted-optional-variadic-id)
(code:line type *))
- (fixed-repeat (code:line number)
+ (fixed-repeat (code:line nat)
(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 +)
+ (mandatory-bounded-variadic-repeat (code:line nat - nat))
+ (optional-bounded-variadic-repeat (code:line 0 - nat)
+ (code:line - nat))
+ (mandatory-variadic-repeat (code:line nat +)
(code:line +)
- (code:line number -)
- (code:line number - ∞))
+ (code:line nat -)
+ (code:line nat - ∞))
(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).}
@@ -274,10 +295,12 @@ To use the type expander, you must first require the
@defproc[(normalize-xlist-type [stx syntax?] [context syntax?]) syntax?]{
Normalizes the xlist type. The normalized form has one type followed by ^
- followed by a repeat within braces (possibly {1}) for each position in the
- original type. It always finishes with #:rest rest-type. This function also
- performs a few simplifications on the type, like transforming @racket[^ {3 -}]
- into @racket[^ {3 +}], and transforming @racket[^ {0 -}] into @racket[^ {*}].}
+ followed by a repeat within braces (a @racket[type] without a repeat is
+ transformed into @racket[type ^ {once}]) for each position in the original
+ type. It always finishes with #:rest rest-type. This function also performs a
+ few simplifications on the type, like transforming @racket[^ {3 -}] into
+ @racket[^ {3 +}], and transforming @racket[^ {0 -}] into @racket[^ {*}].}
+@include-section{split-xlist.scrbl}
@include-section{xlist-untyped.scrbl}
@include-section{identifiers.scrbl}
\ No newline at end of file
diff --git a/split-xlist.rkt b/split-xlist.rkt
@@ -2,12 +2,16 @@
(require (for-syntax phc-toolkit/untyped
syntax/parse
- syntax/parse/experimental/template)
- xlist
+ syntax/parse/experimental/template
+ racket/pretty
+ racket/list)
+ (submod "implementation.rkt" typed)
"caret-identifier.rkt"
+ "infinity-identifier.rkt"
+ "once-identifier.rkt"
type-expander)
-(provide f-split-list)
+(provide split-xlist f-split-list m-split-xlist*)
(: f-split-list (∀ (A B) (→ (→ Any Boolean : B)
(→ (Rec R (U (Pairof A R) B))
@@ -38,70 +42,100 @@
(make-predicate (xlist . whole-τ-rest)))
v))
-(module+ test
- (require phc-toolkit)
+#;(: cons2 (∀ (A B ...) (→ A (List B ...) (List A B ...))))
+#;(define (cons2 a b)
+ (cons a b))
- (check-equal?:
- (((inst f-split-list Number (Listof Symbol))
- (make-predicate (Listof Symbol))) '(1 2 3 a b))
- : (List (Listof Number)
- (Listof Symbol))
- '((1 2 3) (a b))))
+(define-syntax (bounded-filter stx)
+ (syntax-case stx ()
+ [(_ 0 heads t l)
+ #'(values (list . heads) l)]
+ [(_ n (headᵢ …) t l)
+ #`(if ((make-predicate t) l)
+ (values (list headᵢ …) l)
+ (bounded-filter #,(sub1 (syntax-e #'n))
+ (headᵢ … (car l))
+ t
+ (cdr l)))]))
(define-syntax m-split-xlist*
- (syntax-parser
- #:literals (^)
- [(_ v [v₁ vᵢ …] {~seq τ₁ ^ *₁} {~seq τᵢ ^ *ᵢ} … #:rest r)
- ((λ (x) #;(displayln x) x)
- (template
- (begin
- (define split (m-split-list v (xlist τ₁ ^ *₁ (?@ τᵢ ^ *ᵢ) … #:rest r)))
- (define v₁ (car split))
- (m-split-xlist* (cadr split) [vᵢ …] (?@ τᵢ ^ *ᵢ) … #:rest r))))]
- [(_ v [vr] #:rest r)
- #'(define vr v)]))
-
-(module+ test
- (require phc-toolkit)
- (check-equal?:
- (let ()
- (m-split-xlist* '(1 2 3 d e f 7 8 9 . 42)
- [n1 s n2 r]
- Number ^ {*}
- Symbol ^ {*}
- Number ^ {*}
- #:rest Number)
- (list n1 s n2 r))
- : (List (Listof Number)
- (Listof Symbol)
- (Listof Number)
- Number)
- '((1 2 3) (d e f) (7 8 9) 42))
-
- (check-equal?:
- (let ()
- (m-split-xlist* '(1 2 3 d e f 7 8 9)
- [n1 s n2 nul]
- Number ^ {*}
- Symbol ^ {*}
- Number ^ {*}
- #:rest Null)
- (list n1 s n2 nul))
- : (List (Listof Number)
- (Listof Symbol)
- (Listof Number)
- Null)
- '((1 2 3) (d e f) (7 8 9) ())))
+ (λ (stx)
+ (displayln (syntax->datum stx))
+ ((syntax-parser
+ #:literals (^ + - * once ∞)
+ [(_ v [v₁ vᵢ …] τ₁ ^ (once) {~seq τᵢ ^ *ᵢ} … #:rest r)
+ (template
+ (begin
+ (define v₁ (car v))
+ (m-split-xlist* (cdr v) [vᵢ …] (?@ τᵢ ^ *ᵢ) … #:rest r)))]
+ [(_ v [v₁ vᵢ …] τ₁ ^ (power:nat) {~seq τᵢ ^ *ᵢ} … #:rest r)
+ #:with (tmp-car …) (map (λ _ (gensym 'car)) (range (syntax-e #'power)))
+ (template
+ (begin
+ (define-values (v₁ remaining-v)
+ (let* ([remaining-v v]
+ (?@ [tmp-car (car remaining-v)]
+ [remaining-v (cdr remaining-v)])
+ …)
+ (values (list tmp-car …) remaining-v)))
+ (m-split-xlist* remaining-v [vᵢ …] (?@ τᵢ ^ *ᵢ) … #:rest r)))]
+ [(_ v [v₁ vᵢ …] τ₁ ^ (power:nat +) {~seq τᵢ ^ *ᵢ} … #:rest r)
+ #:with (tmp-car …) (map (λ _ (gensym 'car)) (range (syntax-e #'power)))
+ (template
+ (begin
+ (define-values (v₁ remaining-v)
+ (let* ([remaining-v v]
+ (?@ [tmp-car (car remaining-v)]
+ [remaining-v (cdr remaining-v)])
+ …)
+ (define remaining-split
+ (m-split-list remaining-v
+ (xlist τ₁ ^ *₁ (?@ τᵢ ^ *ᵢ) … #:rest r)))
+ (values (list* tmp-car … (car remaining-split))
+ (cdr remaining-split))))
+ (m-split-xlist* remaining-v
+ [vᵢ …] (?@ τᵢ ^ *ᵢ) … #:rest r)))]
+ [(_ v [v₁ vᵢ …] τ₁ ^ (from:nat - to:nat) {~seq τᵢ ^ *ᵢ} … #:rest r)
+ #:with (tmp-car …) (map (λ _ (gensym 'car)) (range (syntax-e #'from)))
+ #:with difference (- (syntax-e #'to) (syntax-e #'from))
+ (when (< (syntax-e #'difference) 0)
+ (raise-syntax-error 'xlist "invalid range: m is larger than n" #'-))
+ (template
+ (begin
+ (define-values (v₁ remaining-v)
+ (let* ([remaining-v v]
+ (?@ [tmp-car (car remaining-v)]
+ [remaining-v (cdr remaining-v)])
+ …)
+ (define-values (before remaining-after)
+ (bounded-filter difference
+ (tmp-car …)
+ (xlist (?@ τᵢ ^ *ᵢ) … #:rest r)
+ remaining-v))
+ (values before
+ remaining-after)))
+ (m-split-xlist* remaining-v
+ [vᵢ …] (?@ τᵢ ^ *ᵢ) … #:rest r)))]
+ [(_ v [v₁ vᵢ …] τ₁ ^ *₁ {~seq τᵢ ^ *ᵢ} … #:rest r)
+ (template
+ (begin
+ (define split
+ (m-split-list v (xlist τ₁ ^ *₁ (?@ τᵢ ^ *ᵢ) … #:rest r)))
+ (define v₁ (car split))
+ (m-split-xlist* (cadr split) [vᵢ …] (?@ τᵢ ^ *ᵢ) … #:rest r)))]
+ [(_ v [vr] #:rest r)
+ #'(define vr v)])
+ stx)))
(define-match-expander split-xlist
(syntax-parser
#:literals (^)
[(_ pat . whole-τ)
- #:with ({~seq normalized-τᵢ ^ normalized-*ᵢ} … #:rest τ-rest)
- (normalize-xlist-type #'whole-τ this-syntax)
-
+ (define/with-parse ({~seq normalized-τᵢ ^ normalized-*ᵢ} … #:rest τ-rest)
+ (normalize-xlist-type #'whole-τ this-syntax))
+
(define-temp-ids "~a/v" (normalized-τᵢ …))
- ((λ (x) (displayln x) x)
+ ((λ (x) #;(pretty-write (syntax->datum x)) x)
(template
(app (λ (l)
(m-split-xlist* l
@@ -110,11 +144,3 @@
#:rest τ-rest)
(list normalized-τᵢ/v … rest/v))
pat)))]))
-
-(module+ test
- (check-equal?:
- (match '(1 2 3 d e f 7 8 9)
- [(split-xlist (list a b c d) Number⃰ Symbol⃰ Number⃰)
- (list d c b a)])
- : (List Null (Listof Number) (Listof Symbol) (Listof Number))
- '(() (7 8 9) (d e f) (1 2 3))))
-\ No newline at end of file
diff --git a/test/test-split-xlist-ann.rkt b/test/test-split-xlist-ann.rkt
@@ -0,0 +1,132 @@
+#lang typed/racket
+
+(require phc-toolkit
+ xlist
+ type-expander
+ "../split-xlist.rkt")
+
+
+(check-equal?:
+ (((inst f-split-list Number (Listof Symbol))
+ (make-predicate (Listof Symbol))) (ann '(1 2 3 a b)
+ (xlist Number⃰ Symbol⃰)))
+ : (List (Listof Number)
+ (Listof Symbol))
+ '((1 2 3) (a b)))
+
+(check-equal?:
+ (let ()
+ (m-split-xlist* (ann '(1 2 3 d e f 7 8 9 . 42)
+ (xlist Number⃰ Symbol⃰ Number⃰ . Number))
+ [n1 s n2 r]
+ Number ^ {*}
+ Symbol ^ {*}
+ Number ^ {*}
+ #:rest Number)
+ (list n1 s n2 r))
+ : (List (Listof Number)
+ (Listof Symbol)
+ (Listof Number)
+ Number)
+ '((1 2 3) (d e f) (7 8 9) 42))
+
+(check-equal?:
+ (let ()
+ (m-split-xlist* (ann '(1 2 3 d e f 7 8 9) (xlist Number⃰ Symbol⃰ Number⃰))
+ [n1 s n2 nul]
+ Number ^ {*}
+ Symbol ^ {*}
+ Number ^ {*}
+ #:rest Null)
+ (list n1 s n2 nul))
+ : (List (Listof Number)
+ (Listof Symbol)
+ (Listof Number)
+ Null)
+ '((1 2 3) (d e f) (7 8 9) ()))
+
+(check-equal?:
+ (match (ann '(1 2 3 d e f 7 8 9) (xlist Number⃰ Symbol⃰ Number⃰))
+ [(split-xlist (list a b c d) Number⃰ Symbol⃰ Number⃰)
+ (list d c b a)])
+ : (List Null (Listof Number) (Listof Symbol) (Listof Number))
+ '(() (7 8 9) (d e f) (1 2 3)))
+
+
+(check-equal?:
+ (match (ann '(1 2 3 d e f 7 8 9) (xlist Number Number⃰ Symbol⃰ Number⃰))
+ [(split-xlist (list a b c d e) Number Number⃰ Symbol⃰ Number⃰)
+ (list e d c b a)])
+ : (List Null (Listof Number) (Listof Symbol) (Listof Number) Number)
+ '(() (7 8 9) (d e f) (2 3) 1))
+
+(check-equal?:
+ (match (ann '(1 2 3 d e f 7 8 9) (xlist Number² Number⃰ Symbol⃰ Number⃰))
+ [(split-xlist (list a b c d e) Number² Number⃰ Symbol⃰ Number⃰)
+ (list e d c b a)])
+ : (List Null
+ (Listof Number)
+ (Listof Symbol)
+ (Listof Number)
+ (List Number Number))
+ '(() (7 8 9) (d e f) (3) (1 2)))
+
+(check-equal?:
+ (match (ann '(1 2 3 d e f 7 8 9) (xlist Number²⁻³ Symbol⃰ Number⃰))
+ [(split-xlist (list a b c d) Number²⁻³ Symbol⃰ Number⃰)
+ (list d c b a)])
+ : (List Null
+ (Listof Number)
+ (Listof Symbol)
+ (List* Number Number (U Null (List Number))))
+ '(() (7 8 9) (d e f) (1 2 3)))
+
+(check-equal?:
+ (match (ann '(1 2 3 4 5 d e f 7 8 9) (xlist Number³⁻⁵ Symbol⃰ Number⃰))
+ [(split-xlist (list a b c d) Number³⁻⁵ Symbol⃰ Number⃰)
+ (list d c b a)])
+ : (List Null
+ (Listof Number)
+ (Listof Symbol)
+ (List* Number Number Number (U Null
+ (List Number)
+ (List Number Number))))
+ '(() (7 8 9) (d e f) (1 2 3 4 5)))
+
+(check-equal?:
+ (match (ann '(1 2 3 4 d e f 7 8 9) (xlist Number³⁻⁵ Symbol⃰ Number⃰))
+ [(split-xlist (list a b c d) Number³⁻⁵ Symbol⃰ Number⃰)
+ (list d c b a)])
+ : (List Null
+ (Listof Number)
+ (Listof Symbol)
+ (List* Number Number Number (U Null
+ (List Number)
+ (List Number Number))))
+ '(() (7 8 9) (d e f) (1 2 3 4)))
+
+(check-equal?:
+ (match (ann '(1 2 3 d e f 7 8 9) (xlist Number³⁻⁵ Symbol⃰ Number⃰))
+ [(split-xlist (list a b c d) Number³⁻⁵ Symbol⃰ Number⃰)
+ (list d c b a)])
+ : (List Null
+ (Listof Number)
+ (Listof Symbol)
+ (xlist Number³⁻⁵))
+ '(() (7 8 9) (d e f) (1 2 3)))
+
+(check-equal?:
+ (match (ann '(1 2 3 4 d e f g 7 8 9) (xlist Number³⁻⁵ Symbol²⁻⁶ Number⃰))
+ [(split-xlist (list a b c d) Number³⁻⁵ Symbol²⁻⁶ Number⃰)
+ (list d c b a)])
+ : (List Null
+ (Listof Number)
+ (List* Symbol Symbol (U Null
+ (List Symbol)
+ (List Symbol Symbol)
+ (List Symbol Symbol Symbol)
+ (List Symbol Symbol Symbol Symbol)))
+ (List* Number Number Number (U Null
+ (List Number)
+ (List Number Number))))
+ '(() (7 8 9) (d e f g) (1 2 3 4)))
+\ No newline at end of file
diff --git a/test/test-split-xlist.rkt b/test/test-split-xlist.rkt
@@ -0,0 +1,130 @@
+#lang typed/racket
+
+(require phc-toolkit
+ xlist
+ type-expander
+ "../split-xlist.rkt")
+
+
+(check-equal?:
+ (((inst f-split-list Number (Listof Symbol))
+ (make-predicate (Listof Symbol))) '(1 2 3 a b))
+ : (List (Listof Number)
+ (Listof Symbol))
+ '((1 2 3) (a b)))
+
+(check-equal?:
+ (let ()
+ (m-split-xlist* '(1 2 3 d e f 7 8 9 . 42)
+ [n1 s n2 r]
+ Number ^ {*}
+ Symbol ^ {*}
+ Number ^ {*}
+ #:rest Number)
+ (list n1 s n2 r))
+ : (List (Listof Number)
+ (Listof Symbol)
+ (Listof Number)
+ Number)
+ '((1 2 3) (d e f) (7 8 9) 42))
+
+(check-equal?:
+ (let ()
+ (m-split-xlist* '(1 2 3 d e f 7 8 9)
+ [n1 s n2 nul]
+ Number ^ {*}
+ Symbol ^ {*}
+ Number ^ {*}
+ #:rest Null)
+ (list n1 s n2 nul))
+ : (List (Listof Number)
+ (Listof Symbol)
+ (Listof Number)
+ Null)
+ '((1 2 3) (d e f) (7 8 9) ()))
+
+(check-equal?:
+ (match '(1 2 3 d e f 7 8 9)
+ [(split-xlist (list a b c d) Number⃰ Symbol⃰ Number⃰)
+ (list d c b a)])
+ : (List Null (Listof Number) (Listof Symbol) (Listof Number))
+ '(() (7 8 9) (d e f) (1 2 3)))
+
+
+(check-equal?:
+ (match '(1 2 3 d e f 7 8 9)
+ [(split-xlist (list a b c d e) Number Number⃰ Symbol⃰ Number⃰)
+ (list e d c b a)])
+ : (List Null (Listof Number) (Listof Symbol) (Listof Number) Number)
+ '(() (7 8 9) (d e f) (2 3) 1))
+
+(check-equal?:
+ (match '(1 2 3 d e f 7 8 9)
+ [(split-xlist (list a b c d e) Number² Number⃰ Symbol⃰ Number⃰)
+ (list e d c b a)])
+ : (List Null
+ (Listof Number)
+ (Listof Symbol)
+ (Listof Number)
+ (List Number Number))
+ '(() (7 8 9) (d e f) (3) (1 2)))
+
+(check-equal?:
+ (match '(1 2 3 d e f 7 8 9)
+ [(split-xlist (list a b c d) Number²⁻³ Symbol⃰ Number⃰)
+ (list d c b a)])
+ : (List Null
+ (Listof Number)
+ (Listof Symbol)
+ (List* Number Number (U Null (List Number))))
+ '(() (7 8 9) (d e f) (1 2 3)))
+
+(check-equal?:
+ (match '(1 2 3 4 5 d e f 7 8 9)
+ [(split-xlist (list a b c d) Number³⁻⁵ Symbol⃰ Number⃰)
+ (list d c b a)])
+ : (List Null
+ (Listof Number)
+ (Listof Symbol)
+ (List* Number Number Number (U Null
+ (List Number)
+ (List Number Number))))
+ '(() (7 8 9) (d e f) (1 2 3 4 5)))
+
+(check-equal?:
+ (match '(1 2 3 4 d e f 7 8 9)
+ [(split-xlist (list a b c d) Number³⁻⁵ Symbol⃰ Number⃰)
+ (list d c b a)])
+ : (List Null
+ (Listof Number)
+ (Listof Symbol)
+ (List* Number Number Number (U Null
+ (List Number)
+ (List Number Number))))
+ '(() (7 8 9) (d e f) (1 2 3 4)))
+
+(check-equal?:
+ (match '(1 2 3 d e f 7 8 9)
+ [(split-xlist (list a b c d) Number³⁻⁵ Symbol⃰ Number⃰)
+ (list d c b a)])
+ : (List Null
+ (Listof Number)
+ (Listof Symbol)
+ (xlist Number³⁻⁵))
+ '(() (7 8 9) (d e f) (1 2 3)))
+
+(check-equal?:
+ (match '(1 2 3 4 d e f g 7 8 9)
+ [(split-xlist (list a b c d) Number³⁻⁵ Symbol²⁻⁶ Number⃰)
+ (list d c b a)])
+ : (List Null
+ (Listof Number)
+ (List* Symbol Symbol (U Null
+ (List Symbol)
+ (List Symbol Symbol)
+ (List Symbol Symbol Symbol)
+ (List Symbol Symbol Symbol Symbol)))
+ (List* Number Number Number (U Null
+ (List Number)
+ (List Number Number))))
+ '(() (7 8 9) (d e f g) (1 2 3 4)))
+\ No newline at end of file
diff --git a/untyped.rkt b/untyped.rkt
@@ -1,2 +1,2 @@
#lang reprovide
-(submod "main.rkt" untyped)
-\ No newline at end of file
+(submod "implementation.rkt" untyped)
+\ No newline at end of file
