Migrate lib/ to jsmaniac/phc-toolkit project: removed lib/… files.
This commit is contained in:
Georges Dupéron
parent
f5433ff093
commit
fb484502ba
|
|
@ -1,11 +0,0 @@
|
|||
#lang typed/racket
|
||||
|
||||
(module m racket
|
||||
(provide eval-get-values)
|
||||
|
||||
(define (eval-get-values expr namespace)
|
||||
(call-with-values (λ () (eval expr namespace)) list)))
|
||||
|
||||
(require/typed 'm [eval-get-values (→ Any Namespace (Listof Any))])
|
||||
|
||||
(provide eval-get-values)
|
||||
|
|
@ -1,148 +0,0 @@
|
|||
#lang typed/racket
|
||||
|
||||
(require "low.rkt")
|
||||
(require "eval-get-values.rkt")
|
||||
|
||||
(provide (all-from-out "low.rkt")
|
||||
(all-from-out "eval-get-values.rkt"))
|
||||
|
||||
;; Types
|
||||
(provide AnyImmutable)
|
||||
;; Functions
|
||||
(provide (rename-out [∘ compose]))
|
||||
;; Macros
|
||||
;(provide mapp)
|
||||
(provide comment)
|
||||
|
||||
(require (for-syntax syntax/parse
|
||||
racket/syntax))
|
||||
|
||||
(define-syntax (comment stx)
|
||||
#'(values))
|
||||
|
||||
(define-type AnyImmutable (U Number
|
||||
Boolean
|
||||
True
|
||||
False
|
||||
String
|
||||
Keyword
|
||||
Symbol
|
||||
Char
|
||||
Void
|
||||
;Input-Port ;; Not quite mutable, nor immutable.
|
||||
;Output-Port ;; Not quite mutable, nor immutable.
|
||||
;Port ;; Not quite mutable, nor immutable.
|
||||
|
||||
;; I haven't checked the mutability of the ones
|
||||
;; inside in the #||# comments below
|
||||
#|
|
||||
Path
|
||||
Path-For-Some-System
|
||||
Regexp
|
||||
PRegexp
|
||||
Byte-Regexp
|
||||
Byte-PRegexp
|
||||
Bytes
|
||||
Namespace
|
||||
Namespace-Anchor
|
||||
Variable-Reference
|
||||
|#
|
||||
Null
|
||||
#|
|
||||
EOF
|
||||
Continuation-Mark-Set
|
||||
|#
|
||||
;; We definitely don't Undefined, it's not mutable
|
||||
;; but it's an error if present anywhere 99.9% of
|
||||
;; the time. Typed/racket is moving towards making
|
||||
;; occurrences of this type an error, anyway.
|
||||
; Undefined
|
||||
#|
|
||||
Module-Path
|
||||
Module-Path-Index
|
||||
Resolved-Module-Path
|
||||
Compiled-Module-Expression
|
||||
Compiled-Expression
|
||||
Internal-Definition-Context
|
||||
Pretty-Print-Style-Table
|
||||
Special-Comment
|
||||
Struct-Type-Property
|
||||
Impersonator-Property
|
||||
Read-Table
|
||||
Bytes-Converter
|
||||
Parameterization
|
||||
Custodian
|
||||
Inspector
|
||||
Security-Guard
|
||||
UDP-Socket ;; Probably not
|
||||
TCP-Listener ;; Probably not
|
||||
Logger ;; Probably not
|
||||
Log-Receiver ;; Probably not
|
||||
Log-Level
|
||||
Thread
|
||||
Thread-Group
|
||||
Subprocess
|
||||
Place
|
||||
Place-Channel
|
||||
Semaphore ;; Probably not
|
||||
FSemaphore ;; Probably not
|
||||
Will-Executor
|
||||
Pseudo-Random-Generator
|
||||
Path-String
|
||||
|#
|
||||
(Pairof AnyImmutable AnyImmutable)
|
||||
(Listof AnyImmutable)
|
||||
; Plus many others, not added yet.
|
||||
;; Don't include closures, because they can contain
|
||||
;; mutable variables, and we can't eq? them.
|
||||
; ->
|
||||
; maybe Prefab? Or are they mutable?
|
||||
))
|
||||
|
||||
#|
|
||||
(define-syntax (mapp stx)
|
||||
(syntax-parse stx
|
||||
[(_ var:id lst:expr body ...)
|
||||
#'(let ((l lst))
|
||||
(if (null? l)
|
||||
'()
|
||||
(let ((result (list (let ((var (car l)))
|
||||
body ...))))
|
||||
(set! l (cdr l))
|
||||
(do ([stop : Boolean #f])
|
||||
(stop (reverse result))
|
||||
(if (null? l)
|
||||
(set! stop #t)
|
||||
(begin
|
||||
(set! result
|
||||
(cons (let ((var (car l)))
|
||||
body ...)
|
||||
result))
|
||||
(set! l (cdr l))))))))]))
|
||||
|#
|
||||
|
||||
|
||||
;; TODO: this does not work, because Null is (Listof Any)
|
||||
; (mapp x (cdr '(1)) (* x x))
|
||||
|
||||
;; TODO: foldll
|
||||
(define-syntax (foldll stx)
|
||||
(syntax-parse stx
|
||||
[(_ var:id acc:id lst:expr init:expr body ...)
|
||||
#'(let ((l lst))
|
||||
(if (null? l)
|
||||
'()
|
||||
(let ((result (list (let ((var (car l)))
|
||||
body ...))))
|
||||
(set! l (cdr l))
|
||||
(do ([stop : Boolean #f])
|
||||
(stop (reverse result))
|
||||
(if (null? l)
|
||||
(set! stop #t)
|
||||
(begin
|
||||
(set! result
|
||||
(cons (let ((var (car l)))
|
||||
body ...)
|
||||
result))
|
||||
(set! l (cdr l))))))))]))
|
||||
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "low/typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(require "low/typed-untyped.rkt")
|
||||
(provide (all-from-out "low/typed-untyped.rkt"))
|
||||
|
||||
;(require/provide (typed/untyped "low/fixnum.rkt" …))
|
||||
(require/provide-typed/untyped
|
||||
"low/misc.rkt"
|
||||
"low/require-provide.rkt"
|
||||
"low/fixnum.rkt"
|
||||
"low/typed-rackunit.rkt"
|
||||
"low/typed-rackunit-extensions.rkt"
|
||||
"low/syntax-parse.rkt"
|
||||
"low/tmpl.rkt"
|
||||
"low/threading.rkt"
|
||||
"low/aliases.rkt"
|
||||
"low/sequence.rkt"
|
||||
"low/repeat-stx.rkt"
|
||||
"low/stx.rkt"
|
||||
"low/list.rkt"
|
||||
"low/values.rkt"
|
||||
"low/ids.rkt"
|
||||
"low/generate-indices.rkt"
|
||||
"low/set.rkt"
|
||||
"low/type-inference-helpers.rkt"
|
||||
"low/percent.rkt"
|
||||
"low/not-implemented-yet.rkt"
|
||||
"low/cond-let.rkt"
|
||||
"low/multiassoc-syntax.rkt"
|
||||
"low/tmpl-multiassoc-syntax.rkt"
|
||||
"low/logn-id.rkt"))
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide (all-from-out racket/match)
|
||||
∘
|
||||
…
|
||||
…+
|
||||
match-λ
|
||||
match-λ*
|
||||
match-λ**
|
||||
generate-temporary)
|
||||
|
||||
(require racket/match)
|
||||
|
||||
(require (only-in racket
|
||||
[compose ∘]
|
||||
[... …])
|
||||
(only-in syntax/parse
|
||||
[...+ …+]))
|
||||
|
||||
(require (only-in racket/match
|
||||
[match-lambda match-λ]
|
||||
[match-lambda* match-λ*]
|
||||
[match-lambda** match-λ**]))
|
||||
|
||||
(require/typed racket/syntax [generate-temporary (→ Any Identifier)]))
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
#lang racket
|
||||
;(require "typed-untyped.rkt")
|
||||
;(define-typed/untyped-modules #:no-test
|
||||
(provide show-backtrace
|
||||
with-backtrace)
|
||||
|
||||
(define backtrace (make-parameter '()))
|
||||
|
||||
(define-syntax-rule (with-backtrace push . body)
|
||||
(parameterize ([backtrace (cons push (backtrace))])
|
||||
. body))
|
||||
|
||||
(define (show-backtrace)
|
||||
(pretty-write (backtrace)));)
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide cond-let)
|
||||
|
||||
(require (for-syntax syntax/parse
|
||||
(submod "aliases.rkt" untyped)))
|
||||
|
||||
(define-syntax (cond-let stx)
|
||||
(syntax-parse stx
|
||||
[(_)
|
||||
#'(typecheck-fail #,stx)]
|
||||
[(_ #:let bindings:expr clause …)
|
||||
#'(let bindings (cond-let clause …))]
|
||||
[(_ [condition:expr (~seq #:else-let binding …) … . body] clause …)
|
||||
#'(if condition
|
||||
(begin . body)
|
||||
(let (binding … …)
|
||||
(cond-let clause …)))])))
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules
|
||||
(provide fxxor)
|
||||
|
||||
;; For fxxor, used to compute hashes.
|
||||
;; The type obtained just by writing (require racket/fixnum) is wrong, so we
|
||||
;; get a more precise one.
|
||||
(require/typed racket/fixnum [(fxxor fxxor2) (→ Fixnum Fixnum Fixnum)])
|
||||
|
||||
(: fxxor (→ Fixnum * Fixnum))
|
||||
(define (fxxor . args)
|
||||
(foldl fxxor2 0 args))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (fxxor2 13206 23715) 28469)
|
||||
(check-equal? (fxxor 0) 0)
|
||||
(check-equal? (fxxor 13206) 13206)
|
||||
(check-equal? (fxxor 13206 23715 314576) 304101)))
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide generate-indices)
|
||||
|
||||
(require "typed-untyped.rkt")
|
||||
(require-typed/untyped "sequence.rkt")
|
||||
(: generate-indices (∀ (T) (case→ (→ Integer (Syntax-Listof T)
|
||||
(Listof Integer))
|
||||
(→ (Syntax-Listof T)
|
||||
(Listof Nonnegative-Integer)))))
|
||||
|
||||
(define generate-indices
|
||||
(case-lambda
|
||||
[(start stx)
|
||||
(for/list ([v (my-in-syntax stx)]
|
||||
[i (in-naturals start)])
|
||||
i)]
|
||||
[(stx)
|
||||
(for/list ([v (my-in-syntax stx)]
|
||||
[i : Nonnegative-Integer
|
||||
(ann (in-naturals) (Sequenceof Nonnegative-Integer))])
|
||||
i)])))
|
||||
|
|
@ -1,313 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:untyped-first
|
||||
(provide !temp
|
||||
(rename-out [!temp &])
|
||||
format-ids
|
||||
hyphen-ids
|
||||
format-temp-ids
|
||||
#|!temp|#
|
||||
define-temp-ids)
|
||||
|
||||
(require "typed-untyped.rkt")
|
||||
(require-typed/untyped "sequence.rkt"
|
||||
"aliases.rkt")
|
||||
(begin-for-syntax (require "typed-untyped.rkt")
|
||||
(require-typed/untyped "aliases.rkt"))
|
||||
|
||||
(module m-!temp racket
|
||||
(provide !temp)
|
||||
|
||||
(require syntax/parse
|
||||
syntax/parse/experimental/template)
|
||||
|
||||
(define-template-metafunction (!temp stx)
|
||||
(syntax-parse stx
|
||||
[(_ id:id)
|
||||
#:with (temp) (generate-temporaries #'(id))
|
||||
#'temp]
|
||||
#|[(_ . id:id)
|
||||
#:with (temp) (generate-temporaries #'(id))
|
||||
#'temp]
|
||||
[(_ id:id ...)
|
||||
(generate-temporaries #'(id ...))]|#)))
|
||||
(require 'm-!temp)
|
||||
|
||||
(require/typed racket/syntax
|
||||
[format-id (→ Syntax String (U String Identifier) *
|
||||
Identifier)])
|
||||
(require (only-in racket/syntax define/with-syntax)
|
||||
(only-in syntax/stx stx-map)
|
||||
(for-syntax racket/base
|
||||
racket/format
|
||||
racket/syntax
|
||||
syntax/parse
|
||||
syntax/parse/experimental/template))
|
||||
;(require racket/sequence) ;; in-syntax
|
||||
|
||||
(define-type S-Id-List
|
||||
(U String
|
||||
Identifier
|
||||
(Listof String)
|
||||
(Listof Identifier)
|
||||
(Syntaxof (Listof Identifier))))
|
||||
|
||||
; TODO: format-ids doesn't accept arbitrary values. Should we change it?
|
||||
;
|
||||
(: format-ids (→ (U Syntax (→ (U String Identifier) * Syntax))
|
||||
String
|
||||
S-Id-List *
|
||||
(Listof Identifier)))
|
||||
(define (format-ids lex-ctx format . vs)
|
||||
(let* ([seqs
|
||||
(map (λ ([v : S-Id-List])
|
||||
(cond
|
||||
[(string? v) (in-cycle (in-value v))]
|
||||
[(identifier? v) (in-cycle (in-value v))]
|
||||
[(list? v) (in-list v)]
|
||||
[else (in-list (syntax->list v))]))
|
||||
vs)]
|
||||
[justconstants (andmap (λ (x) (or (string? x) (identifier? x))) vs)]
|
||||
[seqlst (apply sequence-list seqs)])
|
||||
(for/list : (Listof Identifier)
|
||||
([items seqlst]
|
||||
[bound-length (if justconstants
|
||||
(in-value 'yes)
|
||||
(in-cycle (in-value 'no)))])
|
||||
|
||||
(apply format-id
|
||||
(if (procedure? lex-ctx) (apply lex-ctx items) lex-ctx)
|
||||
format
|
||||
items))))
|
||||
|
||||
(: hyphen-ids (→ (U Syntax (→ (U String Identifier) * Syntax))
|
||||
S-Id-List *
|
||||
(Listof Identifier)))
|
||||
|
||||
(define (hyphen-ids lex-ctx . vs)
|
||||
(apply format-ids
|
||||
lex-ctx
|
||||
(string-join (map (λ _ "~a") vs) "-")
|
||||
vs))
|
||||
|
||||
(: format-temp-ids (→ String
|
||||
S-Id-List *
|
||||
(Listof Identifier)))
|
||||
|
||||
(define (format-temp-ids format . vs)
|
||||
;; Introduce the binding in a fresh scope.
|
||||
(apply format-ids
|
||||
(λ _ ((make-syntax-introducer) (if (syntax? format) format #'())))
|
||||
format
|
||||
vs))
|
||||
|
||||
(require (for-syntax (submod "stx.rkt" untyped)))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-class dotted
|
||||
(pattern id:id
|
||||
#:attr make-dotted
|
||||
(λ (x) x)
|
||||
#:attr wrap
|
||||
(λ (x f) (f x #t)))
|
||||
(pattern (nested:dotted (~literal ...));(~and dots (~literal ...)) ...+)
|
||||
#:with id #'nested.id
|
||||
#:attr make-dotted
|
||||
(λ (x) #`(#,((attribute nested.make-dotted) x) (... ...)));dots …
|
||||
#:attr wrap
|
||||
(λ (x f) (f ((attribute nested.wrap) x f) #f))))
|
||||
|
||||
(define-syntax-class simple-format
|
||||
(pattern format
|
||||
#:when (string? (syntax-e #'format))
|
||||
#:when (regexp-match #rx"^[^~]*~a[^~]*$" (syntax-e #'format))
|
||||
#:attr pos (regexp-match-positions #rx"^([^~]*)~a([^~]*)$"
|
||||
(syntax-e #'format))
|
||||
#:attr left-start 1
|
||||
#:attr left-end (+ 1 (cdr (cadr (attribute pos))))
|
||||
#:attr left-len (cdr (cadr (attribute pos)))
|
||||
|
||||
#:attr right-start (+ 1 (car (caddr (attribute pos))))
|
||||
#:attr right-end (+ 1 (cdr (caddr (attribute pos))))
|
||||
#:attr right-len (- (attribute right-end)
|
||||
(attribute right-start)))))
|
||||
|
||||
(define-syntax (define-temp-ids stx)
|
||||
(syntax-parse stx
|
||||
#|
|
||||
;; TODO : factor this with the next case.
|
||||
[(_ format ((base:id (~literal ...)) (~literal ...)))
|
||||
#:when (string? (syntax-e #'format))
|
||||
(with-syntax ([pat (format-id #'base (syntax-e #'format) #'base)])
|
||||
#'(define/with-syntax ((pat (... ...)) (... ...))
|
||||
(stx-map (curry format-temp-ids format)
|
||||
#'((base (... ...)) (... ...)))))]
|
||||
|#
|
||||
|
||||
;; New features (arrows and #:first) special-cased for now
|
||||
;; TODO: make these features more general.
|
||||
[(_ format:simple-format base:dotted
|
||||
#:first-base first-base
|
||||
(~optional (~seq #:prefix prefix)))
|
||||
#:with first (format-id #'first-base (syntax-e #'format) #'first-base)
|
||||
(let ([first-base-len (identifier-length #'first-base)])
|
||||
(syntax-cons-property (template
|
||||
(define-temp-ids format base
|
||||
#:first first
|
||||
(?? (?@ #:prefix prefix))))
|
||||
'sub-range-binders
|
||||
(list
|
||||
(if (> (attribute format.left-len) 0)
|
||||
(vector (syntax-local-introduce #'first)
|
||||
0
|
||||
(attribute format.left-len)
|
||||
|
||||
(syntax-local-introduce #'format)
|
||||
(attribute format.left-start)
|
||||
(attribute format.left-len))
|
||||
'())
|
||||
(vector (syntax-local-introduce #'first)
|
||||
(attribute format.left-len)
|
||||
first-base-len
|
||||
|
||||
(syntax-local-introduce #'first-base)
|
||||
0
|
||||
first-base-len)
|
||||
(if (> (attribute format.right-len) 0)
|
||||
(vector (syntax-local-introduce #'first)
|
||||
(+ (attribute format.left-len)
|
||||
first-base-len)
|
||||
(attribute format.right-len)
|
||||
|
||||
(syntax-local-introduce #'format)
|
||||
(attribute format.right-start)
|
||||
(attribute format.right-len))
|
||||
'()))))]
|
||||
|
||||
[(_ format:simple-format
|
||||
base:dotted
|
||||
(~optional (~seq #:first first))
|
||||
(~optional (~seq #:prefix prefix)))
|
||||
(let* ([base-len (string-length (symbol->string (syntax-e #'base.id)))])
|
||||
(define/with-syntax pat
|
||||
(format-id #'base.id (syntax-e #'format) #'base.id))
|
||||
(define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat))
|
||||
|
||||
(define/with-syntax format-temp-ids*
|
||||
((attribute base.wrap) (template
|
||||
(compose car
|
||||
(?? (curry format-temp-ids
|
||||
(~a "~a:" format)
|
||||
prefix)
|
||||
(curry format-temp-ids
|
||||
format))
|
||||
generate-temporary))
|
||||
(λ (x deepest?)
|
||||
(if deepest?
|
||||
x
|
||||
#`(curry stx-map #,x)))))
|
||||
(syntax-cons-property
|
||||
(template (begin (define/with-syntax pat-dotted
|
||||
(format-temp-ids* #'base))
|
||||
(?? (?@ (define/with-syntax (first . _)
|
||||
#'pat-dotted)))))
|
||||
'sub-range-binders
|
||||
(list (if (> (attribute format.left-len) 0)
|
||||
(vector (syntax-local-introduce #'pat)
|
||||
0
|
||||
(attribute format.left-len)
|
||||
|
||||
(syntax-local-introduce #'format)
|
||||
(attribute format.left-start)
|
||||
(attribute format.left-len))
|
||||
'())
|
||||
(vector (syntax-local-introduce #'pat)
|
||||
(attribute format.left-len)
|
||||
base-len
|
||||
|
||||
(syntax-local-get-shadower #'base.id)
|
||||
0
|
||||
base-len)
|
||||
(if (> (attribute format.right-len) 0)
|
||||
(vector (syntax-local-introduce #'pat)
|
||||
(+ (attribute format.left-len) base-len)
|
||||
(attribute format.right-len)
|
||||
|
||||
(syntax-local-introduce #'format)
|
||||
(attribute format.right-start)
|
||||
(attribute format.right-len))
|
||||
'()))))]
|
||||
[(_ format base:dotted)
|
||||
#:when (string? (syntax-e #'format))
|
||||
#:when (regexp-match #rx"^[^~]*$" (syntax-e #'format))
|
||||
(define/with-syntax pat (format-id #'base (syntax-e #'format)))
|
||||
(define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat))
|
||||
(define/with-syntax format-temp-ids*
|
||||
((attribute base.wrap) #'(λ (x)
|
||||
(car (format-temp-ids
|
||||
(string-append format "~a")
|
||||
"")))
|
||||
(λ (x deepest?)
|
||||
(if deepest?
|
||||
x
|
||||
#`(curry stx-map #,x)))))
|
||||
(syntax-cons-property
|
||||
#'(define/with-syntax pat-dotted
|
||||
(format-temp-ids* #'base))
|
||||
'sub-range-binders
|
||||
(list (vector (syntax-local-introduce #'pat)
|
||||
0
|
||||
(string-length (syntax-e #'format))
|
||||
|
||||
(syntax-local-introduce #'format)
|
||||
1
|
||||
(string-length (syntax-e #'format)))))]
|
||||
[(_ name:id format:expr . vs)
|
||||
#`(define/with-syntax name (format-temp-ids format . vs))]))
|
||||
|
||||
(module+ test
|
||||
(require-typed/untyped "typed-rackunit.rkt")
|
||||
(require ;(submod "..")
|
||||
(for-syntax racket/syntax
|
||||
(submod ".." ".." untyped)))
|
||||
|
||||
(check-equal?: (format-ids #'a "~a-~a" #'() #'())
|
||||
'())
|
||||
|
||||
(check-equal?: (map syntax->datum
|
||||
(format-ids #'a "~a-~a" #'(x1 x2 x3) #'(a b c)))
|
||||
'(x1-a x2-b x3-c))
|
||||
|
||||
;; Since the presence of "Syntax" in the parameters list makes format-ids
|
||||
;; require a chaperone contract instead of a flat contract, we can't run the
|
||||
;; two tests below directly, we would need to require the untyped version of
|
||||
;; this file, which causes a cycle in loading.
|
||||
|
||||
(define-syntax (test1 stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (let1 d1) x y)
|
||||
(begin
|
||||
(define/with-syntax (foo-x foo-y)
|
||||
(format-ids (λ (xy)
|
||||
(if (string=? (symbol->string (syntax->datum xy))
|
||||
"b")
|
||||
stx
|
||||
#'()))
|
||||
"foo-~a"
|
||||
#'(x y)))
|
||||
#'(let1 d1 (let ((foo-b 2) (foo-c 'b)) (cons foo-x foo-y))))]))
|
||||
|
||||
(check-equal?: (test1 (let ((foo-b 1) (foo-c 'a))) b c)
|
||||
'(1 . b))
|
||||
|
||||
(define-syntax (fubar stx)
|
||||
(define/with-syntax (v1 ...) #'(1 2 3))
|
||||
(define/with-syntax (v2 ...) #'('a 'b 'c))
|
||||
;; the resulting ab and ab should be distinct identifiers:
|
||||
(define/with-syntax (id1 ...) (format-temp-ids "~a" #'(ab cd ab)))
|
||||
(define/with-syntax (id2 ...) (format-temp-ids "~a" #'(ab cd ab)))
|
||||
#'(let ([id1 v1] ...)
|
||||
(let ([id2 v2] ...)
|
||||
(list (cons id1 id2) ...))))
|
||||
|
||||
(check-equal?: (fubar) '((1 . a) (2 . b) (3 . c)))))
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
#lang typed/racket
|
||||
|
||||
(provide in)
|
||||
|
||||
(require racket/stxparam)
|
||||
|
||||
(define-syntax-parameter in
|
||||
(λ (stx)
|
||||
(raise-syntax-error
|
||||
'in
|
||||
"used out of context. It can only be used in some forms."
|
||||
stx)))
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide indexof
|
||||
replace-first
|
||||
map+fold
|
||||
AListof)
|
||||
|
||||
(define-type (AListof K V) (Listof (Pairof K V)))
|
||||
(define-match-expander alistof
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(keys-pat vals-pat)
|
||||
#'(list (cons keys-pat vals-pat) …)])))
|
||||
|
||||
(: indexof (∀ (A B) (→ A (Listof B) (→ A B Any) (U #f Integer))))
|
||||
(define (indexof elt lst [compare equal?])
|
||||
(let rec ([lst lst] [index 0])
|
||||
(if (null? lst)
|
||||
#f
|
||||
(if (compare elt (car lst))
|
||||
index
|
||||
(rec (cdr lst) (+ index 1))))))
|
||||
|
||||
(: replace-first (∀ (A B C) (->* (B
|
||||
C
|
||||
(Listof (U A B)))
|
||||
(#:equal? (→ (U A B) (U A B) Any : #:+ B))
|
||||
(Rec R (U (Pairof (U A B) R)
|
||||
Null
|
||||
(Pairof C (Listof (U A B))))))))
|
||||
(define (replace-first from to l #:equal? [equal? eq?])
|
||||
(if (null? l)
|
||||
'()
|
||||
(if (equal? from (car l))
|
||||
(cons to (cdr l))
|
||||
(cons (car l)
|
||||
(replace-first from to (cdr l))))))
|
||||
|
||||
(: map+fold (∀ (E R A) (→ (→ E A (values R A)) A (Listof E)
|
||||
(Values (Listof R) A))))
|
||||
(define (map+fold f init-acc lst)
|
||||
(let ([result (foldl (λ ([item : E] [acc : (Pairof (Listof R) A)])
|
||||
(let-values ([(item new-acc) (f item (cdr acc))])
|
||||
(cons (cons item (car acc))
|
||||
new-acc)))
|
||||
(cons '() init-acc)
|
||||
lst)])
|
||||
(values (car result) (cdr result)))))
|
||||
|
|
@ -1,82 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide define-logn-ids)
|
||||
|
||||
(require (for-syntax syntax/parse
|
||||
racket/syntax
|
||||
racket/function
|
||||
racket/match
|
||||
syntax/stx)
|
||||
"typed-untyped.rkt")
|
||||
|
||||
(begin-for-syntax
|
||||
(define (insert make-node v ts)
|
||||
(match ts
|
||||
[`() `((,v))]
|
||||
[`(() . ,b) `((,v) . ,b)]
|
||||
[`((,a) . ,b) `(() . ,(insert make-node (make-node v a) b))]))
|
||||
|
||||
(define (merge-trees make-node ts)
|
||||
(match ts
|
||||
[`{[,a]} a]
|
||||
[`{[,a] [] . ,rest} (merge-trees make-node `{[,a] . ,rest})]
|
||||
[`{[] . ,rest} (merge-trees make-node rest)]
|
||||
[`{[,a] [,b] . ,rest} (merge-trees make-node
|
||||
`{[,(make-node a b)] . ,rest})]))
|
||||
|
||||
(define (make-binary-tree l make-node make-leaf)
|
||||
(merge-trees make-node
|
||||
(foldl (curry insert make-node)
|
||||
'()
|
||||
(map make-leaf l)))))
|
||||
|
||||
(define-syntax (define-logn-ids stx)
|
||||
(syntax-parse stx
|
||||
[(_ matcher:id [id:id ty:id] ...)
|
||||
(define/with-syntax (tmp ...) (generate-temporaries #'(id ...)))
|
||||
(define bt
|
||||
(make-binary-tree (syntax->list #'([ty id . tmp] ...))
|
||||
(λ (x y) `(node ,(generate-temporary) ,x ,y))
|
||||
(λ (x) `(leaf ,(stx-car x)
|
||||
,(generate-temporary (stx-car x))
|
||||
,(stx-car (stx-cdr x))
|
||||
,(stx-cdr (stx-cdr x))))))
|
||||
(define (make-structs bt parent)
|
||||
(match bt
|
||||
[`(node ,s ,a ,b) #`(begin (struct #,s #,@parent ())
|
||||
#,(make-structs a (list s))
|
||||
#,(make-structs b (list s)))]
|
||||
[`(leaf ,t ,s ,a ,_) #`(begin (struct #,s #,@parent
|
||||
()
|
||||
#:type-name #,t)
|
||||
(define #,a (#,s)))]))
|
||||
(define (make-btd bt)
|
||||
(match bt
|
||||
[`(node ,s ,(and a `(,_ ,sa . ,_)) ,b)
|
||||
#`(if (if-typed ((make-predicate #,sa) v-cache)
|
||||
#,(format-id sa "~a?" sa))
|
||||
#,(make-btd a)
|
||||
#,(make-btd b))]
|
||||
[`(leaf ,s ,a ,t ,tmp)
|
||||
tmp]))
|
||||
#`(begin #,(make-structs bt #'())
|
||||
(define-syntax (matcher stx)
|
||||
(syntax-parse stx
|
||||
[(_ v:expr [(~literal id) tmp] ...)
|
||||
#'(let ([v-cache v])
|
||||
#,(make-btd bt))])))]))
|
||||
|
||||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
typed/rackunit)
|
||||
|
||||
(define-logn-ids match-x [a A] [b B] [c C] [d D] [e E])
|
||||
|
||||
(check-equal? (match-x (ann b (U A B C D E))
|
||||
[a 1]
|
||||
[b 2]
|
||||
[c 3]
|
||||
[d 4]
|
||||
[e 5])
|
||||
2)))
|
||||
|
|
@ -1,53 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide hash-set**
|
||||
;string-set!
|
||||
;string-copy!
|
||||
;string-fill!
|
||||
with-output-file)
|
||||
|
||||
(require (for-syntax syntax/parse syntax/parse/experimental/template))
|
||||
|
||||
;; hash-set**: hash-set a list of K V pairs.
|
||||
(begin
|
||||
(: hash-set** (∀ (K V)
|
||||
(→ (HashTable K V) (Listof (Pairof K V)) (HashTable K V))))
|
||||
(define (hash-set** h l)
|
||||
(if (null? l)
|
||||
h
|
||||
(hash-set** (hash-set h (caar l) (cdar l)) (cdr l)))))
|
||||
|
||||
;; Disable string mutation
|
||||
(begin
|
||||
(define-syntax (string-set! stx)
|
||||
(raise-syntax-error 'string-set! "Do not mutate strings." stx))
|
||||
(define-syntax (string-copy! stx)
|
||||
(raise-syntax-error 'string-copy! "Do not mutate strings." stx))
|
||||
(define-syntax (string-fill! stx)
|
||||
(raise-syntax-error 'string-fill! "Do not mutate strings." stx)))
|
||||
|
||||
;; with-output-file
|
||||
(begin
|
||||
#|
|
||||
(define-syntax (with-output-file stx)
|
||||
(syntax-parse stx
|
||||
[(_ filename:expr (~optional (~seq #:mode mode:expr))
|
||||
(~optional (~seq #:exists exists:expr))
|
||||
body ...)
|
||||
(template (with-output-to-file filename
|
||||
(λ () body ...)
|
||||
(?? (?@ #:mode mode))
|
||||
(?? (?@ #:exists exists))))]))
|
||||
|#
|
||||
|
||||
(define-syntax (with-output-file stx)
|
||||
(syntax-parse stx
|
||||
[(_ [var:id filename:expr]
|
||||
(~optional (~seq #:mode mode:expr))
|
||||
(~optional (~seq #:exists exists:expr))
|
||||
body ...)
|
||||
(template (call-with-output-file filename
|
||||
(λ (var) body ...)
|
||||
(?? (?@ #:mode mode))
|
||||
(?? (?@ #:exists exists))))]))))
|
||||
|
|
@ -1,35 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide multiassoc-syntax
|
||||
cdr-assoc-syntax
|
||||
assoc-syntax)
|
||||
|
||||
(require "typed-untyped.rkt")
|
||||
(require-typed/untyped "aliases.rkt"
|
||||
"stx.rkt")
|
||||
|
||||
;; TODO: cdr-stx-assoc is already defined in phc-toolkit
|
||||
|
||||
(define-type (Stx-AList A)
|
||||
(Syntaxof (Listof (Syntaxof (Pairof Identifier A)))))
|
||||
|
||||
(: multiassoc-syntax (∀ (A) (→ Identifier (Stx-AList A) (Listof A))))
|
||||
(define (multiassoc-syntax query alist)
|
||||
((inst map A (Syntaxof (Pairof Identifier A)))
|
||||
stx-cdr
|
||||
(filter (λ ([xy : (Syntaxof (Pairof Identifier A))])
|
||||
(free-identifier=? query (stx-car xy)))
|
||||
(syntax->list alist))))
|
||||
|
||||
(: cdr-assoc-syntax (∀ (A) (→ Identifier (Stx-AList A) A)))
|
||||
(define (cdr-assoc-syntax query alist)
|
||||
(stx-cdr (assert (assoc-syntax query alist))))
|
||||
|
||||
(: assoc-syntax (∀ (A) (→ Identifier
|
||||
(Stx-AList A)
|
||||
(U False (Syntaxof (Pairof Identifier A))))))
|
||||
(define (assoc-syntax query alist)
|
||||
(findf (λ ([xy : (Syntaxof (Pairof Identifier A))])
|
||||
(free-identifier=? query (stx-car xy)))
|
||||
(syntax->list alist))))
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide ? ?*)
|
||||
|
||||
(define-syntax (?* stx)
|
||||
(syntax-case stx ()
|
||||
[(q . rest)
|
||||
(quasisyntax/loc stx
|
||||
((λ () : (U) #,(syntax/loc #'q (error "Not implemented yet"))
|
||||
. rest)))]))
|
||||
|
||||
(define-syntax (? stx)
|
||||
(syntax-case stx ()
|
||||
[(q t . rest)
|
||||
(quasisyntax/loc stx
|
||||
((ann (λ () #,(syntax/loc #'q (error "Not implemented yet"))
|
||||
. rest)
|
||||
(→ t))))])))
|
||||
|
|
@ -1,73 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide % define% in)
|
||||
|
||||
(require (for-syntax syntax/parse
|
||||
"typed-untyped.rkt")
|
||||
"in.rkt")
|
||||
(begin-for-syntax (require-typed/untyped "aliases.rkt"))
|
||||
|
||||
#|(define-syntax (% stx)
|
||||
(syntax-parse stx #:literals (= → :)
|
||||
[(_ (~seq (~or ((~and var (~not :)) ...)
|
||||
(~seq (~and var (~not (~or = → :))) ...)) = expr)
|
||||
...
|
||||
(~optional (~literal →)) . body)
|
||||
#'(let-values ([(var ...) expr] ...) . body)]))|#
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-class %pat
|
||||
(pattern v:id
|
||||
#:with expanded #'v)
|
||||
(pattern ()
|
||||
#:with expanded #'(list))
|
||||
(pattern (x:%pat . rest:%pat)
|
||||
#:with expanded #'(cons x.expanded rest.expanded))
|
||||
(pattern #(x:%pat …)
|
||||
#:with expanded #'(vector x.expanded …)))
|
||||
(define-splicing-syntax-class %assignment
|
||||
#:attributes ([pat.expanded 1] [expr 0])
|
||||
#:literals (= in)
|
||||
(pattern (~seq (~and maybe-pat (~not (~or = in))) ...
|
||||
(~datum =) expr:expr)
|
||||
#:with [pat:%pat ...] #'(maybe-pat ...))))
|
||||
|
||||
(define-syntax (% stx)
|
||||
(syntax-parse stx #:literals (= in)
|
||||
[(_ :%assignment ... (~optional (~literal in)) . body)
|
||||
#'(match-let*-values ([(pat.expanded ...) expr] ...) . body)]))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-class typed-pat
|
||||
(pattern [x:%pat (~literal :) type:expr]
|
||||
#:with (tmp) (generate-temporaries #'(x))
|
||||
#:with var-type #`[tmp : type]
|
||||
#:with (expanded ...) #'([x.expanded tmp]))
|
||||
(pattern x:id
|
||||
#:with var-type #'x
|
||||
#:with (expanded ...) #'())
|
||||
(pattern x:%pat
|
||||
#:with (tmp) (generate-temporaries #'(x))
|
||||
#:with var-type #'tmp
|
||||
#:with (expanded ...) #'([x.expanded tmp]))))
|
||||
|
||||
(define-syntax (define% stx)
|
||||
(syntax-parse stx
|
||||
[(_ (name param:typed-pat ...)
|
||||
(~and (~seq ret ...) (~optional (~seq (~literal :) ret-type)))
|
||||
. body)
|
||||
#'(define (name param.var-type ...)
|
||||
(match-let (param.expanded ... ...) ret ... . body))]))
|
||||
|
||||
#|
|
||||
(begin-for-syntax
|
||||
(define-syntax-class λ%expr
|
||||
(pattern e:id #:where (symbol->string e))
|
||||
(pattern e)
|
||||
(pattern (e . rest:λ%expr))))
|
||||
|
||||
(define-syntax (λ% stx)
|
||||
(syntax-parse stx
|
||||
[(_ expr )]))
|
||||
|#)
|
||||
|
|
@ -1,58 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require (for-label typed/racket/base
|
||||
"percent.rkt"))
|
||||
|
||||
@title{@racket[let-in] binding and destructuring form}
|
||||
|
||||
@defform[#:literals (in = and)
|
||||
(% parallel-binding …
|
||||
maybe-in
|
||||
body …)
|
||||
#:grammar
|
||||
[(parallel-binding (code:line binding and parallel-binding)
|
||||
binding)
|
||||
(binding (code:line pattern … = expr))
|
||||
(maybe-in (code:line)
|
||||
in)
|
||||
(expr expression)]]{
|
||||
Locally binds the variables in the @racket[pattern]s to the
|
||||
@racket[expr]. Each binding clause should contain as many
|
||||
@racket[pattern]s as @racket[expr] produces values. The
|
||||
@racket[body …] forms are evaluated with the given
|
||||
variables bound.
|
||||
|
||||
The bindings are executed in sequence, as if bound with
|
||||
@racket[let*], unless grouped using @racket[and], in which
|
||||
case they are executed in parallel, as if bound with
|
||||
@racket[let].
|
||||
|
||||
NOTE: TODO: for now bindings are run in sequence, and
|
||||
parallel bindings have not been implemented yet.}
|
||||
|
||||
|
||||
@defform[#:literals (: :: …)
|
||||
(define% (name pattern …)
|
||||
body …)
|
||||
#:grammar
|
||||
[(pattern variable
|
||||
[variable : type]
|
||||
cons-pattern
|
||||
list-pattern
|
||||
vector-pattern)
|
||||
(cons-pattern (pattern . pattern)
|
||||
(pattern :: pattern))
|
||||
(list-pattern (pattern …)
|
||||
(pattern … :: tail-pattern))
|
||||
(tail-pattern pattern)
|
||||
(vector-pattern #(pattern …))
|
||||
(variable identifier)]]{
|
||||
Locally binds the variables in the @racket[pattern]s to the
|
||||
@racket[expr]. Each binding clause should contain as many
|
||||
@racket[pattern]s as @racket[expr] produces values. The
|
||||
@racket[body …] forms are evaluated with the given
|
||||
variables bound.
|
||||
|
||||
The bindings are executed in parallel, as if bound with
|
||||
@racket[let].}
|
||||
|
||||
|
|
@ -1,114 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide repeat-stx)
|
||||
|
||||
(require syntax/stx
|
||||
(for-syntax racket/base
|
||||
racket/syntax
|
||||
syntax/parse))
|
||||
|
||||
(define-for-syntax (repeat-stx-2 stx)
|
||||
(syntax-parse stx
|
||||
[(a:id b:id)
|
||||
#'(λ _ a)]
|
||||
[(a:id (b:expr (~literal ...)))
|
||||
#`(λ (bs) (stx-map #,(repeat-stx-2 #'(a b)) bs))]))
|
||||
|
||||
(define-for-syntax (repeat-stx-1 stx)
|
||||
(syntax-parse stx
|
||||
[(a:id b:expr)
|
||||
#`(λ (a bs) (#,(repeat-stx-2 #'(a b)) bs))]
|
||||
[((a:expr (~literal ...)) (b:expr (~literal ...)))
|
||||
#`(λ (s1 s2) (stx-map #,(repeat-stx-1 #'(a b)) s1 s2))]))
|
||||
|
||||
(define-syntax (repeat-stx stx)
|
||||
(syntax-parse stx
|
||||
[(_ a:expr b:expr)
|
||||
#`(#,(repeat-stx-1 #'(a b)) #'a #'b)])))
|
||||
|
||||
(module test racket
|
||||
(require (submod ".." untyped))
|
||||
(require syntax/parse
|
||||
rackunit)
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(1 2)
|
||||
[(a b)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx a b)))])
|
||||
1)
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(1 2 3)
|
||||
[(a b ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx a (b ...))))])
|
||||
'(1 1))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(1 (2 3) (uu vv ww) (xx yy))
|
||||
[(a (b ...) ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx a ((b ...) ...))))])
|
||||
'((1 1) (1 1 1) (1 1)))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(1 ((2) (3 3)) ((uu) (vv vv) (ww ww ww)) ((xx) (yy)))
|
||||
[(a ((b ...) ...) ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx a (((b ...) ...) ...))))])
|
||||
'(((1) (1 1)) ((1) (1 1) (1 1 1)) ((1) (1))))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'([1 x] [2 y] [3 z])
|
||||
[([a b] ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx (a ...) (b ...))))])
|
||||
'(1 2 3))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'((1 2 3) (a b))
|
||||
[([a b ...] ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx (a ...) ((b ...) ...))))])
|
||||
'((1 1) (a)))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(((1 2 3) (a b)) ((x y z t) (-1 -2)))
|
||||
[[[[a b ...] ...] ...]
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx ((a ...) ...) (((b ...) ...) ...))))])
|
||||
'(((1 1) (a)) ((x x x) (-1))))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'((f (1 2 3) (a b)) (g (x y z t) (-1 -2)))
|
||||
[[[a (b ...) ...] ...]
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx (a ...) (((b ...) ...) ...))))])
|
||||
'(((f f f) (f f)) ((g g g g) (g g))))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'((h () ()) (i () (x y z) ()))
|
||||
[([a (b ...) ...] ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx (a ...) (((b ...) ...) ...))))])
|
||||
'((() ()) (() (i i i) ()))))
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules
|
||||
(provide require/provide)
|
||||
|
||||
(define-syntax (require/provide stx)
|
||||
(syntax-case stx ()
|
||||
[(_ require-spec ...)
|
||||
#'(begin
|
||||
(require require-spec ...)
|
||||
(provide (all-from-out require-spec ...)))]))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(module ma typed/racket
|
||||
(define require-provide-foo 7)
|
||||
(provide require-provide-foo))
|
||||
(module mb typed/racket
|
||||
(require (submod ".." ".."))
|
||||
(require/provide (submod ".." ma)))
|
||||
(require 'mb)
|
||||
(check-equal? require-provide-foo 7)))
|
||||
|
|
@ -1,186 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules
|
||||
(provide sequence-length>=
|
||||
in-last?
|
||||
in-tails
|
||||
in-heads
|
||||
in-split
|
||||
in-split*
|
||||
*in-split
|
||||
Syntax-Listof
|
||||
my-in-syntax
|
||||
in-syntax
|
||||
sequence-cons
|
||||
sequence-null
|
||||
sequence-list)
|
||||
|
||||
(require racket/sequence)
|
||||
|
||||
;; sequence-length>=
|
||||
(begin
|
||||
(: sequence-length>= (→ (Sequenceof Any) Index Boolean))
|
||||
(define (sequence-length>= s l)
|
||||
(let-values ([(more? next) (sequence-generate s)])
|
||||
(define (rec [remaining : Index]) : Boolean
|
||||
(if (= remaining 0)
|
||||
#t
|
||||
(and (more?)
|
||||
(begin (next)
|
||||
(rec (sub1 remaining))))))
|
||||
(rec l))))
|
||||
|
||||
;; in-last?
|
||||
;; Returns a sequence of the same length as `s`. All values in the sequence
|
||||
;; are #f, except for the last one which is 'last.
|
||||
(begin
|
||||
(: in-last? (→ (Sequenceof Any) (Sequenceof (U #f 'last))))
|
||||
(define (in-last? s)
|
||||
(if (sequence-length>= s 1)
|
||||
(sequence-append (sequence-map (λ _ #f) (sequence-tail s 1))
|
||||
(in-value 'last))
|
||||
empty-sequence)))
|
||||
|
||||
;; in-heads and in-tails
|
||||
(begin
|
||||
(: in-tails (∀ (T) (→ (Listof T) (Listof (Pairof T (Listof T))))))
|
||||
(define (in-tails l)
|
||||
(if (null? l)
|
||||
'()
|
||||
(cons l (in-tails (cdr l)))))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (for/list : (Listof (Listof Number))
|
||||
([x : (Listof Number) (in-tails '(1 2 3 4 5))]) x)
|
||||
'((1 2 3 4 5) (2 3 4 5) (3 4 5) (4 5) (5)))
|
||||
(let ((l '(1 2 3 4 5)))
|
||||
(check-true (eq? (caddr (for/list : (Listof (Listof Number))
|
||||
([x : (Listof Number) (in-tails l)]) x))
|
||||
(cddr l)))))
|
||||
|
||||
(: in-heads (∀ (T) (→ (Listof T) (Listof (Pairof T (Listof T))))))
|
||||
(define (in-heads l)
|
||||
(: my-append1 (→ (Listof T) T (Pairof T (Listof T))))
|
||||
(define (my-append1 x y)
|
||||
(if (null? x)
|
||||
(list y)
|
||||
(cons (car x) (my-append1 (cdr x) y))))
|
||||
|
||||
(define (on-heads/private [acc-head : (Listof T)] [l : (Listof T)])
|
||||
: (Listof (Pairof T (Listof T)))
|
||||
(if (null? l)
|
||||
'()
|
||||
(let ([new-head (my-append1 acc-head (car l))])
|
||||
(cons new-head (on-heads/private new-head (cdr l))))))
|
||||
(on-heads/private '() l))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (for/list : (Listof (Listof Number))
|
||||
([x : (Listof Number) (in-heads '(1 2 3 4 5))]) x)
|
||||
'((1) (1 2) (1 2 3) (1 2 3 4) (1 2 3 4 5)))))
|
||||
|
||||
;; in-split, in-split*, *in-split, *in-split*
|
||||
(begin
|
||||
;; Can't write the type of in-split, because typed/racket doesn't allow
|
||||
;; writing (Sequenceof A B), just (Sequenceof A).
|
||||
;; in-parallel's type has access to the multi-valued version of Sequenceof,
|
||||
;; though, so we let typed/racket propagate the inferred type.
|
||||
(define #:∀ (T) (in-split [l : (Listof T)])
|
||||
(in-parallel (sequence-append (in-value '()) (in-heads l))
|
||||
(sequence-append (in-tails l) (in-value '()))))
|
||||
|
||||
;; Same as in-split, but without the empty tail.
|
||||
(define #:∀ (T) (in-split* [l : (Listof T)])
|
||||
(in-parallel (sequence-append (in-value '()) (in-heads l))
|
||||
(sequence-append (in-tails l))))
|
||||
|
||||
;; Same as in-split, but without the empty head.
|
||||
(define #:∀ (T) (*in-split [l : (Listof T)])
|
||||
(in-parallel (in-heads l)
|
||||
(sequence-append (sequence-tail (in-tails l) 1)
|
||||
(in-value '()))))
|
||||
|
||||
(define #:∀ (T) (*in-split* [l : (Listof T)])
|
||||
(in-parallel (in-heads l)
|
||||
(sequence-tail (in-tails l) 1))))
|
||||
|
||||
;; my-in-syntax and Syntax-Listof
|
||||
(begin
|
||||
;; See also syntax-e, which does not flatten syntax pairs, and syntax->list,
|
||||
;; which isn't correctly typed (won't take #'(a . (b c d e))).
|
||||
(define-type (Syntax-Listof T)
|
||||
(Rec R (Syntaxof (U Null
|
||||
(Pairof T R)
|
||||
(Listof T)))))
|
||||
|
||||
;; in-syntax is now provided by racket/sequence.
|
||||
(: my-in-syntax (∀ (T) (→ (Syntax-Listof T)
|
||||
(Listof T))))
|
||||
(define (my-in-syntax stx)
|
||||
(let ((e (syntax-e stx)))
|
||||
(if (null? e)
|
||||
e
|
||||
(if (syntax? (cdr e))
|
||||
(cons (car e) (my-in-syntax (cdr e)))
|
||||
e))))
|
||||
|
||||
(define (test-in-syntax)
|
||||
; (ann `(,#'(a . b) ,#'(c . d))
|
||||
; (Listof (Syntaxof (U (Pairof (Syntaxof 'a) (Syntaxof 'b))
|
||||
; (Pairof (Syntaxof 'c) (Syntaxof 'c))))))
|
||||
(my-in-syntax #'((a . b) (c . d)))
|
||||
; (ann `(,#'a ,#'b ,#'c ,#'d ,#'e) (Listof (Syntaxof (U 'a 'b 'c 'd))))
|
||||
(my-in-syntax #'(a . (b c d e)))
|
||||
; (ann '() (Listof (Syntaxof Nothing)))
|
||||
(my-in-syntax #'())))
|
||||
|
||||
;; combining sequences:
|
||||
;; sequence-cons
|
||||
;; sequence-null
|
||||
;; sequence-list
|
||||
|
||||
(begin
|
||||
(: sequence-cons (∀ (A B) (→ (Sequenceof A) (Sequenceof B)
|
||||
(Sequenceof (cons A B)))))
|
||||
(define (sequence-cons sa sb)
|
||||
(sequence-map (λ ([x : (List A B)]) (cons (car x) (cadr x)))
|
||||
(in-values-sequence (in-parallel sa sb))))
|
||||
|
||||
(: sequence-null (Sequenceof Null))
|
||||
(define sequence-null (in-cycle (in-value '())))
|
||||
|
||||
;; sequence-list should have the type:
|
||||
;; (∀ (A ...) (→ (Sequenceof A) ... (Sequenceof (List A ...)))))
|
||||
;; But the type system rejects the two definitions below.
|
||||
(: sequence-list (∀ (A) (→ (Sequenceof A) *
|
||||
(Sequenceof (Listof A)))))
|
||||
(define (sequence-list . sequences)
|
||||
(if (null? sequences)
|
||||
sequence-null
|
||||
(sequence-cons (car sequences)
|
||||
(apply sequence-list (cdr sequences)))))
|
||||
|
||||
#|
|
||||
(: sequence-list (∀ (A ...) (→ (Sequenceof A) ...
|
||||
(Sequenceof (List A ...)))))
|
||||
(define (sequence-list . sequences)
|
||||
(if (null? sequences)
|
||||
sequence-null
|
||||
(sequence-cons (car sequences)
|
||||
(apply sequence-list (cdr sequences)))))
|
||||
|#
|
||||
|
||||
#|
|
||||
(: sequence-list (∀ (F R ...)
|
||||
(case→ [→ (Sequenceof Null)]
|
||||
[→ (Sequenceof F) (Sequenceof R) ...
|
||||
(Sequenceof (List F R ...))])))
|
||||
(define sequence-list
|
||||
(case-lambda
|
||||
[()
|
||||
sequence-null]
|
||||
[(sequence . sequences)
|
||||
(sequence-cons sequence (apply sequence-list sequences))]))
|
||||
|#))
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide set-map→set)
|
||||
(: set-map→set (∀ (e b) (→ (Setof e) (→ e b) (Setof b))))
|
||||
(define (set-map→set s f) (list->set (set-map s f))))
|
||||
|
|
@ -1,407 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules
|
||||
(provide stx-list
|
||||
stx-e
|
||||
stx-pair
|
||||
|
||||
syntax-cons-property
|
||||
stx-map-nested
|
||||
identifier-length
|
||||
identifier->string
|
||||
(rename-out [identifier->string identifier→string])
|
||||
;stx-map-nested
|
||||
|
||||
stx-car
|
||||
stx-cdr
|
||||
stx-null?
|
||||
stx-pair?
|
||||
|
||||
stx-cons
|
||||
|
||||
Stx-List?
|
||||
Syntax-Pairs-of
|
||||
|
||||
stx-drop-last
|
||||
|
||||
stx-foldl
|
||||
|
||||
stx-assoc
|
||||
cdr-stx-assoc
|
||||
|
||||
check-duplicate-identifiers
|
||||
|
||||
nameof
|
||||
(all-from-out syntax/stx))
|
||||
|
||||
(require "typed-untyped.rkt")
|
||||
(require-typed/untyped "sequence.rkt")
|
||||
|
||||
(require syntax/stx)
|
||||
|
||||
;; match-expanders:
|
||||
;; stx-list
|
||||
;; stx-e
|
||||
;; stx-pair
|
||||
(begin
|
||||
(define-match-expander stx-list
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ pat ...)
|
||||
#'(? syntax?
|
||||
(app syntax->list (list pat ...)))])))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (match #'(1 2 3)
|
||||
[(stx-list a b c) (list (syntax-e c)
|
||||
(syntax-e b)
|
||||
(syntax-e a))])
|
||||
'(3 2 1))
|
||||
|
||||
(check-equal? (match #'(1 2 3)
|
||||
[(stx-list a ...) (map (inst syntax-e Positive-Byte) a)])
|
||||
'(1 2 3))
|
||||
|
||||
#;(check-equal? (match #`(1 . (2 3))
|
||||
[(stx-list a b c) (list (syntax-e c)
|
||||
(syntax-e b)
|
||||
(syntax-e a))])
|
||||
'(3 2 1)))
|
||||
|
||||
;; stx-e
|
||||
(define-match-expander stx-e
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ pat)
|
||||
#'(? syntax?
|
||||
(app syntax-e pat))])))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (match #'x [(stx-e s) s]) 'x)
|
||||
(check-equal? (match #'(x . y) [(stx-e (cons a b)) (cons (syntax-e b)
|
||||
(syntax-e a))])
|
||||
'(y . x)))
|
||||
|
||||
(define-match-expander stx-pair
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ pat-car pat-cdr)
|
||||
#'(? syntax?
|
||||
(app syntax-e (cons pat-car pat-cdr)))])))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (match #'(x . y) [(stx-pair a b) (cons (syntax-e b)
|
||||
(syntax-e a))])
|
||||
'(y . x))
|
||||
(check-equal? (match #'(x y z) [(stx-pair a b) (cons (map syntax->datum b)
|
||||
(syntax->datum a))])
|
||||
'((y z) . x))))
|
||||
|
||||
;; utilities:
|
||||
;; syntax-cons-property
|
||||
;; identifier-length
|
||||
;; identifier->string
|
||||
;; stx-map-nested
|
||||
(begin
|
||||
(: syntax-cons-property (∀ (A) (→ (Syntaxof A) Symbol Any (Syntaxof A))))
|
||||
(define (syntax-cons-property stx key v)
|
||||
(let ([orig (syntax-property stx key)])
|
||||
(syntax-property stx key (cons v (or orig '())))))
|
||||
|
||||
(: identifier-length (→ Identifier Index))
|
||||
(define (identifier-length id) (string-length (identifier->string id)))
|
||||
|
||||
(: identifier->string (→ Identifier String))
|
||||
(define (identifier->string id) (symbol->string (syntax-e id)))
|
||||
|
||||
(: stx-map-nested (∀ (A B) (→ (→ A B)
|
||||
(Syntaxof (Listof (Syntaxof (Listof A))))
|
||||
(Listof (Listof B)))))
|
||||
(define (stx-map-nested f stx)
|
||||
(map (λ ([x : (Syntaxof (Listof A))])
|
||||
(map f (syntax-e x)))
|
||||
(syntax-e stx))))
|
||||
|
||||
;; accessors:
|
||||
;; stx-car
|
||||
;; stx-cdr
|
||||
;; stx-null?
|
||||
;; stx-pair?
|
||||
(begin
|
||||
#|
|
||||
(require/typed syntax/stx
|
||||
[stx-car (∀ (A B) (→ (Syntaxof (Pairof A B)) A))]
|
||||
[stx-cdr (∀ (A B) (→ (Syntaxof (Pairof A B)) B))])
|
||||
|#
|
||||
|
||||
(: stx-car (∀ (A B)
|
||||
(case→ (→ (Syntaxof (Pairof A B)) A)
|
||||
;; TODO: Not typesafe!
|
||||
(→ (U (Syntaxof (Listof A)) (Listof A)) A))))
|
||||
(define (stx-car p) (car (if (syntax? p) (syntax-e p) p)))
|
||||
|
||||
(: stx-cdr (∀ (A B)
|
||||
(case→ (→ (Syntaxof (Pairof A B))
|
||||
B)
|
||||
;; TODO: Not typesafe!
|
||||
(→ (U (Syntaxof (Listof A)) (Listof A))
|
||||
(Listof A)))))
|
||||
(define (stx-cdr p) (cdr (if (syntax? p) (syntax-e p) p)))
|
||||
|
||||
(: stx-null? (→ Any Boolean : (U (Syntaxof Null) Null)))
|
||||
(define (stx-null? v)
|
||||
(if-typed
|
||||
((make-predicate (U (Syntaxof Null) Null)) v)
|
||||
(or (null? v) (and (syntax? v) (null? (syntax-e v))))))
|
||||
|
||||
(module+ test
|
||||
(check-equal? (stx-null? #f) #f)
|
||||
(check-equal? (stx-null? 'a) #f)
|
||||
(check-equal? (stx-null? '()) #t)
|
||||
(check-equal? (stx-null? #'()) #t)
|
||||
(check-equal? (stx-null? #''()) #f)
|
||||
(check-equal? (stx-null? #'a) #f))
|
||||
|
||||
(: stx-pair? (→ Any Boolean : (U (Pairof Any Any)
|
||||
(Syntaxof (Pairof Any Any)))))
|
||||
(define (stx-pair? v)
|
||||
(if-typed
|
||||
((make-predicate (U (Pairof Any Any)
|
||||
(Syntaxof (Pairof Any Any))))
|
||||
v)
|
||||
(or (pair? v) (and (syntax? v) (pair? (syntax-e v)))))))
|
||||
|
||||
;; constructors:
|
||||
;; stx-cons
|
||||
(begin
|
||||
(module m-stx-cons-untyped racket
|
||||
(provide stx-cons list->stx list*->stx)
|
||||
|
||||
(define (stx-cons a b) #`(#,a . #,b))
|
||||
(define (list->stx l) #`#,l)
|
||||
(define (list*->stx l*) #`#,l*))
|
||||
|
||||
(if-typed
|
||||
(module m-stx-cons-typed typed/racket
|
||||
(provide stx-cons list->stx list*->stx)
|
||||
(require (only-in typed/racket/unsafe unsafe-require/typed))
|
||||
(unsafe-require/typed
|
||||
(submod ".." m-stx-cons-untyped)
|
||||
[stx-cons (∀ (A B)
|
||||
(→ (Syntaxof A)
|
||||
(Syntaxof B)
|
||||
(Syntaxof (Pairof (Syntaxof A) (Syntaxof B)))))]
|
||||
[list->stx (∀ (A)
|
||||
(→ (Listof (Syntaxof A))
|
||||
(Syntaxof (Listof (Syntaxof A)))))]
|
||||
[list*->stx (∀ (A B)
|
||||
(→ (Rec R (U B (Pairof (Syntaxof A) R)))
|
||||
(Syntaxof (Rec R (U B (Pairof (Syntaxof A) R))))))]))
|
||||
(module m-stx-cons-typed racket
|
||||
(provide stx-cons list->stx list*->stx)
|
||||
(require (submod ".." m-stx-cons-untyped))))
|
||||
|
||||
(require 'm-stx-cons-typed)
|
||||
|
||||
(module+ test
|
||||
(require ;(submod "..")
|
||||
typed/rackunit)
|
||||
|
||||
(check-equal? (syntax->datum
|
||||
(ann (stx-cons #'a #'(b c))
|
||||
(Syntaxof (Pairof (Syntaxof 'a)
|
||||
(Syntaxof (List (Syntaxof 'b)
|
||||
(Syntaxof 'c)))))))
|
||||
'(a b c))
|
||||
|
||||
(check-equal? (syntax->datum
|
||||
(ann (stx-cons #'1 (ann #'2 (Syntaxof 2)))
|
||||
(Syntaxof (Pairof (Syntaxof 1)
|
||||
(Syntaxof 2)))))
|
||||
'(1 . 2))))
|
||||
|
||||
;; stx-drop-last
|
||||
(begin
|
||||
(: drop-last (∀ (A) (→ (Listof A) (Listof A))))
|
||||
(define (drop-last l)
|
||||
(if (and (pair? l) (pair? (cdr l)))
|
||||
(cons (car l) (drop-last (cdr l)))
|
||||
'()))
|
||||
|
||||
(define-type (Stx-List? A)
|
||||
(U Null
|
||||
(Pairof A (Stx-List? A))
|
||||
(Syntaxof Null)
|
||||
(Syntaxof (Pairof A (Stx-List? A)))))
|
||||
|
||||
(define-type (Syntax-Pairs-of A)
|
||||
(U (Syntaxof Null)
|
||||
(Syntaxof (Pairof A (Syntax-Pairs-of A)))))
|
||||
|
||||
(module+ test
|
||||
(require-typed/untyped "typed-rackunit.rkt")
|
||||
|
||||
(check-ann #'() (Stx-List? (Syntaxof Number)))
|
||||
(check-ann #'(1) (Stx-List? (Syntaxof Number)))
|
||||
(check-ann #'(1 2 3) (Stx-List? (Syntaxof Number)))
|
||||
(check-ann #'(1 2 . ()) (Stx-List? (Syntaxof Number)))
|
||||
(check-ann #'(1 . (2 . (3 . ()))) (Stx-List? (Syntaxof Number)))
|
||||
(check-ann #'(1 . (2 3 . ())) (Stx-List? (Syntaxof Number)))
|
||||
(check-ann #'(1 2 . (3 4 . (5))) (Stx-List? (Syntaxof Number))))
|
||||
|
||||
(: stx->list (∀ (A) (→ (Stx-List? (Syntaxof A)) (Listof (Syntaxof A)))))
|
||||
(define (stx->list l)
|
||||
(cond [(null? l)
|
||||
'()]
|
||||
[(pair? l)
|
||||
(cons (car l) (stx->list (cdr l)))]
|
||||
[else
|
||||
(stx->list (syntax-e l))]))
|
||||
|
||||
(: stx-drop-last
|
||||
(∀ (A) (→ (Stx-List? (Syntaxof A)) (Syntaxof (Listof (Syntaxof A))))))
|
||||
(define (stx-drop-last l)
|
||||
(list->stx (drop-last (stx->list l))))
|
||||
#|
|
||||
#;(cond [(null? l)
|
||||
#'()]
|
||||
[(pair? l)
|
||||
(cond [(null? (cdr l))
|
||||
#'()]
|
||||
[(pair? (cdr l))
|
||||
]
|
||||
[else
|
||||
(let* ([res (stx-drop-last (cdr l))]
|
||||
[e (syntax-e res)])
|
||||
(if (null? e)
|
||||
(stx-cons (car l) #'())
|
||||
(stx-cons (car l) res)))]
|
||||
[else
|
||||
(stx-drop-last (syntax-e l))])
|
||||
|
||||
#;(if (if-typed ((make-predicate (Syntaxof Any)) l) (syntax? l))
|
||||
(stx-drop-last (syntax-e l))
|
||||
(if (null? l)
|
||||
#'()
|
||||
(stx-cons (car l)
|
||||
(stx-drop-last (cdr l)))))))
|
||||
|#)
|
||||
|
||||
;; stx-foldl
|
||||
(begin
|
||||
(: stx-foldl
|
||||
(∀ (E F G Acc)
|
||||
(case→ (→ (→ E Acc Acc)
|
||||
Acc
|
||||
(U (Syntaxof (Listof E)) (Listof E))
|
||||
Acc)
|
||||
(→ (→ E F Acc Acc)
|
||||
Acc
|
||||
(U (Syntaxof (Listof E)) (Listof E))
|
||||
(U (Syntaxof (Listof F)) (Listof F))
|
||||
Acc)
|
||||
(→ (→ E F G Acc Acc)
|
||||
Acc
|
||||
(U (Syntaxof (Listof E)) (Listof E))
|
||||
(U (Syntaxof (Listof F)) (Listof F))
|
||||
(U (Syntaxof (Listof G)) (Listof G))
|
||||
Acc))))
|
||||
(define stx-foldl
|
||||
(case-lambda
|
||||
[(f acc l)
|
||||
(if (stx-null? l)
|
||||
acc
|
||||
(stx-foldl f (f (stx-car l) acc) (stx-cdr l)))]
|
||||
[(f acc l l2)
|
||||
(if (or (stx-null? l) (stx-null? l2))
|
||||
acc
|
||||
(stx-foldl f
|
||||
(f (stx-car l) (stx-car l2) acc)
|
||||
(stx-cdr l)
|
||||
(stx-cdr l2)))]
|
||||
[(f acc l l2 l3)
|
||||
(if (or (stx-null? l) (stx-null? l2) (stx-null? l3))
|
||||
acc
|
||||
(stx-foldl f
|
||||
(f (stx-car l) (stx-car l2) (stx-car l3) acc)
|
||||
(stx-cdr l)
|
||||
(stx-cdr l2)
|
||||
(stx-cdr l3)))])))
|
||||
|
||||
;; stx-assoc
|
||||
;; cdr-stx-assoc
|
||||
(begin
|
||||
(: stx-assoc (∀ (T) (case→
|
||||
(→ Identifier
|
||||
(U (Syntaxof (Listof (Syntaxof (Pairof Identifier
|
||||
T))))
|
||||
(Listof (Syntaxof (Pairof Identifier T))))
|
||||
(U (Syntaxof (Pairof Identifier T)) #f))
|
||||
(→ Identifier
|
||||
(Listof (Pairof Identifier T))
|
||||
(U (Pairof Identifier T) #f)))))
|
||||
(define (stx-assoc id alist)
|
||||
(let* ([e-alist (if (syntax? alist)
|
||||
(syntax->list alist)
|
||||
alist)]
|
||||
[e-e-alist (cond
|
||||
[(null? e-alist) '()]
|
||||
[(syntax? (car e-alist))
|
||||
(map (λ ([x : (Syntaxof (Pairof Identifier T))])
|
||||
(cons (stx-car x) x))
|
||||
e-alist)]
|
||||
[else
|
||||
(map (λ ([x : (Pairof Identifier T)])
|
||||
(cons (car x) x))
|
||||
e-alist)])]
|
||||
[result (assoc id e-e-alist free-identifier=?)])
|
||||
(if result (cdr result) #f)))
|
||||
|
||||
(: cdr-stx-assoc
|
||||
(∀ (T) (case→ (→ Identifier
|
||||
(U (Syntaxof (Listof (Syntaxof (Pairof Identifier T))))
|
||||
(Listof (Syntaxof (Pairof Identifier T)))
|
||||
(Listof (Pairof Identifier T)))
|
||||
(U T #f)))))
|
||||
(define (cdr-stx-assoc id alist)
|
||||
(if (null? alist)
|
||||
#f
|
||||
;; The typechecker is not precise enough, and the code below does not
|
||||
;; work if we factorize it:
|
||||
;; (if (and (list? alist) (syntax? (car alist))) … …)
|
||||
(if (list? alist)
|
||||
(if (syntax? (car alist))
|
||||
(let ((res (stx-assoc id alist)))
|
||||
(if res (stx-cdr res) #f))
|
||||
(let ((res (stx-assoc id alist)))
|
||||
(if res (cdr res) #f)))
|
||||
(let ((res (stx-assoc id alist)))
|
||||
(if res (stx-cdr res) #f))))))
|
||||
|
||||
;; check-duplicate-identifiers
|
||||
(begin
|
||||
(: check-duplicate-identifiers (→ (Syntaxof (Listof (Syntaxof Symbol)))
|
||||
Boolean))
|
||||
(define (check-duplicate-identifiers ids)
|
||||
(if (check-duplicate-identifier (my-in-syntax ids)) #t #f)))
|
||||
|
||||
;; nameof
|
||||
(begin
|
||||
;; TODO: use the proper way to introduce arrows if possible.
|
||||
(define-syntax-rule (nameof x) (begin x 'x))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(let ((y 3))
|
||||
(check-equal? (nameof y) 'y))))
|
||||
|
||||
#|
|
||||
(define (raise-multi-syntax-error name message exprs)
|
||||
(let ([e (exn:fail:syntax "message"
|
||||
(current-continuation-marks)
|
||||
(list #'aaa #'bbb))])
|
||||
((error-display-handler) (exn-message e) e)))
|
||||
|#)
|
||||
|
|
@ -1,191 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
|
||||
(module m-stx-identifier racket
|
||||
(require racket/stxparam)
|
||||
|
||||
(provide stx)
|
||||
|
||||
(define-syntax-parameter stx
|
||||
(lambda (call-stx)
|
||||
(raise-syntax-error
|
||||
'stx
|
||||
"Can only be used in define-syntax/parse or λ/syntax-parse"
|
||||
call-stx))))
|
||||
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide stx
|
||||
define-syntax/parse
|
||||
λ/syntax-parse
|
||||
~maybe
|
||||
~maybe*
|
||||
~optkw
|
||||
~kw
|
||||
~lit
|
||||
~or-bug
|
||||
define-simple-macro
|
||||
λstx
|
||||
;template/loc
|
||||
;quasitemplate/loc
|
||||
template/debug
|
||||
quasitemplate/debug
|
||||
meta-eval)
|
||||
(begin-for-syntax
|
||||
(provide stx))
|
||||
|
||||
(require syntax/parse
|
||||
syntax/parse/define
|
||||
syntax/parse/experimental/template
|
||||
(for-syntax racket/syntax
|
||||
racket/stxparam)
|
||||
(for-meta 2 racket/base racket/syntax)
|
||||
racket/stxparam)
|
||||
|
||||
;(require "typed-untyped.rkt")
|
||||
;(require-typed/untyped "backtrace.rkt")
|
||||
(require (for-syntax "backtrace.rkt")
|
||||
"backtrace.rkt")
|
||||
|
||||
(define-syntax ~maybe
|
||||
(pattern-expander
|
||||
(λ (stx)
|
||||
(syntax-parse stx
|
||||
[(self pat ...)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
#`(#,(s #'~optional) (#,(s #'~seq) pat ...))]))))
|
||||
|
||||
(define-syntax ~maybe*
|
||||
(pattern-expander
|
||||
(λ (stx)
|
||||
(syntax-parse stx
|
||||
[(self name pat ...)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
#`(#,(s #'~and) name (#,(s #'~optional) (#,(s #'~seq) pat ...)))]))))
|
||||
|
||||
(define-syntax ~optkw
|
||||
(pattern-expander
|
||||
(λ (stx)
|
||||
(syntax-parse stx
|
||||
[(self kw:keyword)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
(define/with-syntax name
|
||||
(format-id #'kw "~a" (keyword->string (syntax-e #'kw))))
|
||||
#`(#,(s #'~optional) (#,(s #'~and) name kw))]))))
|
||||
|
||||
(define-syntax ~kw
|
||||
(pattern-expander
|
||||
(λ (stx)
|
||||
(syntax-parse stx
|
||||
[(self kw:keyword)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
(define/with-syntax name
|
||||
(format-id #'kw "~a" (keyword->string (syntax-e #'kw))))
|
||||
#`(#,(s #'~and) name kw)]))))
|
||||
|
||||
;; Circumvent the bug that causes "syntax-parse: duplicate attribute in: a" in
|
||||
;; (syntax-parse #'(x y z) [((~or a (a b c)) ...) #'(a ...)])
|
||||
(define-syntax ~or-bug
|
||||
(pattern-expander
|
||||
(λ (stx)
|
||||
(syntax-parse stx
|
||||
[(self pat ...)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
#`(#,(s #'~and) x (#,(s #'~parse) (#,(s #'~or) pat ...) #'x))]))))
|
||||
|
||||
(define-syntax ~lit
|
||||
(pattern-expander
|
||||
(λ (stx)
|
||||
(syntax-parse stx
|
||||
[(self (~optional (~seq name:id (~literal ~))) lit)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
(if (attribute name)
|
||||
#`(#,(s #'~and) name (#,(s #'~literal) lit))
|
||||
#`(#,(s #'~literal) lit))]
|
||||
[(self (~optional (~seq name:id (~literal ~))) lit …)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
(if (attribute name)
|
||||
#`(#,(s #'~and) name (#,(s #'~seq) (#,(s #'~literal) lit)))
|
||||
#`(#,(s #'~seq) (#,(s #'~literal) lit)))]))))
|
||||
|
||||
(require (submod ".." m-stx-identifier)
|
||||
(for-syntax (submod ".." m-stx-identifier)))
|
||||
|
||||
(define-simple-macro (define-syntax/parse (name . args) body0 . body)
|
||||
(define-syntax (name stx2)
|
||||
(with-backtrace (syntax->datum stx2)
|
||||
(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
||||
(syntax-parse stx2
|
||||
[(_ . args) body0 . body])))))
|
||||
|
||||
(define-simple-macro (λ/syntax-parse args . body)
|
||||
(λ (stx2)
|
||||
(with-backtrace (syntax->datum stx2)
|
||||
(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
||||
(syntax-parse stx2
|
||||
[args . body])))))
|
||||
|
||||
;; λstx
|
||||
(begin
|
||||
(define-syntax-rule (λstx (param ...) body ...)
|
||||
(λ (param ...)
|
||||
(with-syntax ([param param] ...)
|
||||
body ...)))
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (syntax->datum ((λstx (foo bar) #'(foo bar)) #'a #'b))
|
||||
(syntax->datum #'(a b)))))
|
||||
|
||||
;; template/loc
|
||||
(begin
|
||||
(define-syntax-rule (template/loc loc . tmpl)
|
||||
(quasisyntax/loc loc #,(template . tmpl))))
|
||||
|
||||
;; quasitemplate/loc
|
||||
(begin
|
||||
(define-syntax-rule (quasitemplate/loc loc . tmpl)
|
||||
(quasisyntax/loc loc #,(quasitemplate . tmpl))))
|
||||
|
||||
;; template/debug
|
||||
(begin
|
||||
(define-syntax (template/debug stx)
|
||||
(syntax-parse stx
|
||||
[(_ debug-attribute:id . rest)
|
||||
#'((λ (x)
|
||||
(when (attribute debug-attribute)
|
||||
(pretty-write (syntax->datum x)))
|
||||
x)
|
||||
(template . rest))])))
|
||||
|
||||
;; quasitemplate/debug
|
||||
(begin
|
||||
(define-syntax (quasitemplate/debug stx)
|
||||
(syntax-parse stx
|
||||
[(_ debug-attribute:id . rest)
|
||||
#'((λ (x)
|
||||
(when (attribute debug-attribute)
|
||||
(pretty-write (syntax->datum x)))
|
||||
x)
|
||||
(quasitemplate . rest))])))
|
||||
|
||||
;; meta-eval
|
||||
(begin
|
||||
;; TODO: this is kind of a hack, as we have to write:
|
||||
#;(with-syntax ([(x …) #'(a bb ccc)])
|
||||
(let ([y 70])
|
||||
(quasitemplate
|
||||
([x (meta-eval (+ #,y (string-length
|
||||
(symbol->string
|
||||
(syntax-e #'x)))))]
|
||||
…))))
|
||||
;; Where we need #,y instead of using:
|
||||
;; (+ y (string-length etc.)).
|
||||
(module m-meta-eval racket
|
||||
(provide meta-eval)
|
||||
(require syntax/parse/experimental/template)
|
||||
|
||||
(define-template-metafunction (meta-eval stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . body)
|
||||
#`#,(eval #'(begin . body))])))
|
||||
(require 'm-meta-eval)))
|
||||
|
|
@ -1,265 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require (for-label typed/racket/base
|
||||
syntax/parse
|
||||
;"template.rkt"
|
||||
))
|
||||
|
||||
@(define ellipses (racket ...))
|
||||
|
||||
@title{Versatile parser and template library}
|
||||
|
||||
Keywords: grammar, parser, template.
|
||||
|
||||
@defform[(parse expr [pattern body …] …)]{
|
||||
Analogous to @racket[syntax-parse], except it isn't
|
||||
specialized for syntax, but rather works for arbitrary
|
||||
s-expressions, including syntax ones (denoted by
|
||||
@racket[#'(…)] in the pattern).}
|
||||
|
||||
@defform[#:literals (: :: ... else struct)
|
||||
(tmpl template)
|
||||
#:grammar
|
||||
[(template variable
|
||||
[variable : type] ;; (ann variable type)
|
||||
;; cons-template
|
||||
(template . template)
|
||||
(template :: template)
|
||||
|
||||
;; list
|
||||
(template**)
|
||||
;; list*
|
||||
template**-dotted
|
||||
|
||||
;; vector
|
||||
#(template**)
|
||||
(vector . template**-dotted)
|
||||
|
||||
;; hash-template: template** must expand to a list of pairs.
|
||||
(hash . template**-dotted) ;; TODO: how to distinguish
|
||||
(hasheq . template**-dotted) ;; mutable and immutable?
|
||||
(hasheqv . template**-dotted)
|
||||
#hash([template . template])
|
||||
#hasheq([template . template])
|
||||
#hasheqv([template . template])
|
||||
|
||||
;; struct-template
|
||||
(struct-id template …)
|
||||
(struct struct-id template …)
|
||||
#s(prefab-id template …)
|
||||
#s(template template …) ;; Only allowed in untyped racket
|
||||
|
||||
;; box
|
||||
#&template
|
||||
|
||||
;; call-template
|
||||
(~identifier args …) ;; calls (identifier args …)
|
||||
(~ expr args …) ;; calls (expr args …)
|
||||
|
||||
;; unquote-template
|
||||
,expr
|
||||
,@(list expr)
|
||||
,@(list* expr) ;; must appear in last position.
|
||||
|
||||
|
||||
;; template-expander
|
||||
template-expander-id
|
||||
(template-expander-id args …)
|
||||
|
||||
;; maybe-template (should all be template expanders
|
||||
;; which means the system is extensible enough to express
|
||||
;; these special cases).
|
||||
(?? alt-template …)
|
||||
(?@ . template**-dotted)
|
||||
(??@ . template**-dotted)
|
||||
(?if condition template template)
|
||||
(|@if| condition template template)
|
||||
(if@ condition template template)
|
||||
(|@cond| [condition template] …)
|
||||
(|@cond| [condition template] … [else template])
|
||||
(cond@ condition template template)
|
||||
|
||||
;; like #,@(with-syntax ([meta-var #'template])
|
||||
;; #'(template**))
|
||||
(~let ([meta-var+args template])
|
||||
. template**-dotted)
|
||||
|
||||
(~sort key template ooo)
|
||||
(~loc stxloc . template)
|
||||
;; Like (template . template), but discards the first and
|
||||
;; keeps just the second. If the first contains pattern
|
||||
;; variables which are repeated, this has the effect of
|
||||
;; repeating the second as many times as the first. Example:
|
||||
;; #'(vector (~each some-pattern-var '()))
|
||||
;; => (vector '() '() '() '() '())
|
||||
(~each template template)
|
||||
|
||||
;; escaped
|
||||
(ddd escaped)
|
||||
|
||||
;;
|
||||
|
||||
;; literal
|
||||
#t
|
||||
#f
|
||||
string
|
||||
bytes
|
||||
number
|
||||
char
|
||||
keyword
|
||||
regexp
|
||||
pregexp)
|
||||
|
||||
(meta-var+args meta-var
|
||||
(meta-var meta-arg …))
|
||||
|
||||
(tail-template template)
|
||||
|
||||
;; specialize mid-sequence in repetition (diagonal-matrix-style)
|
||||
|
||||
(variable identifier)
|
||||
|
||||
(template**-dotted (template* … . template)
|
||||
template**)
|
||||
(template** (code:line template* …)
|
||||
(code:line template* … :: template)
|
||||
(code:line template* … (~rest . template)))
|
||||
(template* template
|
||||
(code:line template ooo)
|
||||
special-cased-template)
|
||||
(special-cased-template (code:line template vardd)
|
||||
(code:line template ddvar))
|
||||
;; Where var is an iterated variable.
|
||||
(vardd var.. ;; exclude the current iteration
|
||||
var...) ;; include the current iteration
|
||||
(ddvar ..var ;; exclude the current iteration
|
||||
...var) ;; include the current iteration
|
||||
|
||||
(ooo #,ellipses ;; TODO: make it a hyperlink
|
||||
___
|
||||
..k ;; k positive integer
|
||||
__k ;; k positive integer
|
||||
(code:line .. expr) ;; expr must return a positive integer
|
||||
(code:line __ expr)) ;; expr must return a positive integer
|
||||
(ddd #,ellipses)
|
||||
]]{
|
||||
TODO: implement the versatile template library.
|
||||
@racket[...]
|
||||
|
||||
TODO: support for typed/racket.
|
||||
|
||||
The patterns for @racket[parse] should all have a way to
|
||||
create a symmetric counterpart for @racket[tmpl], which
|
||||
produces the original value. This symmetry is important
|
||||
because allows lens-like macros, which operate on only part
|
||||
of the data structure, leaving everything else intact.
|
||||
|
||||
@racket[??] works like @racket[??] from
|
||||
@racket[syntax/parse/experimental/template], except it
|
||||
allows any number of alternatives (including 0, to avoid
|
||||
special-casing in macros). It is more or less equivalent to
|
||||
@racket[(?? a (?? b (?? c …)))], following syntax/parse's
|
||||
semantics.
|
||||
|
||||
@racket[?@] has the same meaning as in syntax/parse.
|
||||
|
||||
@racket[(??@ t* …)] is a shortcut for
|
||||
@racket[(?? (?@ t* …))]
|
||||
|
||||
For better compatibility with at-exp, @racket[|@if|] can be
|
||||
written @racket[if@], and the same goes for
|
||||
@racket[|@cond|] etc.
|
||||
|
||||
TODO: what's the difference between @racket[~],
|
||||
@racket[template-expander] and @racket[unquote]?
|
||||
@racket[template-expander] runs at compile-time and should
|
||||
treat its arguments as syntax.
|
||||
|
||||
Concerning unquoting, unlike @racket[racket]'s default
|
||||
behaviour in @RACKET[#'([x #,(y …)] …)], unquoting should
|
||||
not break the nesting of ellipses. How should we express
|
||||
voluntary variation of the level of nesting? @racket[~let]
|
||||
already allows expanding part of the template at some level
|
||||
and inserting it verbatim somewhere below, but it's not a
|
||||
silver bullet. One case which comes to mind is when some of
|
||||
the nested data should be mixed with less-nested data, for
|
||||
example going from
|
||||
@racket[([10 1 2 3] [100 4 5] [1000 6])] to
|
||||
@racket[([10 20 30] [400 500] [6000])] should be relatively
|
||||
easy to express. Maybe @racket[~let] with parameters can be
|
||||
a suitable generalized solution:
|
||||
@RACKET[({~let ([(addx v) #,(+ x v)]) [(addx y) …]} …)]
|
||||
|
||||
The special-cased template syntax should allow special
|
||||
treatment of the @racket[i]-th iteration in a doubly-nested
|
||||
loop: matching @racket[x] on @racket[(1 2 3 4 5)], and
|
||||
using the template @racket[(0 x.. ,(* x x) ..x 1) …] will
|
||||
produce @racket[(1 1 1 1 1)
|
||||
(0 4 1 1 1)
|
||||
(0 0 9 1 1)
|
||||
(0 0 0 16 1)
|
||||
(0 0 0 0 24)]. The pattern before
|
||||
@racket[x..] and the pattern after @racket[..x] can expand
|
||||
to multiple items which will be spliced in by wrapping it
|
||||
with @racket[?@].}
|
||||
|
||||
@section{Ideas for implementation}
|
||||
|
||||
@subsection{Extensibility (expanders)}
|
||||
|
||||
Allow normal, inline-prefix, inline-postfix and inline-infix
|
||||
expanders, which can bind using regular expressions. This
|
||||
allows implementing exotic syntax like @racket[var..]
|
||||
(postfix, operates on the pattern preceeding it),
|
||||
@racket[..var] (postfix, operates on the pattern after it),
|
||||
@racket[(… escaped-pattern)] (normal, operates on the
|
||||
containing s-exp)
|
||||
|
||||
@subsection{Customization}
|
||||
|
||||
For things that are likely to be customized by the user in
|
||||
the whole file scope, define a grammar/custom module, used
|
||||
as follows:
|
||||
|
||||
@racketblock[(require grammar/custom)
|
||||
(grammar/custom option …)]
|
||||
|
||||
The @racket[grammar/custom] macro expands to
|
||||
@racket[(require grammar/core)] followed by a bunch of
|
||||
@racket[define-syntax] which wrap the core macros, providing
|
||||
them the custom options:
|
||||
|
||||
@racketblock[(require grammar/core)
|
||||
(define-syntax-rule (parse . rest)
|
||||
(parse/core #:global-options (option …) . rest))
|
||||
(define-syntax-rule (tmpl . rest)
|
||||
(parse/core #:global-options (option …) . rest))]
|
||||
|
||||
This can also be used to rename the @racket[parse] and
|
||||
@racket[tmpl] macros, if desired (for example,
|
||||
@racket[tmpl] could be renamed to @racket[quasisyntax], or
|
||||
something similar).
|
||||
|
||||
Otherwise, @racket[grammar/custom] could just @racket[set!]
|
||||
some for-syntax variable which stores the options. A second
|
||||
boolean for-syntax variable could be used to check if
|
||||
@racket[grammar/custom] was called twice, and throw an error
|
||||
in that case.
|
||||
|
||||
Or maybe we should just use units? Can they be customized in
|
||||
a similar way?
|
||||
|
||||
The idea is to avoid having to wrap the whole file in a
|
||||
@racket[(parameterize …)], and be able to easily
|
||||
@racket[provide] a customized variation of this library:
|
||||
|
||||
@racketblock[(provide (customized-out grammar/custom))]
|
||||
|
||||
@subsection{Things to look at}
|
||||
|
||||
@itemlist[
|
||||
@item{@racket[math/arry], for @racket[::] and array
|
||||
broadcasting.}
|
||||
@item{Quasipatterns in @racket[match].}
|
||||
@item{The @racket[lens] library}]
|
||||
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
;; raco pkg install alexis-util
|
||||
;; or:
|
||||
;; raco pkg install threading
|
||||
(require alexis/util/threading
|
||||
(for-syntax racket/syntax
|
||||
syntax/parse))
|
||||
|
||||
(define-syntax-rule (~>_ clause ... expr) (~> expr clause ...))
|
||||
(define-syntax (<~ stx)
|
||||
(syntax-parse stx
|
||||
[(_ expr clause ...)
|
||||
(define/with-syntax (r-clause ...)
|
||||
(reverse (syntax->list #'(clause ...))))
|
||||
#'(~> expr r-clause ...)]))
|
||||
|
||||
(define-syntax-rule (<~_ clause ... expr) (<~ expr clause ...))
|
||||
|
||||
(provide <~ <~_ ~>_ ~> ~>> _ (rename-out [_ ♦] [<~_ <~♦] [~>_ ~>♦])))
|
||||
|
|
@ -1,25 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide tmpl-cdr-assoc-syntax
|
||||
(rename-out [tmpl-cdr-assoc-syntax !cdr-assoc]))
|
||||
|
||||
(module m-tmpl-cdr-assoc-syntax racket
|
||||
(provide tmpl-cdr-assoc-syntax)
|
||||
|
||||
(require syntax/parse
|
||||
syntax/parse/experimental/template
|
||||
(submod "stx.rkt" untyped)
|
||||
(submod "multiassoc-syntax.rkt" untyped)
|
||||
(submod "aliases.rkt" untyped))
|
||||
|
||||
(define-template-metafunction (tmpl-cdr-assoc-syntax stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~optional (~seq #:default default)) query [k . v] …)
|
||||
(if (attribute default)
|
||||
(let ([r (assoc-syntax #'query #'([k . v] …))])
|
||||
(if r
|
||||
(stx-cdr r)
|
||||
#'default))
|
||||
(cdr-assoc-syntax #'query #'([k . v] …)))])))
|
||||
(require 'm-tmpl-cdr-assoc-syntax))
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide !each)
|
||||
|
||||
(module m-!each racket
|
||||
(provide !each)
|
||||
(require syntax/parse/experimental/template)
|
||||
|
||||
(define-template-metafunction (!each stx)
|
||||
(syntax-case stx ()
|
||||
[(_ a b) #'b])))
|
||||
|
||||
(require 'm-!each))
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(module m racket
|
||||
(require syntax/parse
|
||||
syntax/parse/experimental/template)
|
||||
(provide (rename-out [template syntax]
|
||||
[quasitemplate quasisyntax])
|
||||
(all-from-out syntax/parse
|
||||
syntax/parse/experimental/template)))
|
||||
|
||||
(require 'm)
|
||||
|
||||
(syntax-parse #'(a b)
|
||||
[(x (~optional y) z)
|
||||
#'(x (?? y 1) z)])
|
||||
|
|
@ -1,28 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide cars cdrs lists)
|
||||
|
||||
#|
|
||||
;; This does not work, in the end.
|
||||
(provide imap)
|
||||
(define-syntax (imap stx)
|
||||
(syntax-parse stx
|
||||
[(_ lst:expr var:id (~optional (~literal →)) . body)
|
||||
#'(let ()
|
||||
(define #:∀ (T) (inlined-map [l : (Listof T)])
|
||||
(if (null? l)
|
||||
'()
|
||||
(cons (let ([var (car l)]) . body)
|
||||
(inlined-map (cdr l)))))
|
||||
(inlined-map lst))]))
|
||||
|#
|
||||
|
||||
(: cars (∀ (A) (→ (Listof (Pairof A Any)) (Listof A))))
|
||||
(define (cars l) ((inst map A (Pairof A Any)) car l))
|
||||
|
||||
(: cdrs (∀ (B) (→ (Listof (Pairof Any B)) (Listof B))))
|
||||
(define (cdrs l) ((inst map B (Pairof Any B)) cdr l))
|
||||
|
||||
(: lists (∀ (A) (→ (Listof A) (Listof (List A)))))
|
||||
(define (lists l) ((inst map (List A) A) (λ (x) (list x)) l)))
|
||||
|
|
@ -1,69 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
(provide check-equal?-classes
|
||||
check-equal?-classes:)
|
||||
|
||||
(require "typed-untyped.rkt")
|
||||
(require-typed/untyped "syntax-parse.rkt"
|
||||
"sequence.rkt")
|
||||
|
||||
(require (for-syntax syntax/parse
|
||||
syntax/parse/experimental/template
|
||||
racket/syntax
|
||||
(submod "aliases.rkt" untyped)
|
||||
(submod "syntax-parse.rkt" untyped)
|
||||
(submod "repeat-stx.rkt" untyped))
|
||||
typed/rackunit)
|
||||
|
||||
(: check-equal?-classes (∀ (A ...) (→ (Pairof String (Listof A)) ... Void)))
|
||||
(define (check-equal?-classes . classes)
|
||||
(for* ([(head tail) (in-split* classes)])
|
||||
(let ([this-class (sequence-ref tail 0)]
|
||||
[different-classes (in-sequences head (sequence-tail tail 1))])
|
||||
(for ([val (cdr this-class)])
|
||||
(for ([other-val (cdr this-class)])
|
||||
#;(displayln (format "Test ~a ∈ ~a = ~a ∈ ~a …"
|
||||
val
|
||||
this-class
|
||||
other-val
|
||||
this-class))
|
||||
(check-equal? val other-val
|
||||
(format "Test ~a ∈ ~a = ~a ∈ ~a failed."
|
||||
val
|
||||
this-class
|
||||
other-val
|
||||
this-class)))
|
||||
(for ([different-class different-classes])
|
||||
(for ([different-val (cdr different-class)])
|
||||
#;(displayln (format "Test ~a ∈ ~a != ~a ∈ ~a ∈ ~a …"
|
||||
val
|
||||
this-class
|
||||
different-val
|
||||
different-class
|
||||
(sequence->list different-classes)))
|
||||
(check-not-equal? val different-val
|
||||
(format "Test ~a ∈ ~a != ~a ∈ ~a ∈ ~a failed."
|
||||
val
|
||||
this-class
|
||||
different-val
|
||||
different-class
|
||||
(sequence->list
|
||||
different-classes)))))))))
|
||||
|
||||
(define-syntax/parse (check-equal?-classes:
|
||||
(~seq [(~maybe #:name name:expr)
|
||||
(~maybe (~lit :) c-type)
|
||||
(~seq val (~maybe (~lit :) v-type)) …])
|
||||
…)
|
||||
(define/with-syntax ([a-val …] …)
|
||||
(template ([(?? (ann val v-type) val) …] …)))
|
||||
(define/with-syntax ([aa-val …] …)
|
||||
(let ()
|
||||
;; TODO: this is ugly, repeat-stx should handle missing stuff instead.
|
||||
(define/with-syntax (xx-c-type …) (template ((?? (c-type) ()) …)))
|
||||
(syntax-parse (repeat-stx (xx-c-type …) ([val …] …))
|
||||
[([((~optional c-type-rep)) …] …)
|
||||
(template ([(?? name "") (?? (ann a-val c-type-rep) a-val) …] …))])))
|
||||
(template
|
||||
(check-equal?-classes (list aa-val …) …))))
|
||||
|
|
@ -1,116 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules #:no-test
|
||||
;; TODO: these won't expand types in the ann.
|
||||
(provide check-equal?:
|
||||
check-true:
|
||||
check-not-equal?:
|
||||
check-ann)
|
||||
|
||||
(require "typed-untyped.rkt")
|
||||
|
||||
(require/typed rackunit
|
||||
[(check-true untyped:check-true)
|
||||
(->* (Any) (String) Any)]
|
||||
[#:struct check-info ([name : Symbol] [value : Any])]
|
||||
[make-check-info (→ Symbol Any check-info)]
|
||||
[make-check-location (→ (List Any
|
||||
(U Number False)
|
||||
(U Number False)
|
||||
(U Number False)
|
||||
(U Number False))
|
||||
check-info)]
|
||||
[make-check-name (→ Any check-info)]
|
||||
[make-check-params (→ Any check-info)]
|
||||
[make-check-actual (→ Any check-info)]
|
||||
[make-check-expected (→ Any check-info)]
|
||||
[make-check-expression (→ Any check-info)]
|
||||
[make-check-message (→ Any check-info)]
|
||||
[with-check-info* (→ (Listof check-info) (→ Any) Any)])
|
||||
|
||||
(require (for-syntax syntax/parse
|
||||
syntax/parse/experimental/template))
|
||||
(require-typed/untyped "syntax-parse.rkt")
|
||||
|
||||
(define-syntax/parse
|
||||
(check-equal?: actual
|
||||
(~optional (~seq (~datum :) type))
|
||||
expected
|
||||
(~optional message:expr))
|
||||
(quasitemplate
|
||||
(with-check-info* (list (make-check-actual (format "~s" actual))
|
||||
(make-check-expected (format "~s" expected))
|
||||
(make-check-name 'check-equal?:)
|
||||
(make-check-params
|
||||
(format "~s" `(,actual (?? 'type) ,expected)))
|
||||
(make-check-location '(#,(syntax-source stx)
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,(syntax-position stx)
|
||||
#,(syntax-span stx)))
|
||||
(make-check-expression '#,(syntax->datum stx)))
|
||||
(λ ()
|
||||
(untyped:check-true
|
||||
(equal? (?? (ann actual type) actual)
|
||||
expected))))))
|
||||
|
||||
(define-syntax/parse
|
||||
(check-true: actual
|
||||
(~optional message:expr))
|
||||
(quasitemplate
|
||||
(with-check-info* (list (make-check-actual (format "~s" actual))
|
||||
(make-check-expected (format "~s" #t))
|
||||
(make-check-name 'check-equal?:)
|
||||
(make-check-params
|
||||
(format "~s" `(,actual)))
|
||||
(make-check-location '(#,(syntax-source stx)
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,(syntax-position stx)
|
||||
#,(syntax-span stx)))
|
||||
(make-check-expression '#,(syntax->datum stx)))
|
||||
(λ ()
|
||||
(untyped:check-true
|
||||
;; TODO: do we really need the (not (not …)) here?
|
||||
(not (not actual)))))))
|
||||
|
||||
(define-syntax/parse
|
||||
(check-not-equal?: actual
|
||||
(~optional (~seq (~datum :) type))
|
||||
expected
|
||||
(~optional message))
|
||||
(quasitemplate
|
||||
(with-check-info* (list (make-check-actual (format "~s" actual))
|
||||
(make-check-expected (format "~s" expected))
|
||||
(make-check-name 'check-not-equal?:)
|
||||
(make-check-params
|
||||
(format "~s" `(,actual (?? 'type) ,expected)))
|
||||
(make-check-location '(#,(syntax-source stx)
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,(syntax-position stx)
|
||||
#,(syntax-span stx)))
|
||||
(make-check-expression '#,(syntax->datum stx)))
|
||||
(λ ()
|
||||
(untyped:check-true
|
||||
(not (equal? (?? (ann actual type) actual)
|
||||
expected)))))))
|
||||
|
||||
(define-syntax/parse (check-ann value type (~optional message))
|
||||
(quasitemplate
|
||||
((λ _ (void)) (ann value type))
|
||||
#;(let ([value-cache value])
|
||||
(with-check-info* (list (make-check-actual (format "~s" value-cache))
|
||||
(make-check-expected (format "~s" value-cache))
|
||||
(make-check-name 'check-ann)
|
||||
(make-check-params (format "~s" `(,value-cache
|
||||
type)))
|
||||
(make-check-location '(#,(syntax-source stx)
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,(syntax-position stx)
|
||||
#,(syntax-span stx)))
|
||||
(make-check-expression '#,(syntax->datum stx)))
|
||||
(λ ()
|
||||
(untyped:check-true
|
||||
(equal? (ann value type) value))))))))
|
||||
|
|
@ -1,185 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(provide ;typed/untyped
|
||||
require-typed/untyped-typed
|
||||
require-typed/untyped
|
||||
require/provide-typed/untyped
|
||||
define-typed/untyped-modules
|
||||
if-typed
|
||||
when-typed
|
||||
when-untyped)
|
||||
|
||||
(require typed/untyped-utils
|
||||
racket/require-syntax
|
||||
(for-syntax syntax/parse
|
||||
racket/syntax
|
||||
syntax/stx
|
||||
syntax/strip-context))
|
||||
|
||||
(module m-typed typed/racket
|
||||
(provide (rename-out [require tr:require]
|
||||
[provide tr:provide])
|
||||
;typed/untyped
|
||||
#;require-typed/untyped)
|
||||
|
||||
#;(require (for-syntax syntax/parse
|
||||
racket/syntax
|
||||
syntax/stx
|
||||
syntax/strip-context)
|
||||
racket/require-syntax)
|
||||
|
||||
|
||||
|
||||
#;(define-syntax (require-typed/untyped stx)
|
||||
(syntax-case stx ()
|
||||
[(_ m)
|
||||
(let ()
|
||||
(define/with-syntax sb (datum->syntax #'m 'submod #'m #'m))
|
||||
(define/with-syntax ty (datum->syntax #'m 'typed #'m #'m))
|
||||
#'(require (sb m ty)))])))
|
||||
|
||||
#;(require 'm-typed)
|
||||
|
||||
;; require
|
||||
(define-syntax (require-typed/untyped-typed stx)
|
||||
(syntax-parse stx
|
||||
[(_ . (~and ms (m ...)))
|
||||
(replace-context #'ms #'(require (submod m typed) ...))]))
|
||||
|
||||
#;(define-require-syntax (typed/untyped-typed stx)
|
||||
(syntax-case stx ()
|
||||
[(_ m) (replace-context stx #'(submod m typed))]))
|
||||
|
||||
#;(define-require-syntax (typed/untyped-untyped stx)
|
||||
(syntax-case stx ()
|
||||
[(_ m) (replace-context stx #'(submod m untyped))]))
|
||||
|
||||
(define-syntax (require-typed/untyped-untyped stx)
|
||||
(syntax-parse stx
|
||||
[(_ . (~and ms (m ...)))
|
||||
(replace-context #'ms #'(require (submod m untyped) ...))]))
|
||||
|
||||
(define-typed/untyped-identifier require-typed/untyped
|
||||
require-typed/untyped-typed
|
||||
require-typed/untyped-untyped)
|
||||
|
||||
#;(define-typed/untyped-identifier typed/untyped
|
||||
typed/untyped-typed
|
||||
typed/untyped-untyped)
|
||||
|
||||
;; require/provide
|
||||
;; TODO: make a require expander instead.
|
||||
(define-syntax (require/provide-typed/untyped-typed stx)
|
||||
(syntax-parse stx
|
||||
[(_ . (~and ms (m ...)))
|
||||
(replace-context #'ms
|
||||
#'(begin
|
||||
(require (submod m typed) ...)
|
||||
(provide (all-from-out (submod m typed) ...))))]))
|
||||
|
||||
(define-syntax (require/provide-typed/untyped-untyped stx)
|
||||
(syntax-parse stx
|
||||
[(_ . (~and ms (m ...)))
|
||||
(replace-context #'ms
|
||||
#'(begin
|
||||
(require (submod m untyped) ...)
|
||||
(provide (all-from-out (submod m untyped) ...))))]))
|
||||
|
||||
(define-typed/untyped-identifier require/provide-typed/untyped
|
||||
require/provide-typed/untyped-typed
|
||||
require/provide-typed/untyped-untyped)
|
||||
|
||||
#|
|
||||
(module mt typed/racket
|
||||
(define-syntax-rule (require/provide-typed/untyped m)
|
||||
(require m))
|
||||
(provide require/provide-typed/untyped))
|
||||
(require 'mt)
|
||||
|#
|
||||
|
||||
;; define-typed/untyped-modules
|
||||
(begin
|
||||
(define-syntax (define-typed/untyped-modules stx)
|
||||
(syntax-parse stx
|
||||
[(def-t/u-mod (~optional (~and no-test #:no-test))
|
||||
(~optional (~and untyped-first #:untyped-first)) . body)
|
||||
(define (ds sym) (datum->syntax #'def-t/u-mod sym #'def-t/u-mod))
|
||||
(define/with-syntax module-typed
|
||||
#`(module #,(ds 'typed) #,(ds 'typed/racket)
|
||||
. body))
|
||||
(define/with-syntax module-untyped
|
||||
#`(module #,(ds 'untyped) #,(ds 'typed/racket/no-check)
|
||||
(#,(ds 'require) (#,(ds 'for-syntax) #,(ds 'racket/base)))
|
||||
. body))
|
||||
#`(begin
|
||||
#,(if (attribute untyped-first) #'module-untyped #'module-typed)
|
||||
#,(if (attribute untyped-first) #'module-typed #'module-untyped)
|
||||
#,@(if (attribute no-test)
|
||||
#'()
|
||||
#`((module #,(ds 'test) #,(ds 'typed/racket)
|
||||
(#,(ds 'require) (#,(ds 'submod) #,(ds "..")
|
||||
#,(ds 'typed)
|
||||
#,(ds 'test)))
|
||||
(#,(ds 'require) (#,(ds 'submod) #,(ds "..")
|
||||
#,(ds 'untyped)
|
||||
#,(ds 'test))))))
|
||||
(#,(ds 'require) '#,(ds 'typed))
|
||||
(#,(ds 'provide) (#,(ds 'all-from-out) '#,(ds 'typed))))]))
|
||||
|
||||
#| ;; test: should work in no-check but not in typed:
|
||||
(define-typed/untyped-modules moo
|
||||
(: foo One)
|
||||
(define foo 2))
|
||||
|#)
|
||||
|
||||
;; if-typed
|
||||
(define-syntax-rule (if-typed-typed t u) t)
|
||||
(define-syntax-rule (if-typed-untyped t u) u)
|
||||
(define-typed/untyped-identifier if-typed
|
||||
if-typed-typed
|
||||
if-typed-untyped)
|
||||
|
||||
;; when-typed and when-untyped
|
||||
(define-syntax-rule (when-typed . t) (if-typed (begin . t) (begin)))
|
||||
(define-syntax-rule (when-untyped . t) (if-typed (begin) (begin . t)))
|
||||
|
||||
;; typed/untyped-prefix
|
||||
(begin
|
||||
(define-syntax-rule (typed/untyped-prefix [typed-prefix ...]
|
||||
[untyped-prefix ...]
|
||||
. rest)
|
||||
(if-typed (typed-prefix ... . rest)
|
||||
(untyped-prefix ... . rest)))
|
||||
#|
|
||||
;; test: should work in no-check but not in typed:
|
||||
(typed/untyped-prefix
|
||||
[module moo2 typed/racket]
|
||||
[module moo2 typed/racket/no-check]
|
||||
(: foo One)
|
||||
(define foo 2))
|
||||
|#)
|
||||
|
||||
;; define-modules
|
||||
(begin
|
||||
;; define-modules
|
||||
(define-syntax define-modules
|
||||
(syntax-rules (no-submodule)
|
||||
[(_ ([no-submodule] [name lang] ...) . body)
|
||||
(begin (begin . body)
|
||||
(module name lang . body) ...)]
|
||||
[(_ ([name lang] ...) . body)
|
||||
(begin (module name lang . body) ...)]))
|
||||
|
||||
#|
|
||||
;; TODO: tests: test with a macro and check that we can use it in untyped.
|
||||
;; TODO: tests: test with two mini-languages with different semantics for some
|
||||
;; function.
|
||||
(define-modules ([foo typed/racket] [foo-untyped typed/racket/no-check])
|
||||
(provide x)
|
||||
(: x (→ Syntax Syntax))
|
||||
(define (x s) s))
|
||||
|
||||
(module test racket
|
||||
(require (submod ".." foo-untyped))
|
||||
(x #'a))
|
||||
|#)
|
||||
|
|
@ -1,37 +0,0 @@
|
|||
#lang typed/racket
|
||||
(require "typed-untyped.rkt")
|
||||
(define-typed/untyped-modules
|
||||
(provide first-value second-value third-value fourth-value fifth-value
|
||||
sixth-value seventh-value eighth-value ninth-value tenth-value
|
||||
cons→values
|
||||
(rename-out [cons→values cons->values]))
|
||||
|
||||
(define-syntax-rule (define-value-getter name v ... last-v)
|
||||
(define-syntax-rule (name expr)
|
||||
(call-with-values (λ () expr) (λ (v ... last-v . rest) last-v))))
|
||||
|
||||
(define-value-getter first-value v1)
|
||||
(define-value-getter second-value v1 v2)
|
||||
(define-value-getter third-value v1 v2 v3)
|
||||
(define-value-getter fourth-value v1 v2 v3 v4)
|
||||
(define-value-getter fifth-value v1 v2 v3 v4 v5)
|
||||
(define-value-getter sixth-value v1 v2 v3 v4 v5 v6)
|
||||
(define-value-getter seventh-value v1 v2 v3 v4 v5 v6 v7)
|
||||
(define-value-getter eighth-value v1 v2 v3 v4 v5 v6 v7 v8)
|
||||
(define-value-getter ninth-value v1 v2 v3 v4 v5 v6 v7 v8 v9)
|
||||
(define-value-getter tenth-value v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)
|
||||
|
||||
(module+ test
|
||||
(require typed/rackunit)
|
||||
(check-equal? (first-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 1)
|
||||
(check-equal? (second-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 2)
|
||||
(check-equal? (third-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 3)
|
||||
(check-equal? (fourth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 4)
|
||||
(check-equal? (fifth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 5)
|
||||
(check-equal? (sixth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 6)
|
||||
(check-equal? (seventh-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 7)
|
||||
(check-equal? (eighth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 8)
|
||||
(check-equal? (ninth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 9)
|
||||
(check-equal? (tenth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 10))
|
||||
|
||||
(define #:∀ (A B) (cons→values [x : (Pairof A B)]) (values (car x) (cdr x))))
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
#lang typed/racket/no-check
|
||||
|
||||
;; When creating the html document with scribble/lp2, it does not see the macros
|
||||
;; defined in low.rkt when including it with sugar/include.
|
||||
;; But using a raw include/reader works.
|
||||
|
||||
;(require sugar/include)
|
||||
;(include-without-lang-line "low.rkt")
|
||||
|
||||
;; TODO: file a bug report?
|
||||
;; typed/racket/no-check does not require (for-syntax racket/base).
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(include/reader "low.rkt" (λ (source-name in)
|
||||
(port-count-lines! in)
|
||||
(do ()
|
||||
[(let-values ([(line column position)
|
||||
(port-next-location in)])
|
||||
(> line 1))]
|
||||
(read-line in))
|
||||
(read-syntax source-name in)))
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
#lang typed/racket
|
||||
;(require mzlib/etc)
|
||||
;(this-expression-file-name)
|
||||
|
||||
(provide define-to-this-file-name)
|
||||
|
||||
(define-syntax (define-to-this-file-name stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name)
|
||||
#`(begin (define name #,(syntax-source #'dummy))
|
||||
(define-for-syntax name #,(syntax-source #'dummy)))]))
|
||||
|
||||
;(define-syntax (get-current-file stx)
|
||||
; #`(format "Macro in ~a, Use in ~a" structure.rkt-path #,(syntax-source stx)))
|
||||
|
||||
|
|
@ -1,85 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(require syntax/parse/experimental/template
|
||||
(for-syntax syntax/parse
|
||||
racket/syntax))
|
||||
|
||||
(provide quasitemplate
|
||||
(all-from-out syntax/parse/experimental/template))
|
||||
|
||||
;; subst-quasitemplate returns a stx-pair, with definitions for
|
||||
;; with-syntax in the stx-car, and a template in the stx-cdr.
|
||||
;; The template is either of the form ('eh-tmpl . tmpl), in which case it is an
|
||||
;; ellipsis-head template, or of the form ('tmpl . tmpl), in which case it is
|
||||
;; a regular template.
|
||||
|
||||
;; Appending the stx-car from the two branches at each recursion step is
|
||||
;; extremely inefficient (in the worst case O(n²)), so while gathering them, we
|
||||
;; store them as a binary tree, and then we flatten it with flatten-defs.
|
||||
|
||||
;; Note that quasitemplate can still take O(n²) time, because of ellipsis-head
|
||||
;; templates which are not handled very efficiently.
|
||||
|
||||
(define-for-syntax (flatten-defs stx acc)
|
||||
(syntax-parse stx
|
||||
[(l r) (flatten-defs #'r (flatten-defs #'l acc))]
|
||||
[() acc]
|
||||
[(def) #`(def . #,acc)]))
|
||||
|
||||
;; There are two cases for the transformation of #,@(expr):
|
||||
;; If it is in a car position, we write:
|
||||
;; (with-syntax ([(tmp ...) expr]) (tmp ... . the-cdr))
|
||||
;; If it is in a cdr position, we write:
|
||||
;; (with-syntax ([tmp expr]) (the-car . tmp))
|
||||
(define-for-syntax (subst-quasitemplate car? stx)
|
||||
(syntax-parse stx #:literals (unsyntax unsyntax-splicing)
|
||||
[(unsyntax expr)
|
||||
(with-syntax ([tmp (gensym)])
|
||||
#`(([tmp expr]) . #,(if car? #'{tmp} #'tmp)))]
|
||||
[(unsyntax-splicing expr)
|
||||
(with-syntax ([tmp (gensym)])
|
||||
(if car?
|
||||
#'(... (([(tmp ...) expr]) . {tmp ...}))
|
||||
#'(([tmp expr]) . tmp)))]
|
||||
[((unsyntax-splicing expr)) ;; In last position in a list
|
||||
(if car?
|
||||
#'(([tmp expr]) . {tmp})
|
||||
#'(([tmp expr]) . tmp))]
|
||||
[(a . b)
|
||||
(with-syntax ([(defs-a sa ...) (subst-quasitemplate #t #'a)]
|
||||
[(defs-b . sb) (subst-quasitemplate #f #'b)])
|
||||
#`((defs-a defs-b) . #,(if car? #'{(sa ... . sb)} #'(sa ... . sb))))]
|
||||
[x
|
||||
#`(() . #,(if car? #'{x} #'x))]))
|
||||
|
||||
(define-syntax (quasitemplate stx)
|
||||
(syntax-parse stx
|
||||
[(_ tmpl)
|
||||
(with-syntax* ([(defs . new-tmpl) (subst-quasitemplate #f #'tmpl)]
|
||||
[(flattened-defs ...) (flatten-defs #'defs #'())])
|
||||
#'(with-syntax (flattened-defs ...)
|
||||
(template new-tmpl)))]))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define-syntax-rule (check . tmpl)
|
||||
(check-equal? (syntax->datum (quasitemplate . tmpl))
|
||||
(syntax->datum (quasisyntax . tmpl))))
|
||||
|
||||
(check (a #,(+ 1 2)))
|
||||
(check (a #,(+ 1 2) #,(+ 3 4)))
|
||||
(check (a #,@(list 1 2) #,@(list 3 4)))
|
||||
(check (#,@(list 1 2) #,@(list 3 4) . #,(list* 5 6)))
|
||||
(check (a (#,@(list 1 2) #,@(list 3 4) . #,(list* 5 6)) c))
|
||||
(check (a . (#,@(list 1 2) #,@(list 3 4) . #,(list* 5 6))))
|
||||
(check (a (#,@(list 1 2) #,@(list 3 4) . #,(list* 5 6))))
|
||||
|
||||
(check (#,@(list 1 2) #,@(list 3 4) #,@(list* 5 6)))
|
||||
(check (a (#,@(list 1 2) #,@(list 3 4) #,@(list* 5 6)) c))
|
||||
(check (a . (#,@(list 1 2) #,@(list 3 4) #,@(list* 5 6))))
|
||||
(check (a (#,@(list 1 2) #,@(list 3 4) #,@(list* 5 6))))
|
||||
(check (a #,@1))
|
||||
(check (a (#,@1)))
|
||||
(check (a (#,@1) c))
|
||||
(check ((#,@1) b))
|
||||
(check ((#,@1) b)))
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
#lang racket
|
||||
(require (submod "low.rkt" untyped))
|
||||
|
||||
(with-syntax ([((foo ...) ...) #'((aa bb cc) (x1 x2))])
|
||||
(define-temp-ids "___~a.truc" ((foo ...) ...) #:first-base fst)
|
||||
(syntax->datum #'((___foo.truc ...) ...))
|
||||
(syntax->datum #'(fst ___fst.truc))
|
||||
(void))
|
||||
|
||||
(with-syntax ([(foo ...) #'(aa bb cc)])
|
||||
(define-temp-ids "___~a.truc" (foo ...) #:first-base fst)
|
||||
(syntax->datum #'(___foo.truc ...))
|
||||
(syntax->datum #'(fst ___fst.truc))
|
||||
(void))
|
||||
|
||||
(with-syntax ([foo #'aa])
|
||||
(define-temp-ids "___~a.truc" foo)
|
||||
(syntax->datum #'___foo.truc)
|
||||
(syntax->datum #'(fst ___fst.truc))
|
||||
(void))
|
||||
|
||||
(with-syntax ([((foo ...) ...) #'((aa bb cc) (x1 x2))])
|
||||
(define-temp-ids "___~a.truc" ((foo ...) ...) #:first-base fst)
|
||||
(syntax->datum #'(___foo.truc ... ...))
|
||||
(syntax->datum #'(fst ___fst.truc))
|
||||
(void))
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
#lang typed/racket
|
||||
|
||||
;; Using check-equal? on our variants result in the following error message:
|
||||
;; Attempted to use a higher-order value passed as `Any` in untyped code
|
||||
;; check-equal? and check-not-equal? are replaced by versions that work with
|
||||
;; “higher-order values” below.
|
||||
|
||||
(require (except-in (only-meta-in 0 typed/rackunit)
|
||||
;; Above: typed/racket risks complaining that it can't do
|
||||
;; for-meta in all-from-out if we don't use `only-meta-in`.
|
||||
check-equal?
|
||||
check-not-equal?))
|
||||
|
||||
(provide (all-from-out typed/rackunit)
|
||||
check-equal?
|
||||
check-not-equal?
|
||||
check-eval-equal?
|
||||
check-eval-string-equal?
|
||||
check-eval-string-equal?/ns)
|
||||
|
||||
(require "eval-get-values.rkt")
|
||||
|
||||
(require syntax/parse/define)
|
||||
|
||||
(define-simple-macro (check-equal? x y . message)
|
||||
(check-true (equal? x y) . message))
|
||||
|
||||
(define-simple-macro (check-not-equal? x y . message)
|
||||
(check-true (not (equal? x y)) . message))
|
||||
|
||||
(define-simple-macro (check-eval-equal? to-eval y . message)
|
||||
(check-true (equal? (eval-get-values to-eval
|
||||
(variable-reference->namespace
|
||||
(#%variable-reference)))
|
||||
y)
|
||||
. message))
|
||||
|
||||
(define-simple-macro (check-eval-string-equal? to-eval y . message)
|
||||
(check-true (equal? (eval-get-values (read (open-input-string to-eval))
|
||||
(variable-reference->namespace
|
||||
(#%variable-reference)))
|
||||
y)
|
||||
. message))
|
||||
|
||||
(define-simple-macro (check-eval-string-equal?/ns ns-anchor to-eval y . message)
|
||||
(check-true (equal? (eval-get-values (read (open-input-string to-eval))
|
||||
(namespace-anchor->namespace
|
||||
ns-anchor))
|
||||
y)
|
||||
. message))
|
||||
|
||||
(define-syntax-rule (test-module body ...)
|
||||
(module* test typed/racket
|
||||
(require (submod ".."))
|
||||
body ...))
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang typed/racket
|
||||
|
||||
(require "low.rkt")
|
||||
(require/provide "untyped/for-star-list-star.rkt")
|
||||
|
|
@ -1,71 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(provide for*/list*)
|
||||
|
||||
(require (for-syntax syntax/parse))
|
||||
|
||||
(define-syntax (for*/list* stx)
|
||||
(define-syntax-class sequences
|
||||
#:description "([id seq-expr] ...) or (* [id seq-expr] ...)"
|
||||
(pattern ((~optional (~and star (~datum *))) (id:id seq-expr:expr) ...)
|
||||
#:with for-kind (if (attribute star) #'for*/list #'for/list)))
|
||||
|
||||
(syntax-parse stx
|
||||
[(_ [sequences:sequences ...] . body)
|
||||
(foldl (λ (for-kind clauses acc)
|
||||
#`(#,for-kind #,clauses #,acc))
|
||||
#'(let () . body)
|
||||
(reverse (syntax-e #'(sequences.for-kind ...)))
|
||||
(reverse (syntax-e #'(([sequences.id sequences.seq-expr] ...)
|
||||
...))))]))
|
||||
|
||||
;; Test for*/list*
|
||||
(module* test racket
|
||||
(require rackunit)
|
||||
(require (submod ".."))
|
||||
(check-equal? (for*/list* [([x '(a b c)]
|
||||
[y '(1 2 3)])
|
||||
(* [z '(d e f)]
|
||||
[t '(4 5 6)])]
|
||||
(list x y z t))
|
||||
'(((a 1 d 4) (a 1 d 5) (a 1 d 6)
|
||||
(a 1 e 4) (a 1 e 5) (a 1 e 6)
|
||||
(a 1 f 4) (a 1 f 5) (a 1 f 6))
|
||||
((b 2 d 4) (b 2 d 5) (b 2 d 6)
|
||||
(b 2 e 4) (b 2 e 5) (b 2 e 6)
|
||||
(b 2 f 4) (b 2 f 5) (b 2 f 6))
|
||||
((c 3 d 4) (c 3 d 5) (c 3 d 6)
|
||||
(c 3 e 4) (c 3 e 5) (c 3 e 6)
|
||||
(c 3 f 4) (c 3 f 5) (c 3 f 6))))
|
||||
(check-equal? (for*/list* [([x '(a b c)])
|
||||
([y '(1 2 3)])
|
||||
(* [z '(d e f)]
|
||||
[t '(4 5 6)])]
|
||||
(list x y z t))
|
||||
'((((a 1 d 4) (a 1 d 5) (a 1 d 6)
|
||||
(a 1 e 4) (a 1 e 5) (a 1 e 6)
|
||||
(a 1 f 4) (a 1 f 5) (a 1 f 6))
|
||||
((a 2 d 4) (a 2 d 5) (a 2 d 6)
|
||||
(a 2 e 4) (a 2 e 5) (a 2 e 6)
|
||||
(a 2 f 4) (a 2 f 5) (a 2 f 6))
|
||||
((a 3 d 4) (a 3 d 5) (a 3 d 6)
|
||||
(a 3 e 4) (a 3 e 5) (a 3 e 6)
|
||||
(a 3 f 4) (a 3 f 5) (a 3 f 6)))
|
||||
(((b 1 d 4) (b 1 d 5) (b 1 d 6)
|
||||
(b 1 e 4) (b 1 e 5) (b 1 e 6)
|
||||
(b 1 f 4) (b 1 f 5) (b 1 f 6))
|
||||
((b 2 d 4) (b 2 d 5) (b 2 d 6)
|
||||
(b 2 e 4) (b 2 e 5) (b 2 e 6)
|
||||
(b 2 f 4) (b 2 f 5) (b 2 f 6))
|
||||
((b 3 d 4) (b 3 d 5) (b 3 d 6) (b 3 e 4)
|
||||
(b 3 e 5) (b 3 e 6) (b 3 f 4)
|
||||
(b 3 f 5) (b 3 f 6)))
|
||||
(((c 1 d 4) (c 1 d 5) (c 1 d 6) (c 1 e 4)
|
||||
(c 1 e 5) (c 1 e 6) (c 1 f 4)
|
||||
(c 1 f 5) (c 1 f 6))
|
||||
((c 2 d 4) (c 2 d 5) (c 2 d 6) (c 2 e 4)
|
||||
(c 2 e 5) (c 2 e 6) (c 2 f 4)
|
||||
(c 2 f 5) (c 2 f 6))
|
||||
((c 3 d 4) (c 3 d 5) (c 3 d 6) (c 3 e 4)
|
||||
(c 3 e 5) (c 3 e 6) (c 3 f 4)
|
||||
(c 3 f 5) (c 3 f 6))))))
|
||||
Loading…
Reference in New Issue
Block a user