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

Documented split-xlist, improved prcision of inference for fixed-length and bounded-length sublists

Browse Source
This commit is contained in:
Georges Dupéron 2016-09-25 15:53:21 +02:00
parent cd704f574f
commit b672228539
11 changed files with 978 additions and 585 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

483
implementation.rkt Normal file
View File

@ -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)))))

480
main.rkt
View File

@ -1,475 +1,5 @@
#lang typed/racket/base #lang typed/racket
(require (submod "implementation.rkt" typed)
(require phc-toolkit/typed-untyped) "split-xlist.rkt")
(define-typed/untyped-modules #:no-test (provide (all-from-out (submod "implementation.rkt" typed))
(require racket/require split-xlist)
(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)))))

11
once-identifier.rkt Normal file
View File

@ -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)))

5
scribblings/identifiers.scrbl
View File

@ -10,10 +10,13 @@
#:link-target? #f #:link-target? #f
#:use-sources #:use-sources
[(lib "xlist/infinity-identifier.rkt") [(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[^]{This identifier can only be used within xlist forms.}
@defidform[once]{This identifier can only be used within xlist forms.}
@defidform[∞]{ @defidform[∞]{
This identifier is meant to be used within xlist forms, but is also equal to 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 @racket[+inf.0] as a convenience. In the future, this package will make it

55
scribblings/split-xlist.scrbl Normal file
View File

@ -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)]}]}

2
scribblings/xlist-untyped.scrbl
View File

@ -7,6 +7,6 @@
@title{Untyped versions of xlist} @title{Untyped versions of xlist}
@defmodule[xlist/untyped @defmodule[xlist/untyped
#:use-sources #:use-sources
[(submod (lib "xlist/main.rkt") untyped)]] [(submod (lib "xlist/implementation.rkt") untyped)]]
@defidform[xlist]{Untyped version of @|typed:xlist|.} @defidform[xlist]{Untyped version of @|typed:xlist|.}

105
scribblings/xlist.scrbl
View File

@ -11,6 +11,8 @@
@title[#:style (with-html5 manual-doc-style)]{xlist} @title[#:style (with-html5 manual-doc-style)]{xlist}
@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]] @author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]]
@(define ddd (racket ...))
@defmodule[xlist] @defmodule[xlist]
Fancy lists, with bounded or unbounded repetition of elements. Can be used as a 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" [@defform*[#:kind "type-expander"
[(xList τᵢ ...) [(xList τᵢ ...)
(xList τᵢ ... . rest) (xList τᵢ ... . rest)
(xList τᵢ ... #:rest . rest)]] (xList τᵢ ... #:rest rest)]]
@defform*[#:kind "type-expander" @defform*[#:kind "type-expander"
#:literals (^ *) #:literals (^ * + - ∞ once)
[(xlist τᵢ ...) [(xlist τᵢ ...)
(xlist τᵢ ... . rest)] (xlist τᵢ ... . rest)]
#:grammar #:grammar
@ -38,22 +40,26 @@ To use the type expander, you must first require the
(code:line type *) (code:line type *)
(code:line type +) (code:line type +)
(code:line superscripted-id)) (code:line superscripted-id))
(repeat (code:line number) (repeat (code:line once)
(code:line number +) (code:line nat)
(code:line nat +)
(code:line +) (code:line +)
(code:line number - number) (code:line nat - nat)
(code:line number - ∞) (code:line nat - ∞)
(code:line number -) (code:line nat -)
(code:line - number) (code:line - nat)
(code:line -) (code:line -)
(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 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,
the following two types are equivalent: the following two types are equivalent:
@racketblock[ @racketblock[
(xList Number ^ 3 Symbol String ^ 2) (xList Number ^ 3 Symbol String ^ 2)
(List Number Number Number Symbol String String)] (List Number Number Number Symbol String String)]
The notation @racket[type *] indicates that the given type may be repeated zero 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[ @racketblock[
(xList Number * Symbol String *) (xList Number * Symbol String *)
(Rec R1 (U (Pairof Number R1) (Rec R1 (U (Pairof Number R1)
(List* Symbol (Rec R2 (U (Pairof String R2) (List* Symbol (Rec R2 (U (Pairof String R2)
Null)))))] Null)))))]
@ -70,17 +77,24 @@ To use the type expander, you must first require the
@racketblock[ @racketblock[
(xList Number ^ {2 +} String) (xList Number ^ {2 +} String)
(List* Number Number (Rec R1 (U (Pairof Number R1) (List* Number Number (Rec R1 (U (Pairof Number R1)
(List String))))] (List String))))]
When the number preceding @racket[+] is omitted, it defaults to @racket[1]. 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 The notation @racket[type ^ _n - _m] indicates that the given type may be
repeated between @racket[_n] (inclusive) and @racket[_m] (inclusive) times. repeated between @racket[_n] (inclusive) and @racket[_m] (inclusive) times.
Therefore, the following two types are equivalent: Therefore, the following two types are equivalent:
@racketblock[ @racketblock[
(xList Number ^ {2 - 5} String) (xList Number ^ {2 - 5} String)
(U (List Number Number String) (U (List Number Number String)
(List Number Number Number String) (List Number Number Number String)
(List Number 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" @defform*[#:kind "match-expander"
#:link-target? #f #:link-target? #f
#:literals (^ *) #:literals (^ * + - ...+ ∞)
[(xlist patᵢ ...) [(xlist patᵢ ...)
(xlist patᵢ ... . rest) (xlist patᵢ ... . rest)
(xlist patᵢ ... #:rest . rest)] (xlist patᵢ ... #:rest rest)]
#:grammar #:grammar
[(patᵢ pattern-or-spliced [(patᵢ pattern-or-spliced
repeated-pattern 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 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 ooo)
(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 once)
(code:line number +) (code:line nat)
(code:line nat +)
(code:line +) (code:line +)
(code:line number - number) (code:line nat - nat)
(code:line number - ∞) (code:line nat - ∞)
(code:line number -) (code:line nat -)
(code:line - number) (code:line - nat)
(code:line - ∞) (code:line - ∞)
(code:line -) (code:line -)
(code:line *) (code:line *)
(code:line ...) (code:line ooo))
(code:line ..k) (ooo #,ddd
(code:line ____) ..k
(code:line ___k) ____
(code:line ...+))]]{ ___k
...+)]
#:contracts
[(nat (syntax/c exact-nonnegative-integer?))]]{
This match expander works like the @racket[xList] type expander, but instead This match expander works like the @racket[xList] type expander, but instead
controls the repetition of match patterns. The repeated patterns are not 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 attributes. Instead, the @racket[repeat] forms control the number of times a
pattern may be bound, like @racket[...] does. 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 For convenience and compatibility with existing match patterns, the following
equivalences are provided: equivalences are provided:
@itemlist[ @itemlist[
@ -191,6 +210,7 @@ To use the type expander, you must first require the
@racketblock[ @racketblock[
(xlist number?³⁻⁵ ,@(list-no-order number? string?) symbol?⁺) (xlist number?³⁻⁵ ,@(list-no-order number? string?) symbol?⁺)
(append (and (list number? ...) (app length (? (between/c 3 5)))) (append (and (list number? ...) (app length (? (between/c 3 5))))
(list-no-order number? string?) (list-no-order number? string?)
(list symbol? ..1))] (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 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 construction @racket[xlist] tries to avoid to generate such patterns, a few of
the patterns supported by @racket[xlist] will not work in the patterns supported by @racket[xlist] will not work in
@racketmodname[typed/racket] (rest values and spliced lists are the most likely @racketmodname[typed/racket] (rest values and spliced lists are the most
to cause problems).} 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. @;{This is completely wrong.
@defform*[#:link-target? #f @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 type superscripted-optional-variadic-repeat)
(code:line superscripted-optional-variadic-id) (code:line superscripted-optional-variadic-id)
(code:line type *)) (code:line type *))
(fixed-repeat (code:line number) (fixed-repeat (code:line nat)
(code:line from - to (code:comment "from = to"))) (code:line from - to (code:comment "from = to")))
(mandatory-bounded-variadic-repeat (code:line number - number)) (mandatory-bounded-variadic-repeat (code:line nat - nat))
(optional-bounded-variadic-repeat (code:line 0 - number) (optional-bounded-variadic-repeat (code:line 0 - nat)
(code:line - number)) (code:line - nat))
(mandatory-variadic-repeat (code:line number +) (mandatory-variadic-repeat (code:line nat +)
(code:line +) (code:line +)
(code:line number -) (code:line nat -)
(code:line number - ∞)) (code:line nat - ∞))
(optional-variadic-repeat (code:line 0 - ∞) (optional-variadic-repeat (code:line 0 - ∞)
(code:line 0 -) (code:line 0 -)
(code:line - ∞) (code:line - ∞)
(code:line -) (code:line -)
(code:line *))]]{ (code:line *))]]{
Macro form which returns a builder function for a list with the given type. 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 The simplified syntax compared to @racket[xList] is due to the fact that there
are some function types that Typed/Racket cannot express (yet).} 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?]{ @defproc[(normalize-xlist-type [stx syntax?] [context syntax?]) syntax?]{
Normalizes the xlist type. The normalized form has one type followed by ^ 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 followed by a repeat within braces (a @racket[type] without a repeat is
original type. It always finishes with #:rest rest-type. This function also transformed into @racket[type ^ {once}]) for each position in the original
performs a few simplifications on the type, like transforming @racket[^ {3 -}] type. It always finishes with #:rest rest-type. This function also performs a
into @racket[^ {3 +}], and transforming @racket[^ {0 -}] into @racket[^ {*}].} 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{xlist-untyped.scrbl}
@include-section{identifiers.scrbl} @include-section{identifiers.scrbl}

148
split-xlist.rkt
View File

@ -2,12 +2,16 @@
(require (for-syntax phc-toolkit/untyped (require (for-syntax phc-toolkit/untyped
syntax/parse syntax/parse
syntax/parse/experimental/template) syntax/parse/experimental/template
xlist racket/pretty
racket/list)
(submod "implementation.rkt" typed)
"caret-identifier.rkt" "caret-identifier.rkt"
"infinity-identifier.rkt"
"once-identifier.rkt"
type-expander) type-expander)
(provide f-split-list) (provide split-xlist f-split-list m-split-xlist*)
(: f-split-list (∀ (A B) (→ (→ Any Boolean : B) (: f-split-list (∀ (A B) (→ (→ Any Boolean : B)
(→ (Rec R (U (Pairof A R) B)) (→ (Rec R (U (Pairof A R) B))
@ -38,70 +42,100 @@
(make-predicate (xlist . whole-τ-rest))) (make-predicate (xlist . whole-τ-rest)))
v)) v))
(module+ test #;(: cons2 (∀ (A B ...) (→ A (List B ...) (List A B ...))))
(require phc-toolkit) #;(define (cons2 a b)
(cons a b))
(check-equal?: (define-syntax (bounded-filter stx)
(((inst f-split-list Number (Listof Symbol)) (syntax-case stx ()
(make-predicate (Listof Symbol))) '(1 2 3 a b)) [(_ 0 heads t l)
: (List (Listof Number) #'(values (list . heads) l)]
(Listof Symbol)) [(_ n (headᵢ …) t l)
'((1 2 3) (a b)))) #`(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* (define-syntax m-split-xlist*
(syntax-parser (λ (stx)
#:literals (^) (displayln (syntax->datum stx))
[(_ v [v₁ vᵢ …] {~seq τ₁ ^ *₁} {~seq τᵢ ^ *ᵢ} … #:rest r) ((syntax-parser
((λ (x) #;(displayln x) x) #:literals (^ + - * once ∞)
[(_ v [v₁ vᵢ …] τ₁ ^ (once) {~seq τᵢ ^ *ᵢ} … #:rest r)
(template (template
(begin (begin
(define split (m-split-list v (xlist τ₁ ^ *₁ (?@ τᵢ ^ *ᵢ) … #:rest r))) (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)) (define v₁ (car split))
(m-split-xlist* (cadr split) [vᵢ …] (?@ τᵢ ^ *ᵢ) … #:rest r))))] (m-split-xlist* (cadr split) [vᵢ …] (?@ τᵢ ^ *ᵢ) … #:rest r)))]
[(_ v [vr] #:rest r) [(_ v [vr] #:rest r)
#'(define vr v)])) #'(define vr v)])
stx)))
(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) ())))
(define-match-expander split-xlist (define-match-expander split-xlist
(syntax-parser (syntax-parser
#:literals (^) #:literals (^)
[(_ pat . whole-τ) [(_ pat . whole-τ)
#:with ({~seq normalized-τᵢ ^ normalized-*ᵢ} … #:rest τ-rest) (define/with-parse ({~seq normalized-τᵢ ^ normalized-*ᵢ} … #:rest τ-rest)
(normalize-xlist-type #'whole-τ this-syntax) (normalize-xlist-type #'whole-τ this-syntax))
(define-temp-ids "~a/v" (normalized-τᵢ …)) (define-temp-ids "~a/v" (normalized-τᵢ …))
((λ (x) (displayln x) x) ((λ (x) #;(pretty-write (syntax->datum x)) x)
(template (template
(app (λ (l) (app (λ (l)
(m-split-xlist* l (m-split-xlist* l
@ -110,11 +144,3 @@
#:rest τ-rest) #:rest τ-rest)
(list normalized-τᵢ/v … rest/v)) (list normalized-τᵢ/v … rest/v))
pat)))])) 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))))

132
test/test-split-xlist-ann.rkt Normal file
View File

@ -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)))

130
test/test-split-xlist.rkt Normal file
View File

@ -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)))

2
untyped.rkt
View File

@ -1,2 +1,2 @@
#lang reprovide #lang reprovide
(submod "main.rkt" untyped) (submod "implementation.rkt" untyped)