suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Added lib/sequences.rkt, transformed format-ids into a function, moved format-ids and the rest of lib/untyped/ids.rkt into lib/low.rkt, added define-modules macro. Adjusted README and lib/untyped.rkt accordingly.

Browse Source
This commit is contained in:
Georges Dupéron 2015-10-22 18:17:38 +02:00
parent 494537057f
commit 44c6c951cc
5 changed files with 202 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
graph/README
View File

@ -203,10 +203,6 @@ Library functions and utilities
Wrapper around lib/low.rkt that allows using it from a untyped racket file.
* lib/untyped/ids.rkt
Some untyped racket utilities to manipulate identifiers inside macros.
* lib/untyped/for-star-list-star.rkt
A utility macro similar to for*/list to iterate over collections and return a
@ -214,8 +210,7 @@ Library functions and utilities
* lib/untyped.rkt
Aggregates lib/low-untyped.rkt, lib/untyped/ids.rkt and
lib/untyped/for-star-list-star.rkt.
Aggregates lib/low-untyped.rkt, and lib/untyped/for-star-list-star.rkt.
* lib/test-framework.rkt

155
graph/lib/low.rkt
View File

@ -4,6 +4,30 @@
(: degub (∀ (T) (→ T T)))
(define (degub x) (display "degub:") (displayln x) x)
;; ==== low/typed-untyped-module.rkt ====
(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))
|#
;; ==== low/require-provide.rkt ====
(provide require/provide)
@ -179,6 +203,11 @@
(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))])
@ -342,3 +371,129 @@
(rename-out [match-lambda match-λ]
[match-lambda* match-λ*]
[match-lambda** match-λ**]))
;; ==== ids.rkt ====
(define-modules ([no-submodule] [ids-untyped typed/racket/no-check])
(provide format-ids
hyphen-ids
format-temp-ids
#|t/gen-temp|#)
(require/typed racket/syntax
[format-id (→ Syntax String (U String Identifier) * Identifier)])
;(require racket/sequence) ;; in-syntax
(require "sequences.rkt"
#|"../low.rkt"|#) ;; my-in-syntax
(define-type S-Id-List
(U String
Identifier
(Listof String)
(Listof Identifier)
(Syntaxof (Listof Identifier))))
(: 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) #'())) format vs)))
(module+ test
(require ;(submod "..")
;"test-framework.rkt"
(for-syntax racket/syntax
(submod ".." ids-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))))
#|
(define-template-metafunction (t/gen-temp stx)
(syntax-parse stx
[(_ . id:id)
#:with (temp) (generate-temporaries #'(id))
#'temp]
[(_ id:id ...)
(generate-temporaries #'(id ...))]))
|#
;; ==== end ====

45
graph/lib/sequences.rkt Normal file
View File

@ -0,0 +1,45 @@
#lang typed/racket
(provide sequence-cons sequence-null sequence-list)
(: 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))]))
|#

3
graph/lib/untyped.rkt
View File

@ -1,5 +1,4 @@
#lang typed/racket
(require "low-untyped.rkt")
(require/provide "untyped/for-star-list-star.rkt"
"untyped/ids.rkt")
(require/provide "untyped/for-star-list-star.rkt")

114
graph/lib/untyped/ids.rkt
View File

@ -1,114 +0,0 @@
#lang racket
(provide format-ids
hyphen-ids
format-temp-ids
#|t/gen-temp|#)
(require racket/syntax) ;; Used to bind format-id in macroexpansion below.
(require racket/sequence) ;; Used to bind in-syntax in macroexpansion below.
;; Used to bind in-syntax on older versions in macroexpansion below:
;(require unstable/sequence)
(require (for-syntax racket/syntax
syntax/parse
racket/string
racket/sequence
;unstable/sequence ;; in-syntax on older versions
#|syntax/parse/experimental/template|#)
syntax/strip-context)
;; Actually, this could be just a regular function:
;; test (with list?, syntax? and combinations thereof) if we should iterate or
;; just put the value as-is.
(begin-for-syntax
(define-syntax-class var-expr
#:description
(string-append "#'identifier or #'(identifier ooo), where ooo is a"
" literal “...”, or #'(identifier ...), or an expression")
(pattern (~and whole ((~literal syntax) var:id))
#:with code #'(in-value whole))
(pattern (~and whole ((~literal syntax) (var:id (~literal ...))))
#:with code #'(in-syntax whole))
(pattern (~and whole ((~literal syntax) (vars:id ...)))
#:with (var . _) #`(vars ... #,(gensym 'empty))
#:with code #'(in-syntax whole))
(pattern expr:expr
#:with var (gensym)
#:with code #'(let ((s expr)) (if (string? s) (in-value s) s)))))
;; TODO: infinite loop if we only have constants which ar handled with for-value
(define-syntax (format-ids stx)
(syntax-parse stx
[(_ lexical-context:expr format:expr v:var-expr ...)
(define/with-syntax (tmp ...) (generate-temporaries #'(v.var ...)))
#'(let ([lex-ctx lexical-context])
(for/list ([tmp v.code] ...)
(format-id (if (procedure? lex-ctx) (lex-ctx tmp ...) lex-ctx)
format
tmp ...)))]))
(define-syntax (hyphen-ids stx)
(syntax-parse stx
;; TODO: allow single #'foo instead of (var expr), and use in-value
[(_ lexical-context:expr v:var-expr ...)
#`(format-ids lexical-context
#,(string-join (for/list ([x (in-syntax #'(v ...))]) "~a")
"-")
v ...)]))
(define-syntax (format-temp-ids stx)
(syntax-parse stx
[(_ . rest)
;; Introduce the binding in a fresh scope.
#'(format-ids (λ _ ((make-syntax-introducer) #'())) . rest)]))
#|
(define-template-metafunction (t/gen-temp stx)
(syntax-parse stx
[(_ . id:id)
#:with (temp) (generate-temporaries #'(id))
#'temp]
[(_ id:id ...)
(generate-temporaries #'(id ...))]))
|#
(module* test racket
(require (submod "..")
rackunit
(for-syntax racket/syntax
(submod "..")))
(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))
(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))))