Documented split-xlist, improved prcision of inference for fixed-length and bounded-length sublists
This commit is contained in:
Georges Dupéron
parent
cd704f574f
commit
b672228539
483
implementation.rkt
Normal file
483
implementation.rkt
Normal 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
480
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)
|
||||
11
once-identifier.rkt
Normal file
11
once-identifier.rkt
Normal 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)))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
55
scribblings/split-xlist.scrbl
Normal file
55
scribblings/split-xlist.scrbl
Normal 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)]}]}
|
||||
|
|
@ -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|.}
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
158
split-xlist.rkt
158
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))))
|
||||
132
test/test-split-xlist-ann.rkt
Normal file
132
test/test-split-xlist-ann.rkt
Normal 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
130
test/test-split-xlist.rkt
Normal 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)))
|
||||
|
|
@ -1,2 +1,2 @@
|
|||
#lang reprovide
|
||||
(submod "main.rkt" untyped)
|
||||
(submod "implementation.rkt" untyped)
|
||||
Loading…
Reference in New Issue
Block a user