diff --git a/graph-lib/lib/eval-get-values.rkt b/graph-lib/lib/eval-get-values.rkt deleted file mode 100644 index 2069fe6..0000000 --- a/graph-lib/lib/eval-get-values.rkt +++ /dev/null @@ -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) diff --git a/graph-lib/lib/lib.rkt b/graph-lib/lib/lib.rkt deleted file mode 100644 index c772202..0000000 --- a/graph-lib/lib/lib.rkt +++ /dev/null @@ -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))))))))])) - diff --git a/graph-lib/lib/low.rkt b/graph-lib/lib/low.rkt deleted file mode 100644 index 5996b48..0000000 --- a/graph-lib/lib/low.rkt +++ /dev/null @@ -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")) diff --git a/graph-lib/lib/low/aliases.rkt b/graph-lib/lib/low/aliases.rkt deleted file mode 100644 index 1563784..0000000 --- a/graph-lib/lib/low/aliases.rkt +++ /dev/null @@ -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)])) diff --git a/graph-lib/lib/low/backtrace.rkt b/graph-lib/lib/low/backtrace.rkt deleted file mode 100644 index 36e66e7..0000000 --- a/graph-lib/lib/low/backtrace.rkt +++ /dev/null @@ -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)));) \ No newline at end of file diff --git a/graph-lib/lib/low/cond-let.rkt b/graph-lib/lib/low/cond-let.rkt deleted file mode 100644 index e92ffb3..0000000 --- a/graph-lib/lib/low/cond-let.rkt +++ /dev/null @@ -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 …)))]))) \ No newline at end of file diff --git a/graph-lib/lib/low/fixnum.rkt b/graph-lib/lib/low/fixnum.rkt deleted file mode 100644 index 8b707b2..0000000 --- a/graph-lib/lib/low/fixnum.rkt +++ /dev/null @@ -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))) \ No newline at end of file diff --git a/graph-lib/lib/low/generate-indices.rkt b/graph-lib/lib/low/generate-indices.rkt deleted file mode 100644 index 9cce1fc..0000000 --- a/graph-lib/lib/low/generate-indices.rkt +++ /dev/null @@ -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)]))) \ No newline at end of file diff --git a/graph-lib/lib/low/ids.rkt b/graph-lib/lib/low/ids.rkt deleted file mode 100644 index 6f1570a..0000000 --- a/graph-lib/lib/low/ids.rkt +++ /dev/null @@ -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))))) \ No newline at end of file diff --git a/graph-lib/lib/low/in.rkt b/graph-lib/lib/low/in.rkt deleted file mode 100644 index 45b8124..0000000 --- a/graph-lib/lib/low/in.rkt +++ /dev/null @@ -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))) \ No newline at end of file diff --git a/graph-lib/lib/low/list.rkt b/graph-lib/lib/low/list.rkt deleted file mode 100644 index 1b74312..0000000 --- a/graph-lib/lib/low/list.rkt +++ /dev/null @@ -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))))) \ No newline at end of file diff --git a/graph-lib/lib/low/logn-id.rkt b/graph-lib/lib/low/logn-id.rkt deleted file mode 100644 index 24b36cf..0000000 --- a/graph-lib/lib/low/logn-id.rkt +++ /dev/null @@ -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))) \ No newline at end of file diff --git a/graph-lib/lib/low/misc.rkt b/graph-lib/lib/low/misc.rkt deleted file mode 100644 index 8760ceb..0000000 --- a/graph-lib/lib/low/misc.rkt +++ /dev/null @@ -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))))])))) \ No newline at end of file diff --git a/graph-lib/lib/low/multiassoc-syntax.rkt b/graph-lib/lib/low/multiassoc-syntax.rkt deleted file mode 100644 index e27a526..0000000 --- a/graph-lib/lib/low/multiassoc-syntax.rkt +++ /dev/null @@ -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)))) diff --git a/graph-lib/lib/low/not-implemented-yet.rkt b/graph-lib/lib/low/not-implemented-yet.rkt deleted file mode 100644 index 9196a9d..0000000 --- a/graph-lib/lib/low/not-implemented-yet.rkt +++ /dev/null @@ -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))))]))) \ No newline at end of file diff --git a/graph-lib/lib/low/percent.rkt b/graph-lib/lib/low/percent.rkt deleted file mode 100644 index 6081b83..0000000 --- a/graph-lib/lib/low/percent.rkt +++ /dev/null @@ -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 )])) - |#) \ No newline at end of file diff --git a/graph-lib/lib/low/percent.scrbl b/graph-lib/lib/low/percent.scrbl deleted file mode 100644 index 46a0439..0000000 --- a/graph-lib/lib/low/percent.scrbl +++ /dev/null @@ -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].} - diff --git a/graph-lib/lib/low/repeat-stx.rkt b/graph-lib/lib/low/repeat-stx.rkt deleted file mode 100644 index a49364b..0000000 --- a/graph-lib/lib/low/repeat-stx.rkt +++ /dev/null @@ -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) ())))) \ No newline at end of file diff --git a/graph-lib/lib/low/require-provide.rkt b/graph-lib/lib/low/require-provide.rkt deleted file mode 100644 index f424047..0000000 --- a/graph-lib/lib/low/require-provide.rkt +++ /dev/null @@ -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))) \ No newline at end of file diff --git a/graph-lib/lib/low/sequence.rkt b/graph-lib/lib/low/sequence.rkt deleted file mode 100644 index db16cff..0000000 --- a/graph-lib/lib/low/sequence.rkt +++ /dev/null @@ -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))])) - |#)) \ No newline at end of file diff --git a/graph-lib/lib/low/set.rkt b/graph-lib/lib/low/set.rkt deleted file mode 100644 index 7684249..0000000 --- a/graph-lib/lib/low/set.rkt +++ /dev/null @@ -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)))) \ No newline at end of file diff --git a/graph-lib/lib/low/stx.rkt b/graph-lib/lib/low/stx.rkt deleted file mode 100644 index b74a817..0000000 --- a/graph-lib/lib/low/stx.rkt +++ /dev/null @@ -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))) - |#) \ No newline at end of file diff --git a/graph-lib/lib/low/syntax-parse.rkt b/graph-lib/lib/low/syntax-parse.rkt deleted file mode 100644 index 1344e72..0000000 --- a/graph-lib/lib/low/syntax-parse.rkt +++ /dev/null @@ -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))) \ No newline at end of file diff --git a/graph-lib/lib/low/template.scrbl b/graph-lib/lib/low/template.scrbl deleted file mode 100644 index e8f0f55..0000000 --- a/graph-lib/lib/low/template.scrbl +++ /dev/null @@ -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}] - diff --git a/graph-lib/lib/low/threading.rkt b/graph-lib/lib/low/threading.rkt deleted file mode 100644 index 7b68226..0000000 --- a/graph-lib/lib/low/threading.rkt +++ /dev/null @@ -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 [_ ♦] [<~_ <~♦] [~>_ ~>♦]))) \ No newline at end of file diff --git a/graph-lib/lib/low/tmpl-multiassoc-syntax.rkt b/graph-lib/lib/low/tmpl-multiassoc-syntax.rkt deleted file mode 100644 index 1f02e39..0000000 --- a/graph-lib/lib/low/tmpl-multiassoc-syntax.rkt +++ /dev/null @@ -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)) \ No newline at end of file diff --git a/graph-lib/lib/low/tmpl.rkt b/graph-lib/lib/low/tmpl.rkt deleted file mode 100644 index ade54aa..0000000 --- a/graph-lib/lib/low/tmpl.rkt +++ /dev/null @@ -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)) \ No newline at end of file diff --git a/graph-lib/lib/low/todo.rkt b/graph-lib/lib/low/todo.rkt deleted file mode 100644 index 080967b..0000000 --- a/graph-lib/lib/low/todo.rkt +++ /dev/null @@ -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)]) \ No newline at end of file diff --git a/graph-lib/lib/low/type-inference-helpers.rkt b/graph-lib/lib/low/type-inference-helpers.rkt deleted file mode 100644 index afe221c..0000000 --- a/graph-lib/lib/low/type-inference-helpers.rkt +++ /dev/null @@ -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))) \ No newline at end of file diff --git a/graph-lib/lib/low/typed-rackunit-extensions.rkt b/graph-lib/lib/low/typed-rackunit-extensions.rkt deleted file mode 100644 index 6b6094c..0000000 --- a/graph-lib/lib/low/typed-rackunit-extensions.rkt +++ /dev/null @@ -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 …) …)))) \ No newline at end of file diff --git a/graph-lib/lib/low/typed-rackunit.rkt b/graph-lib/lib/low/typed-rackunit.rkt deleted file mode 100644 index 93516bb..0000000 --- a/graph-lib/lib/low/typed-rackunit.rkt +++ /dev/null @@ -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)))))))) \ No newline at end of file diff --git a/graph-lib/lib/low/typed-untyped.rkt b/graph-lib/lib/low/typed-untyped.rkt deleted file mode 100644 index e7af8e2..0000000 --- a/graph-lib/lib/low/typed-untyped.rkt +++ /dev/null @@ -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)) - |#) \ No newline at end of file diff --git a/graph-lib/lib/low/values.rkt b/graph-lib/lib/low/values.rkt deleted file mode 100644 index ddf8492..0000000 --- a/graph-lib/lib/low/values.rkt +++ /dev/null @@ -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)))) \ No newline at end of file diff --git a/graph-lib/lib/old_low-untyped.rkt b/graph-lib/lib/old_low-untyped.rkt deleted file mode 100644 index 24dbd9c..0000000 --- a/graph-lib/lib/old_low-untyped.rkt +++ /dev/null @@ -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))) \ No newline at end of file diff --git a/graph-lib/lib/path.rkt b/graph-lib/lib/path.rkt deleted file mode 100644 index a5726e4..0000000 --- a/graph-lib/lib/path.rkt +++ /dev/null @@ -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))) - diff --git a/graph-lib/lib/syntax/quasitemplate.rkt b/graph-lib/lib/syntax/quasitemplate.rkt deleted file mode 100644 index 753dbdc..0000000 --- a/graph-lib/lib/syntax/quasitemplate.rkt +++ /dev/null @@ -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))) \ No newline at end of file diff --git a/graph-lib/lib/test-define-temp-ids.rkt b/graph-lib/lib/test-define-temp-ids.rkt deleted file mode 100644 index b12ee56..0000000 --- a/graph-lib/lib/test-define-temp-ids.rkt +++ /dev/null @@ -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)) diff --git a/graph-lib/lib/test-framework.rkt b/graph-lib/lib/test-framework.rkt deleted file mode 100644 index 9c3e360..0000000 --- a/graph-lib/lib/test-framework.rkt +++ /dev/null @@ -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 ...)) \ No newline at end of file diff --git a/graph-lib/lib/untyped.rkt b/graph-lib/lib/untyped.rkt deleted file mode 100644 index 0073233..0000000 --- a/graph-lib/lib/untyped.rkt +++ /dev/null @@ -1,4 +0,0 @@ -#lang typed/racket - -(require "low.rkt") -(require/provide "untyped/for-star-list-star.rkt") diff --git a/graph-lib/lib/untyped/for-star-list-star.rkt b/graph-lib/lib/untyped/for-star-list-star.rkt deleted file mode 100644 index 6db7238..0000000 --- a/graph-lib/lib/untyped/for-star-list-star.rkt +++ /dev/null @@ -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)))))) \ No newline at end of file