implementation.rkt (20349B)
1 #lang typed/racket/base 2 3 (require phc-toolkit/typed-untyped) 4 (define-typed/untyped-modules #:no-test 5 (require racket/require 6 (only-in type-expander define-type-expander) 7 multi-id 8 "caret-identifier.rkt" 9 "infinity-identifier.rkt" 10 "once-identifier.rkt" 11 "between.rkt" 12 match-string 13 racket/match 14 (only-in phc-toolkit/typed-untyped when-typed) 15 (only-in syntax/parse ...+) 16 (for-syntax "caret-identifier.rkt" 17 (rename-in racket/base 18 [* mul] 19 [+ plus] 20 [compose ∘] 21 [... …]) 22 racket/syntax 23 racket/match 24 racket/contract 25 racket/list 26 racket/function 27 racket/string 28 (rename-in syntax/parse 29 [...+ …+]) 30 syntax/parse/experimental/template 31 (subtract-in syntax/stx phc-toolkit/untyped) 32 type-expander/expander 33 phc-toolkit/untyped 34 racket/pretty) 35 (for-meta 2 racket/base) 36 (for-meta 2 syntax/parse)) 37 38 (provide xlist ^ ∞ once (for-syntax normalize-xlist-type)) 39 40 (begin-for-syntax 41 (define-syntax ~^ 42 (pattern-expander 43 (λ (stx) 44 (syntax-case stx () 45 [(_ pat ...) 46 #`{~or {~seq {~literal ^} pat ...} 47 {~seq {~optional {~literal ^}} 48 (pat ...)}}])))) 49 50 (define number/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]+)$") 51 (define */rx #px"^(.*?)⃰$") 52 (define +/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]*)⁺$") 53 (define -/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]*)⁻([⁰¹²³⁴⁵⁶⁷⁸⁹]*)$") 54 55 (define (regexp-match/c rx) 56 (and/c string? (λ (s) (regexp-match? rx s)))) 57 58 (define (id/c id) 59 (and/c identifier? (λ (i) (free-identifier=? i id)))) 60 61 62 (define string-superscript-number/c (regexp-match/c number/rx)) 63 (define string-superscript-*/c (regexp-match/c */rx)) 64 (define string-superscript-+/c (regexp-match/c +/rx)) 65 (define string-superscript--/c (regexp-match/c -/rx)) 66 67 (define string-superscript-any/c 68 (or/c string-superscript-number/c 69 string-superscript-*/c 70 string-superscript-+/c 71 string-superscript--/c)) 72 73 (define normal-rest/c 74 (or/c (list/c (id/c #'^) exact-nonnegative-integer?) 75 (list/c (id/c #'^) (id/c #'*)) 76 (list/c (id/c #'^) exact-nonnegative-integer? (id/c #'+)) 77 (list/c (id/c #'^) 78 exact-nonnegative-integer? 79 (id/c #'-) 80 (or/c (id/c #'∞) exact-nonnegative-integer?)))) 81 82 (define normal-string/c (cons/c string? 83 normal-rest/c)) 84 (define normal-id/c (cons/c (and/c identifier? (not/c (syntax/c '||))) 85 normal-rest/c)) 86 87 (define/contract (string-superscripts->number superscripts) 88 (-> string-superscript-number/c exact-nonnegative-integer?) 89 (string->number 90 (string-join 91 (map (match-lambda ["⁰" "0"] ["¹" "1"] ["²" "2"] ["³" "3"] ["⁴" "4"] 92 ["⁵" "5"] ["⁶" "6"] ["⁷" "7"] ["⁸" "8"] ["⁹" "9"]) 93 (map string (string->list superscripts)))))) 94 95 (define/contract (string-superscripts->normal superscripts) 96 (-> string-superscript-any/c 97 normal-string/c) 98 (define ->num string-superscripts->number) 99 (match superscripts 100 ;; Order is important, the regexpes overlap 101 [(regexp -/rx (list _ base n m)) 102 (list base 103 #'^ 104 (if (string=? n "") 0 (->num n)) 105 #'- 106 (if (string=? m "") #'∞ (->num m)))] 107 [(regexp number/rx (list _ base n)) (list base #'^ (->num n))] 108 [(regexp */rx (list _ base)) (list base #'^ #'*)] 109 [(regexp +/rx (list _ base n)) 110 (list base #'^ (if (string=? n "") 1 (->num n)) #'+)])) 111 112 (define/contract (id-superscripts->normal id) 113 (-> identifier? (or/c #f normal-id/c)) 114 (define str (symbol->string (syntax-e id))) 115 (if (string-superscript-any/c str) 116 (match (string-superscripts->normal str) 117 [(cons "" _) #f] 118 [(cons base rest) (cons (format-id id "~a" base) rest)]) 119 #f)) 120 121 (define/contract (only-superscripts->normal id) 122 (-> identifier? (or/c #f normal-rest/c)) 123 (define str (symbol->string (syntax-e id))) 124 (if (string-superscript-any/c str) 125 (match (string-superscripts->normal str) 126 [(cons "" rest) rest] 127 [_ #f]) 128 #f)) 129 130 (define-splicing-syntax-class with-superscripts 131 (pattern (~seq id:id) 132 #:do [(define normal (id-superscripts->normal #'id))] 133 #:when normal 134 #:with (expanded …) normal) 135 (pattern (~seq base:expr super:id) 136 #:do [(define normal (only-superscripts->normal #'super))] 137 #:when normal 138 #:with (expanded …) (cons #'base normal))) 139 140 (define-syntax-class not-stx-pair 141 (pattern {~not (_ . _)})) 142 143 (define-syntax-class base 144 #:literals (^ + *) 145 (pattern {~and base {~not {~or ^ + *}}})) 146 147 (define-splicing-syntax-class fixed-repeat 148 (pattern {~seq :base {~^ power:nat}} 149 #:with (expanded …) (map (const #'base) 150 (range (syntax-e #'power)))) 151 (pattern e:base 152 #:with (expanded …) #'(e))) 153 154 (define-syntax-class repeat-spec 155 #:literals (* + - ∞) 156 (pattern (:nat)) 157 (pattern ({~optional :nat} +)) 158 (pattern ({~optional :nat} - {~optional {~or ∞ :nat}})) 159 (pattern (*))) 160 161 #;(define-splicing-syntax-class xlist-*-element 162 #:attributes (base) 163 (pattern :split-superscript-*-id) 164 (pattern (~seq base :superscript-ish-*))) 165 166 #;(define-splicing-syntax-class xlist-+-element 167 #:attributes (base min) 168 (pattern :split-superscript-+-id) 169 (pattern (~seq base :superscript-ish-+))) 170 171 (define ((xlist-type context) stx) 172 ;; The order of clauses is important, as they otherwise overlap. 173 (define xl 174 (syntax-parser 175 #:context context 176 #:literals (^ * + - ∞ once) 177 [() 178 #'Null] 179 [rest:not-stx-pair 180 #'rest] 181 [(#:rest rest) 182 #'rest] 183 [(s:with-superscripts . rest) 184 (xl #'(s.expanded … . rest))] 185 [(:base {~or * {~^ *}}) 186 #'(Listof base)] 187 [(:base {~or * {~^ *}} . rest) 188 #:with R (gensym 'R) 189 #`(Rec R (U (Pairof base R) 190 #,(xl #'rest)))] 191 [(:base {~or + {~^ +}} . rest) 192 (xl #'(base ^ 1 + . rest))] 193 [(:base {~^ power:nat +} . rest) 194 (xl #'(base ^ {power} base * . rest))] 195 [(:base {~optional ^} {-} . rest) ;; If it is ^ {-}, the next thing may be a number but should be used as a pattern, not a repeat 196 (xl #'(base ^ * . rest))] 197 [(:base ^ - . rest) ;; not with {}, check if there's stuff after 198 (xl #'(base ^ 0 - . rest))] 199 [(:base {~^ from:nat - ∞} . rest) 200 (xl #'(base ^ from + . rest))] 201 [(:base {~^ 0 - to:nat} . rest) 202 #`(U . #,(foldl (λ (iteration u*) 203 (syntax-case u* () 204 [[(_ . base…rest) . _] 205 #`[(List* base . base…rest) . #,u*]])) 206 #`[(List* #,(xl #'rest))] 207 (range (syntax-e #'to))))] 208 [(:base {~^ from:nat - to:nat} . rest) 209 #:with difference (- (syntax-e #'to) (syntax-e #'from)) 210 (when (< (syntax-e #'difference) 0) 211 (raise-syntax-error 'xlist 212 "invalid range: m is larger than n" 213 #'-)) 214 (xl #'(base ^ {from} base ^ 0 - difference . rest))] 215 [(:base {~^ from:nat -} . rest) 216 ;; "-" is not followed by a number, nor by ∞, so default to ∞. 217 (xl #'(base ^ from - ∞ . rest))] 218 [(:base {~^ power:nat} . rest) 219 #:with (expanded …) (map (const #'base) 220 (range (syntax-e #'power))) 221 #`(List* expanded … #,(xl #'rest))] 222 [(:base {~optional {~^ once}} . rest) 223 #`(Pairof base #,(xl #'rest))])) 224 (xl stx)) 225 226 ;; normalize the xlist type 227 ;; The normalized form has one type followed by ^ followed by a repeat 228 ;; within braces (possibly {1}) for each position in the original type. It 229 ;; always finishes with #:rest rest-type 230 231 (define (normalize-xlist-type stx context) 232 (define nt 233 (syntax-parser 234 #:context context 235 #:literals (^ * + - ∞ once) 236 [() 237 #'(#:rest Null)] 238 [rest:not-stx-pair 239 #'(#:rest rest)] 240 [(#:rest rest) 241 #'(#:rest rest)] 242 [(s:with-superscripts . rest) 243 (nt #'(s.expanded … . rest))] 244 [(:base {~or * {~^ *}} . rest) 245 #`(base ^ {*} . #,(nt #'rest))] 246 [(:base {~or + {~^ +}} . rest) 247 #`(base ^ {1 +} . #,(nt #'rest))] 248 [(:base {~^ 0 +} . rest) 249 #`(base ^ {*} . #,(nt #'rest))] 250 [(:base {~^ power:nat +} . rest) 251 #`(base ^ {power +} . #,(nt #'rest))] 252 [(:base {~optional ^} {-} . rest) 253 #`(base ^ {*} . #,(nt #'rest))] 254 [(:base ^ - . rest) ;; not with {}, check if there's stuff after 255 (nt #'(base ^ 0 - . rest))] 256 [(:base {~^ 0 - ∞} . rest) 257 #`(base ^ {*} . #,(nt #'rest))] 258 [(:base {~^ from:nat - ∞} . rest) 259 (nt #'(base ^ from + . rest))] 260 [(:base {~^ from:nat - to:nat} . rest) 261 #`(base ^ {from - to} . #,(nt #'rest))] 262 [(:base {~^ from:nat -} . rest) 263 ;; "-" is not followed by a number, nor by ∞, so default to ∞. 264 (nt #'(base ^ from - ∞ . rest))] 265 [(:base {~^ power:nat} . rest) 266 #`(base ^ {power} . #,(nt #'rest))] 267 [(:base {~optional {~^ once}} . rest) 268 #`(base ^ {once} . #,(nt #'rest))])) 269 (nt stx)) 270 271 272 273 ;; Match 274 275 (define-syntax-class xlist-pattern 276 (pattern (({~literal unquote-splicing} splice)) 277 #:with expanded #'splice) 278 (pattern (pat) 279 #:with expanded #'(list pat))) 280 281 (define ((xlist-match context) stx) 282 ;; The order of clauses is important, as they otherwise overlap. 283 (define/with-syntax ooo #'(... ...)) 284 (define xl 285 (syntax-parser 286 #:context context 287 #:literals (^ * + - ∞ once) 288 [() 289 #'(list)] 290 [rest:not-stx-pair 291 #'rest] 292 [(#:rest rest) 293 #'rest] 294 [(({~literal unquote-splicing} splice) …+ . rest) 295 #`(append splice … #,(xl #'rest))] 296 [(s:with-superscripts . rest) 297 (xl #'(s.expanded … . rest))] 298 [(:base {~or * {~^ *}} . rest) 299 #:with R (gensym 'R) 300 #`(list-rest-ish [] base ooo #,(xl #'rest))] 301 [(:base {~or + {~^ +}} . rest) 302 (xl #'(base ^ 1 + . rest))] 303 [(:base {~^ power:nat +} . rest) 304 #:with ..power (format-id #'power "..~a" (syntax-e #'power)) 305 #`(list-rest-ish [] base ..power #,(xl #'rest))] 306 [(:base {~optional ^} {-} . rest) ;; If it is ^ {-}, the next thing may be a number but should be used as a pattern, not a repeat 307 (xl #'(base ^ {*} . rest))] 308 [(:base ^ - . rest) ;; not with {}, check if there's stuff after 309 (xl #'(base ^ 0 - . rest))] 310 [(:base {~^ from:nat - ∞} . rest) 311 (xl #'(base ^ {from +} . rest))] 312 [(:base {~^ from:nat - to:nat} . rest) 313 #:with occurrences (gensym 'occurrences) 314 (when (> (syntax-e #'from) (syntax-e #'to)) 315 (raise-syntax-error 'xlist 316 "invalid range: m is larger than n" 317 #'-)) 318 #`(list-rest-ish 319 [(? (λ (_) ((between/c from to) (length occurrences))))] 320 (and occurrences base) ooo 321 #,(xl #'rest))] 322 [(:base {~^ from:nat -} . rest) 323 ;; "-" is not followed by a number, nor by ∞, so default to ∞. 324 (xl #'(base ^ {from - ∞} . rest))] 325 ;; aliases 326 [(:base {~or {~literal ...} {~literal ___} 327 {~^ {~literal ...}} {~^ {~literal ___}}} 328 . rest) 329 #`(list-rest-ish [] base ooo #,(xl #'rest))] 330 [(:base {~or {~literal ...+} {~^ {~literal ...+}}} . rest) 331 #`(list-rest-ish base ..1 #,(xl #'rest))] 332 [(:base {~or ellipsis:id {~^ ellipsis:id}} . rest) 333 #:when (regexp-match? #px"^\\.\\.[0-9]+$" 334 (symbol->string (syntax-e #'ellipsis))) 335 #`(list-rest-ish [] base ellipsis #,(xl #'rest))] 336 [(:base {~^ once} . rest) 337 #`(list-rest-ish [] base #|no ellipsis|# #,(xl #'rest))] 338 [(:base {~^ power:nat} . rest) 339 #:with occurrences (gensym 'occurrences) 340 #`(list-rest-ish [(? (λ (_) (= (length occurrences) power)))] 341 (and occurrences base) ooo 342 #,(xl #'rest))] 343 [(:base . rest) 344 #`(list-rest-ish [] base #|no ellipsis|# #,(xl #'rest))])) 345 (xl stx)) 346 347 #;("This is completely wrong" 348 ;; Expands 0 or more mandatory-doms for ->* 349 (define-splicing-syntax-class fixed-repeated-type 350 #:attributes ([mandatory 1]) 351 #:literals (^ * + - ∞) 352 (pattern {~seq :base {~^ power:nat}} 353 #:with (mandatory …) (map (const #'base) 354 (range (syntax-e #'power)))) 355 (pattern {~seq :base {~^ from:nat - to:nat}} 356 #:when (= (syntax-e #'from) (syntax-e #'to)) 357 #:with (mandatory …) (map (const #'base) 358 (range (syntax-e #'from)))) 359 (pattern s:with-superscripts 360 #:with (:fixed-repeated-type) #'(s.expanded …)) 361 (pattern (~seq {~peek-not :mandatory-bounded-variadic-repeated-type} 362 {~peek-not :optional-bounded-variadic-repeated-type} 363 {~peek-not :mandatory-variadic-repeated-type} 364 {~peek-not :optional-variadic-repeated-type} 365 :base) 366 #:with (mandatory …) #'(base))) 367 368 ;; Expands to 0 or more mandatory-doms and 0 or more optional-doms 369 ;; for ->* 370 (define-splicing-syntax-class mandatory-bounded-variadic-repeated-type 371 #:attributes ([mandatory 1] [optional 1]) 372 #:literals (^ * + - ∞) 373 (pattern {~seq :base {~^ {~and from:nat {~not 0}} - to:nat}} 374 #:with (mandatory …) (map (const #'base) 375 (range (syntax-e #'from))) 376 #:with (optional …) (map (const #'base) 377 (range (- (syntax-e #'to) 378 (syntax-e #'from))))) 379 (pattern s:with-superscripts 380 #:with (:mandatory-bounded-variadic-repeated-type) 381 #'(s.expanded …))) 382 383 ;; Expands to 1 or more optional-doms for ->* 384 (define-splicing-syntax-class optional-bounded-variadic-repeated-type 385 #:attributes ([optional 1]) 386 #:literals (^ * + - ∞) 387 (pattern {~seq :base {~^ {~optional 0} - to:nat}} 388 #:with (optional …) (map (const #'base) 389 (range (syntax-e #'to)))) 390 (pattern s:with-superscripts 391 #:with (:optional-bounded-variadic-repeated-type) 392 #'(s.expanded …))) 393 394 ;; Expands to 0 or more mandatory-doms for ->* and possibly a rest clause 395 (define-splicing-syntax-class mandatory-variadic-repeated-type 396 #:attributes ([mandatory 1] [rest-clause 1]) 397 (pattern {~seq :base {~^ from:nat +}} 398 #:with (mandatory …) (map (const #'base) 399 (range (syntax-e #'from))) 400 #:with (rest-clause …) #'(#:rest base)) 401 (pattern {~seq :base {~or + {~^ +}}} 402 #:with (:mandatory-variadic-repeated-type) #'(base ^ 1 +)) 403 (pattern {~seq :base {~^ from:nat - {~optional ∞}}} 404 #:with (:mandatory-variadic-repeated-type) #'(base ^ from +)) 405 (pattern s:with-superscripts 406 #:with (:mandatory-variadic-repeated-type) 407 #'(s.expanded …))) 408 409 ;; Expands to a #:rest clause for ->* 410 (define-splicing-syntax-class optional-variadic-repeated-type 411 #:attributes ([rest-clause 1]) 412 #:literals (^ * + - ∞) 413 (pattern {~or {~seq :base {~^ {~optional 0} - {~optional ∞}}} 414 {~seq :base {~^ *}} 415 {~seq :base *}} 416 #:with (rest-clause …) #'(#:rest base)) 417 (pattern s:with-superscripts 418 #:with (:optional-variadic-repeated-type) 419 #'(s.expanded …))) 420 421 (define ((xlist-builder-type context) stx) 422 ;; The order of clauses is important, as they otherwise overlap. 423 (syntax-parse stx 424 #:context context 425 #:literals (^ * + - ∞) 426 [(τᵢ:fixed-repeated-type 427 … 428 (~or (~seq τₘᵥ:mandatory-variadic-repeated-type) 429 (~seq {~optional τⱼ:mandatory-bounded-variadic-repeated-type} 430 τₖ:optional-bounded-variadic-repeated-type 431 … 432 {~optional τₙ:optional-variadic-repeated-type}))) 433 #:with range ((xlist-type context) stx) 434 (template (->* 435 ;; mandatory 436 (τᵢ.mandatory 437 … … 438 {?? {?@ τₘᵥ.mandatory …}} 439 {?? {?@ τⱼ.mandatory …}}) 440 ;; optional 441 ({?? {?@ τⱼ.optional …}} 442 τₖ.optional … …) 443 ;; #:rest 444 {?? {?@ τₘᵥ.rest-clause …}} 445 {?? {?@ τₙ.rest-clause …}} 446 ;; range 447 range))])) 448 449 (define ((xlist-builder context) stx) 450 #`(cast list 451 #,((xlist-builder-type context) stx))))) 452 453 (define-multi-id xlist 454 #:type-expander (λ (stx) ((xlist-type stx) (stx-cdr stx))) 455 #:match-expander (λ (stx) ((xlist-match stx) (stx-cdr stx))) 456 #;{#:call (λ (stx) ((xlist-builder stx) (stx-cdr stx)))}) 457 458 (define-match-expander list-rest-ish 459 (λ (stx) 460 ((λ (x) #;(pretty-write (syntax->datum x)) x) 461 ((syntax-parser 462 #:literals (list list-rest-ish) 463 #:datum-literals (list-rest) 464 [(_ [c₁ …] e₁ … (list-rest-ish [c₂ …] e₂ … r)) 465 #'(list-rest-ish [c₁ … c₂ …] e₁ … e₂ … r)] 466 [(_ [c₁ …] e₁ … (list-rest e₂ … r)) 467 #'(list-rest-ish [c₁ …] e₁ … e₂ … r)] 468 [(_ [c₁ …] e₁ … (list e₂ …)) 469 #'(and (list e₁ … e₂ …) c₁ …)] 470 [(_ [c₁ …] e₁ … r) 471 #'(and (list-rest e₁ … r) 472 c₁ …)]) 473 stx)))) 474 475 (when-typed 476 (provide xList #;xListBuilder) 477 (define-type-expander (xList stx) 478 ((xlist-type stx) (stx-cdr stx))) 479 480 #;(define-type-expander (xListBuilder stx) 481 ((xlist-builder-type stx) (stx-cdr stx)))))