diff --git a/main.rkt b/main.rkt index 1a9380d..a0d90d1 100644 --- a/main.rkt +++ b/main.rkt @@ -11,22 +11,24 @@ 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/stx - type-expander/expander)) + (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 + syntax/stx + type-expander/expander) + (for-meta 2 racket/base) + (for-meta 2 syntax/parse)) (provide xlist ^ ∞) @@ -34,6 +36,15 @@ (λ (stx) (raise-syntax-error 'stop "This is a private marker" stx))) (begin-for-syntax + (define-syntax ~^ + (pattern-expander + (λ (stx) + (syntax-case stx () + [(_ pat ...) + #`{~or {~seq #,(syntax-local-introduce #'^) pat ...} + {~seq {~optional #,(syntax-local-introduce #'^)} + (pat ...)}}])))) + (define number/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]+)$") (define */rx #px"^(.*?)⃰$") (define +/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]*)⁺$") @@ -132,7 +143,7 @@ (pattern {~and base {~not {~or ^ + *}}})) (define-splicing-syntax-class fixed-repeat - (pattern {~seq :base {~literal ^} power:number} + (pattern {~seq :base {~literal ^} power:nat} #:with (expanded …) (map (const #'base) (range (syntax-e #'power)))) (pattern {~literal stop} @@ -142,9 +153,9 @@ (define-syntax-class repeat-spec #:literals (* + - ∞) - (pattern (:number)) - (pattern ({~optional :number} +)) - (pattern ({~optional :number} - {~optional {~or ∞ :number}})) + (pattern (:nat)) + (pattern ({~optional :nat} +)) + (pattern ({~optional :nat} - {~optional {~or ∞ :nat}})) (pattern (*))) #;(define-splicing-syntax-class xlist-*-element @@ -157,52 +168,54 @@ (pattern :split-superscript-+-id) (pattern (~seq base :superscript-ish-+))) - (define (xlist-type context) + (define ((xlist-type context) stx) ;; The order of clauses is important, as they otherwise overlap. - (syntax-parser - #:context context - #:literals (^ * + - ∞ stop) - [() - #'Null] - [rest:not-stx-list - #'rest] - [(stop . rest) ;; eliminate the private marker - #'(xlist . rest)] - [(s:with-superscripts . rest) - #'(xlist s.expanded … . rest)] - [(:base {~optional ^} *) - #'(Listof base)] - [(:base {~optional ^} * . rest) - #:with R (gensym 'R) - #'(Rec R (U (Pairof base R) - (xlist . rest)))] - [(:base {~optional ^} + . rest) - #'(xlist base ^ 1 + . rest)] - [(:base ^ power:nat + . rest) - #'(xlist base ^ power stop base * . rest)] - [(:base ^ - . rest) - #'(xlist base ^ 0 - . rest)] - [(:base ^ from:nat - ∞ . rest) - #'(xlist base ^ from + . rest)] - [(:base ^ 0 - to:nat . rest) - #`(U . #,(foldl (λ (iteration u*) - (syntax-case u* () - [[(_ . base…rest) . _] - #`[(xlist base . base…rest) . #,u*]])) - #'[(xlist . 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" - #'-)) - #`(xlist base ^ from stop base ^ 0 - difference . rest)] - [(:base ^ from:nat - . rest) - ;; "-" is not followed by a number, nor by ∞, so default to ∞. - #`(xlist base ^ from - ∞ . rest)] - [(e:fixed-repeat . rest) - #'(List* e.expanded … (xlist . rest))])) + (define xl + (syntax-parser + #:context context + #:literals (^ * + - ∞ stop) + [() + #'Null] + [rest:not-stx-list + #'rest] + [(stop . rest) ;; eliminate the private marker + (xl #'rest)] + [(s:with-superscripts . rest) + (xl #'(s.expanded … . rest))] + [(:base {~optional ^} *) + #'(Listof base)] + [(:base {~optional ^} * . rest) + #:with R (gensym 'R) + #`(Rec R (U (Pairof base R) + #,(xl #'rest)))] + [(:base {~optional ^} + . rest) + (xl #'(base ^ 1 + . rest))] + [(:base ^ power:nat + . rest) + (xl #'(base ^ power stop base * . rest))] + [(:base ^ - . rest) + (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 stop 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)) @@ -267,11 +280,118 @@ #`(list-rest-ish [] base ellipsis #,(xl #'rest))] [(e:fixed-repeat . rest) #`(list-rest-ish [] e.expanded … #,(xl #'rest))])) - (xl stx))) + (xl stx)) + + #;("This is completely wrong" + ;; Expands 0 or more mandatory-doms for ->* + (define-splicing-syntax-class fixed-repeated-type + #:attributes ([mandatory 1]) + #:literals (^ * + - ∞ stop) + (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 (^ * + - ∞ stop) + (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 (^ * + - ∞ stop) + (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 (^ * + - ∞ stop) + (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 (^ * + - ∞ stop) + [(τᵢ: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)))) + #:match-expander (λ (stx) ((xlist-match stx) (stx-cdr stx))) + #;{#:call (λ (stx) ((xlist-builder stx) (stx-cdr stx)))}) (define-match-expander list-rest-ish (syntax-parser @@ -288,6 +408,9 @@ c₁ …)])) (when-typed - (provide xList) + (provide xList #;xListBuilder) (define-type-expander (xList stx) - ((xlist-type stx) (stx-cdr stx))))) + ((xlist-type stx) (stx-cdr stx))) + + #;(define-type-expander (xListBuilder stx) + ((xlist-builder-type stx) (stx-cdr stx))))) diff --git a/scribblings/xlist.scrbl b/scribblings/xlist.scrbl index 32a4628..e1cc916 100644 --- a/scribblings/xlist.scrbl +++ b/scribblings/xlist.scrbl @@ -41,10 +41,11 @@ To use the type expander, you must first require the (code:line number +) (code:line +) (code:line number - number) - (code:line number -) (code:line number - ∞) + (code:line number -) (code:line - number) (code:line -) + (code:line - ∞) (code:line *))]]]]{ 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, @@ -147,9 +148,10 @@ To use the type expander, you must first require the (code:line number +) (code:line +) (code:line number - number) - (code:line number -) (code:line number - ∞) + (code:line number -) (code:line - number) + (code:line - ∞) (code:line -) (code:line *) (code:line ...) @@ -197,5 +199,71 @@ To use the type expander, you must first require the @racketmodname[typed/racket] (rest values and spliced lists are the most likely to cause problems).} +@;{This is completely wrong. + @defform*[#:link-target? #f + #:literals (^ *) + [(xlist τᵢ … maybe-τⱼ τₖ … maybe-τₙ) + (xlist τᵢ … τₘᵥ)] + #:grammar + [(τᵢ type + fixed-repeated-type) + (τₘᵥ mandatory-variadic-repeated-type) + (maybe-τⱼ (code:line) + mandatory-bounded-variadic-repeated-type) + (τₖ optional-bounded-variadic-repeated-type) + (maybe-τₙ (code:line) + optional-variadic-repeated-type) + (fixed-repeated-type + (code:line type ^ fixed-repeat) + (code:line type ^ {fixed-repeat}) + (code:line type {fixed-repeat}) + (code:line type superscripted-fixed-repeat) + (code:line superscripted-fixed-id)) + (mandatory-bounded-variadic-repeated-type + (code:line type ^ mandatory-bounded-variadic-repeat) + (code:line type ^ {mandatory-bounded-variadic-repeat}) + (code:line type {mandatory-bounded-variadic-repeat}) + (code:line type superscripted-mandatory-bounded-variadic-repeat) + (code:line superscripted-mandatory-bounded-variadic-id)) + (optional-bounded-variadic-repeated-type + (code:line type ^ optional-bounded-variadic-repeat) + (code:line type ^ {optional-bounded-variadic-repeat}) + (code:line type {optional-bounded-variadic-repeat}) + (code:line type superscripted-optional-bounded-variadic-repeat) + (code:line superscripted-optional-bounded-variadic-id)) + (mandatory-variadic-repeated-type + (code:line type ^ mandatory-variadic-repeat) + (code:line type ^ {mandatory-variadic-repeat}) + (code:line type {mandatory-variadic-repeat}) + (code:line type superscripted-mandatory-variadic-repeat) + (code:line superscripted-mandatory-variadic-id) + (code:line type +)) + (optional-variadic-repeated-type + (code:line type ^ optional-variadic-repeat) + (code:line type ^ {optional-variadic-repeat}) + (code:line type {optional-variadic-repeat}) + (code:line type superscripted-optional-variadic-repeat) + (code:line superscripted-optional-variadic-id) + (code:line type *)) + (fixed-repeat (code:line number) + (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 +) + (code:line +) + (code:line number -) + (code:line number - ∞)) + (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).} +} + @include-section{xlist-untyped.scrbl} @include-section{identifiers.scrbl} \ No newline at end of file diff --git a/test/test-type.rkt b/test/test-type.rkt index 2e4d0ed..46f100c 100644 --- a/test/test-type.rkt +++ b/test/test-type.rkt @@ -111,6 +111,16 @@ (ann '(1 1 1) (xlist Number ^ 3 +)) (void)) +(test-begin + "(xlist Number ^ x)" + (ann '() (xlist Number ^ 0)) + (ann '(1) (xlist Number ^ 1)) + (ann '(1 1) (xlist Number ^ 2)) + (ann '(1 1 1) (xlist Number ^ 3)) + (ann '(1 1 1 1) (xlist Number ^ 4)) + (ann '(1 1 1 1 1) (xlist Number ^ 5)) + (void)) + (test-begin "(xlist Number ^ x - y)" (ann '() (xlist Number ^ -))