#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] [... …]) 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 ∘ compose) (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 {~optional {~^ once}} . 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 (^ * + - ∞ once) [() #'(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} . rest) #`(list-rest-ish [] base #|no ellipsis|# #,(xl #'rest))] [(:base {~^ power:nat} . rest) #: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)))))