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