commit 7a6e258955a7ea4ccba6472a014fe0b0e6a6fd12
parent 96fa8c0ba312dc445f80d8ba3b473ab40505256d
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 21 Sep 2016 18:12:46 +0200
Added xlist match expander. Added typed and untyped versions.
Diffstat:
5 files changed, 308 insertions(+), 218 deletions(-)
diff --git a/infinity-identifier.rkt b/infinity-identifier.rkt
@@ -1,6 +1,5 @@
-#lang racket/base
-(provide ∞)
+#lang typed/racket/base
-(require (for-syntax racket/base))
+(provide ∞)
-(define ∞ +inf.0)
-\ No newline at end of file
+(define ∞ : +inf.0 +inf.0)
+\ No newline at end of file
diff --git a/info.rkt b/info.rkt
@@ -7,12 +7,14 @@
"multi-id"
"type-expander"
"typed-racket-lib"
- "typed-racket-more"))
+ "typed-racket-more"
+ "phc-toolkit"
+ "reprovide-lang"
+ "match-string"))
(define build-deps '("scribble-lib"
"racket-doc"
"typed-racket-doc"
- "scribble-math"
- "match-string"))
+ "scribble-math"))
(define scribblings '(("scribblings/xlist.scrbl" ())))
(define pkg-desc "Description Here")
(define version "0.0")
diff --git a/main.rkt b/main.rkt
@@ -1,204 +1,293 @@
#lang typed/racket/base
-(require type-expander
- multi-id
- "caret-identifier.rkt"
- "infinity-identifier.rkt"
- (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))
-
-(provide xlist xList ^ ∞)
-
-(define-syntax stop
- (λ (stx) (raise-syntax-error 'stop "This is a private marker" stx)))
-
-(begin-for-syntax
- (define number/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]+)$")
- (define */rx #px"^(.*?)⃰$")
- (define +/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]*)⁺$")
- (define -/rx #px"^(.*?)([⁰¹²³⁴⁵⁶⁷⁸⁹]*)⁻([⁰¹²³⁴⁵⁶⁷⁸⁹]*)$")
+(require phc-toolkit/typed-untyped)
+(define-typed/untyped-modules #:no-test
+ (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/stx
+ type-expander/expander))
+
+ (provide xlist ^ ∞)
+
+ (define-syntax stop
+ (λ (stx) (raise-syntax-error 'stop "This is a private marker" stx)))
+
+ (begin-for-syntax
+ (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 (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 (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-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-list
- (pattern {~not (_ …)}))
-
- (define-syntax-class base
- #:literals (^ + *)
- (pattern {~and base {~not {~or ^ + *}}}))
-
- (define-splicing-syntax-class fixed-repeat
- (pattern {~seq :base {~literal ^} power:number}
- #:with (expanded …) (map (const #'base)
- (range (syntax-e #'power))))
- (pattern {~literal stop}
- #:with (expanded …) #'())
- (pattern e:base
- #:with (expanded …) #'(e)))
-
- (define-syntax-class repeat-spec
- #:literals (* + - ∞)
- (pattern (:number))
- (pattern ({~optional :number} +))
- (pattern ({~optional :number} - {~optional {~or ∞ :number}}))
- (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)
- ;; The order of clauses is important, as they otherwise overlap.
+ (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-list
+ (pattern {~not (_ …)}))
+
+ (define-syntax-class base
+ #:literals (^ + *)
+ (pattern {~and base {~not {~or ^ + *}}}))
+
+ (define-splicing-syntax-class fixed-repeat
+ (pattern {~seq :base {~literal ^} power:number}
+ #:with (expanded …) (map (const #'base)
+ (range (syntax-e #'power))))
+ (pattern {~literal stop}
+ #:with (expanded …) #'())
+ (pattern e:base
+ #:with (expanded …) #'(e)))
+
+ (define-syntax-class repeat-spec
+ #:literals (* + - ∞)
+ (pattern (:number))
+ (pattern ({~optional :number} +))
+ (pattern ({~optional :number} - {~optional {~or ∞ :number}}))
+ (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)
+ ;; 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))]))
+
+
+
+
+
+ ;; 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 (^ * + - ∞ stop)
+ [()
+ #'(list)]
+ [rest:not-stx-list
+ #'rest]
+ [(stop . rest) ;; eliminate the private marker
+ (xl #'rest)]
+ [(({~literal unquote-splicing} splice) …+ . rest)
+ #`(append splice … #,(xl #'rest))]
+ [(s:with-superscripts . rest)
+ (xl #'(s.expanded … . rest))]
+ [(:base {~optional ^} * . rest)
+ #:with R (gensym 'R)
+ #`(list-rest-ish [] base ooo #,(xl #'rest))]
+ [(:base {~optional ^} + . 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 ^ - . rest)
+ (xl #'(base ^ 0 - . rest))]
+ [(:base ^ from:nat - ∞ . rest)
+ (xl #'(base ^ from + . rest))]
+ [(:base ^ from:nat - to:nat . rest)
+ (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 ___}} . rest)
+ #`(list-rest-ish [] base ooo #,(xl #'rest))]
+ [(:base {~literal ...+} . rest)
+ #`(list-rest-ish base ..1 #,(xl #'rest))]
+ [(:base ellipsis:id . rest)
+ #:when (regexp-match? #px"^\\.\\.[0-9]+$"
+ (symbol->string (syntax-e #'ellipsis)))
+ #`(list-rest-ish [] base ellipsis #,(xl #'rest))]
+ [(e:fixed-repeat . rest)
+ #`(list-rest-ish [] e.expanded … #,(xl #'rest))]))
+ (xl stx)))
+
+ (define-multi-id xlist
+ #:type-expander (λ (stx) ((xlist-type stx) (stx-cdr stx)))
+ #:match-expander (λ (stx) ((xlist-match stx) (stx-cdr stx))))
+
+ (define-match-expander list-rest-ish
(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 stop base * . 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-type-expander (xList stx)
- ((xlist-type stx) (stx-cdr stx)))
-
-(define-multi-id xlist
- #:type-expander (λ (stx) ((xlist-type stx) (stx-cdr stx))))
+ #: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₁ …)]))
+
+ (when-typed
+ (provide xList)
+ (define-type-expander (xList stx)
+ ((xlist-type stx) (stx-cdr stx)))))
diff --git a/scribblings/xlist.scrbl b/scribblings/xlist.scrbl
@@ -182,17 +182,17 @@ 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)))
+ (append (and (list number? ...) (app length (? (between/c 3 5))))
(list-no-order number? string?)
(list symbol? ..1))]
Applying a repeat indicator on a splice is not supported yet, i.e.
- @racket[(xlist ,@(list-no-order number? string?)⁵)] will not work.}
-
-@defidform[^]{This identifier can only be used within xlist forms.}
-@defthing[∞]{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 possible for other packages to overload the meaning
- of the @racket[^] and @racket[∞] identifiers, so that the value of @racket[∞]
- may depend on the packages loaded (for example a symbolic math package may want
- to attach a special value to @racket[∞].}
-\ No newline at end of file
+ @racket[(xlist ,@(list-no-order number? string?)⁵)] will not work.
+
+ @emph{Note :} Typed/Racket's type inference is not strong enough (yet) to
+ support some match patterns, and there is no @elem[#:style 'tt "typed/match"]
+ library which would help with that (yet). This means that some of the patterns
+ supported by @racket[xlist] will not work in typed/racket.}
+
+@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
@@ -63,9 +63,9 @@
(ann '(1 1 1) (xlist Number ^ *))
; NOT (ann '() (xlist Number ^ +))
- (ann '(1) (xlist 1 ^ +))
- (ann '(1 1) (xlist 1 ^ +))
- (ann '(1 1 1) (xlist 1 ^ +))
+ (ann '(1) (xlist Number ^ +))
+ (ann '(1 1) (xlist Number ^ +))
+ (ann '(1 1 1) (xlist Number ^ +))
(void))
(test-begin
