Moved typed-syntax files to tr-immutable.
This commit is contained in:
Georges Dupéron
parent
deca84c956
commit
99c63ecd55
|
|
@ -7,8 +7,7 @@
|
||||||
extract-first-comments
|
extract-first-comments
|
||||||
extract-comments-after)
|
extract-comments-after)
|
||||||
|
|
||||||
(require "typed-syntax.rkt"
|
(require tr-immutable/typed-syntax
|
||||||
"typed-pairof-predicate.rkt"
|
|
||||||
typed-map)
|
typed-map)
|
||||||
|
|
||||||
(define-type First-Comments
|
(define-type First-Comments
|
||||||
|
|
|
||||||
|
|
@ -1,31 +0,0 @@
|
||||||
#lang typed/racket
|
|
||||||
|
|
||||||
(provide pairof?)
|
|
||||||
|
|
||||||
(require typed/racket/unsafe)
|
|
||||||
(unsafe-require/typed racket/function
|
|
||||||
[[identity unsafe-cast-function] (∀ (A) (→ Any A))])
|
|
||||||
(define-syntax-rule (unsafe-cast v t)
|
|
||||||
((inst unsafe-cast-function t) v))
|
|
||||||
|
|
||||||
(: pairof?* (∀ (A D) (→ Any
|
|
||||||
(→ Any Boolean : A)
|
|
||||||
(→ Any Boolean : D)
|
|
||||||
Boolean)))
|
|
||||||
(define (pairof?* v a? d?)
|
|
||||||
(and (pair? v)
|
|
||||||
(a? (car v))
|
|
||||||
(d? (cdr v))))
|
|
||||||
|
|
||||||
(define pairof?
|
|
||||||
;; Circumvent https://github.com/racket/typed-racket/issues/429
|
|
||||||
(unsafe-cast pairof?*
|
|
||||||
(∀ (A D) (→ Any
|
|
||||||
(→ Any Boolean : A)
|
|
||||||
(→ Any Boolean : D)
|
|
||||||
Boolean
|
|
||||||
:
|
|
||||||
;; Circumvent
|
|
||||||
;; https://github.com/racket/typed-racket/issues/488
|
|
||||||
#:+ (Pairof A D)
|
|
||||||
#:- (! (Pairof A D))))))
|
|
||||||
|
|
@ -1,35 +0,0 @@
|
||||||
#lang typed/racket
|
|
||||||
|
|
||||||
(struct (A) NonSexp ([v : A]) #:type-name NonSexpOf)
|
|
||||||
(struct (A) NonSyntax ([v : A]) #:type-name NonSyntaxOf)
|
|
||||||
(struct (A) Some ([v : A]))
|
|
||||||
(define-type (Maybe A)
|
|
||||||
(U (Some A) #f))
|
|
||||||
|
|
||||||
(provide (struct-out NonSexp) NonSexpOf
|
|
||||||
(struct-out NonSyntax) NonSyntaxOf
|
|
||||||
(struct-out Some)
|
|
||||||
Maybe)
|
|
||||||
|
|
||||||
(module* test typed/racket
|
|
||||||
(require (submod ".."))
|
|
||||||
(require typed/rackunit)
|
|
||||||
(check-pred procedure? NonSexp)
|
|
||||||
(check-pred NonSexp? (ann (ann (NonSexp 1) (NonSexpOf Number)) Any))
|
|
||||||
(check-not-exn
|
|
||||||
(λ ()
|
|
||||||
(ann (let ([n : (NonSexpOf Any) (NonSexp 1)])
|
|
||||||
(if (number? (NonSexp-v n))
|
|
||||||
(NonSexp-v n)
|
|
||||||
0))
|
|
||||||
Number)))
|
|
||||||
|
|
||||||
(check-not-exn
|
|
||||||
(λ ()
|
|
||||||
(ann (let ([n : Any (NonSexp 1)])
|
|
||||||
(if (NonSexp? n)
|
|
||||||
(if (number? (NonSexp-v n))
|
|
||||||
(NonSexp-v n)
|
|
||||||
2)
|
|
||||||
0))
|
|
||||||
Number))))
|
|
||||||
|
|
@ -1,130 +0,0 @@
|
||||||
#lang typed/racket
|
|
||||||
|
|
||||||
(require typed-map
|
|
||||||
typed/racket/unsafe
|
|
||||||
"typed-prefab-declarations.rkt")
|
|
||||||
|
|
||||||
(provide try-any->isexp*
|
|
||||||
try-any->isexp
|
|
||||||
any->isexp+non-sexp)
|
|
||||||
|
|
||||||
(unsafe-require/typed racket/function
|
|
||||||
[[identity unsafe-cast-function] (∀ (A) (→ Any A))])
|
|
||||||
(unsafe-require/typed racket/base
|
|
||||||
[[datum->syntax datum->syntax*]
|
|
||||||
(∀ (A) (→ (Syntaxof Any)
|
|
||||||
A
|
|
||||||
(Syntaxof Any)
|
|
||||||
(Syntaxof Any)
|
|
||||||
(Syntaxof A)))])
|
|
||||||
|
|
||||||
(define-syntax-rule (unsafe-cast v t)
|
|
||||||
((inst unsafe-cast-function t) v))
|
|
||||||
|
|
||||||
(define-type (non-sexp-handler A)
|
|
||||||
(→ Any
|
|
||||||
(Values (U (Sexpof A) #f)
|
|
||||||
(U 'unmodified 'modified #f))))
|
|
||||||
|
|
||||||
(: try-listof-any->isexp* (∀ (A) (→ (Listof Any)
|
|
||||||
(non-sexp-handler A)
|
|
||||||
(U (Pairof (Listof (Sexpof A))
|
|
||||||
(U 'unmodified 'modified))
|
|
||||||
(Pairof #f #f)))))
|
|
||||||
|
|
||||||
(define (try-listof-any->isexp* e non-sexp)
|
|
||||||
(define e+status*
|
|
||||||
(map (λ ([eᵢ : Any])
|
|
||||||
(let-values ([(eᵢ* status) (try-any->isexp* eᵢ non-sexp)])
|
|
||||||
(cons eᵢ* status)))
|
|
||||||
e))
|
|
||||||
(define e* (map car e+status*))
|
|
||||||
(define status* (map cdr e+status*))
|
|
||||||
(cond
|
|
||||||
[(andmap (curry eq? 'unmodified) status*)
|
|
||||||
(cons (unsafe-cast e (Listof (Sexpof A))) 'unmodified)]
|
|
||||||
[(ormap (curry eq? #f) status*)
|
|
||||||
(cons #f #f)]
|
|
||||||
[else
|
|
||||||
(cons e* 'modified)]))
|
|
||||||
|
|
||||||
(: try-any->isexp* (∀ (A) (→ Any
|
|
||||||
(non-sexp-handler A)
|
|
||||||
(Values (U (Sexpof A) #f)
|
|
||||||
(U 'unmodified 'modified #f)))))
|
|
||||||
(define (try-any->isexp* e non-sexp)
|
|
||||||
(cond
|
|
||||||
[(boolean? e) (values e 'unmodified)]
|
|
||||||
[(char? e) (values e 'unmodified)]
|
|
||||||
[(number? e) (values e 'unmodified)]
|
|
||||||
[(keyword? e) (values e 'unmodified)]
|
|
||||||
[(null? e) (values e 'unmodified)]
|
|
||||||
[(string? e) (if (immutable? e)
|
|
||||||
(values e 'unmodified)
|
|
||||||
(values (string->immutable-string e) 'modified))]
|
|
||||||
[(symbol? e) (values e 'unmodified)]
|
|
||||||
[(box? e) (let*-values ([(u) (unbox e)]
|
|
||||||
[(u* status) (try-any->isexp* e non-sexp)])
|
|
||||||
(case status
|
|
||||||
[(unmodified)
|
|
||||||
(if (immutable? e)
|
|
||||||
(values (unsafe-cast e (Sexpof A)) 'unmodified)
|
|
||||||
(values (box-immutable u*) 'modified))]
|
|
||||||
[(modified)
|
|
||||||
(values (box-immutable u*) 'modified)]
|
|
||||||
[(#f)
|
|
||||||
(values #f #f)]))]
|
|
||||||
[(pair? e) (let*-values ([(car* status-car)
|
|
||||||
(try-any->isexp* (car e) non-sexp)]
|
|
||||||
[(cdr* status-cdr)
|
|
||||||
(try-any->isexp* (cdr e) non-sexp)])
|
|
||||||
(cond
|
|
||||||
[(and (eq? status-car 'unmodified)
|
|
||||||
(eq? status-cdr 'unmodified))
|
|
||||||
(values (unsafe-cast e (Sexpof A)) 'unmodified)]
|
|
||||||
[(or (eq? status-car #f)
|
|
||||||
(eq? status-cdr #f))
|
|
||||||
(values #f #f)]
|
|
||||||
[else
|
|
||||||
(values (cons car* cdr*) 'modified)]))]
|
|
||||||
[(vector? e) (match-let ([(cons vs* status)
|
|
||||||
(try-listof-any->isexp* (vector->list e) non-sexp)])
|
|
||||||
(case status
|
|
||||||
[(unmodified)
|
|
||||||
(if (immutable? e)
|
|
||||||
(values (unsafe-cast e (Sexpof A)) 'unmodified)
|
|
||||||
(values (apply vector-immutable vs*) 'modified))]
|
|
||||||
[(modified)
|
|
||||||
(values (apply vector-immutable vs*) 'modified)]
|
|
||||||
[(#f)
|
|
||||||
(values #f #f)]))]
|
|
||||||
[else
|
|
||||||
(non-sexp e)]))
|
|
||||||
|
|
||||||
|
|
||||||
(: any->isexp+non-sexp (→ Any (Sexpof (NonSexpOf Any))))
|
|
||||||
(define (any->isexp+non-sexp e)
|
|
||||||
(let*-values ([(e* status) (try-any->isexp*
|
|
||||||
e
|
|
||||||
(λ (non-sexp-e)
|
|
||||||
(values (NonSexp non-sexp-e)
|
|
||||||
'modified)))])
|
|
||||||
(case status
|
|
||||||
[(unmodified) (unsafe-cast e (Sexpof (NonSexpOf Any)))]
|
|
||||||
[(modified) e*]
|
|
||||||
[(#f)
|
|
||||||
(error
|
|
||||||
(string-append "Got #f from try->any-isexp* using non-sexp which does"
|
|
||||||
" not return #f."))])))
|
|
||||||
|
|
||||||
|
|
||||||
(: try-any->isexp (→ Any (Maybe Sexp)))
|
|
||||||
(define (try-any->isexp e)
|
|
||||||
(let*-values ([(e* status) (try-any->isexp*
|
|
||||||
e
|
|
||||||
(λ (non-sexp-e)
|
|
||||||
(values #f #f)))])
|
|
||||||
(case status
|
|
||||||
[(unmodified) (Some (unsafe-cast e Sexp))]
|
|
||||||
[(modified) (Some e*)]
|
|
||||||
[(#f) #f])))
|
|
||||||
|
|
@ -1,328 +0,0 @@
|
||||||
#lang typed/racket
|
|
||||||
|
|
||||||
(require typed-map
|
|
||||||
typed/racket/unsafe
|
|
||||||
"typed-prefab-declarations.rkt")
|
|
||||||
|
|
||||||
(unsafe-require/typed racket/base
|
|
||||||
[[datum->syntax datum->syntax*]
|
|
||||||
(∀ (A) (→ (Syntaxof Any)
|
|
||||||
A
|
|
||||||
(Syntaxof Any)
|
|
||||||
(Syntaxof Any)
|
|
||||||
(Syntaxof A)))])
|
|
||||||
|
|
||||||
(provide ISyntaxOf
|
|
||||||
ISyntaxOf-E
|
|
||||||
ISyntax
|
|
||||||
ISyntax-E
|
|
||||||
ISyntax/Non
|
|
||||||
ISyntax/Non-E
|
|
||||||
any->isyntax/non
|
|
||||||
syntax->isyntax/non
|
|
||||||
any->isyntax/non-e
|
|
||||||
try-any->isyntax
|
|
||||||
try-syntax->isyntax
|
|
||||||
try-any->isyntax-e
|
|
||||||
isyntax?
|
|
||||||
isyntax-e?)
|
|
||||||
|
|
||||||
(unsafe-require/typed racket/function
|
|
||||||
[[identity unsafe-cast-function] (∀ (A) (→ Any A))])
|
|
||||||
(define-syntax-rule (unsafe-cast v t)
|
|
||||||
((inst unsafe-cast-function t) v))
|
|
||||||
|
|
||||||
(define-type (ISyntaxOf A B)
|
|
||||||
(Rec
|
|
||||||
stx
|
|
||||||
(U A
|
|
||||||
(Syntaxof
|
|
||||||
(U B
|
|
||||||
Boolean
|
|
||||||
Char
|
|
||||||
Complex
|
|
||||||
Keyword
|
|
||||||
String
|
|
||||||
Symbol
|
|
||||||
(Boxof stx)
|
|
||||||
Null
|
|
||||||
(Pairof stx (Rec L (U Null
|
|
||||||
stx
|
|
||||||
(Pairof stx L))))
|
|
||||||
(Vectorof stx))))))
|
|
||||||
|
|
||||||
(define-type (ISyntaxOf-E A B)
|
|
||||||
(U B
|
|
||||||
Boolean
|
|
||||||
Char
|
|
||||||
Complex
|
|
||||||
Keyword
|
|
||||||
String
|
|
||||||
Symbol
|
|
||||||
(Boxof (ISyntaxOf A B))
|
|
||||||
Null
|
|
||||||
(Pairof (ISyntaxOf A B) (Rec L (U Null
|
|
||||||
(ISyntaxOf A B)
|
|
||||||
(Pairof (ISyntaxOf A B) L))))
|
|
||||||
(Vectorof (ISyntaxOf A B))))
|
|
||||||
|
|
||||||
(define-type ISyntax/Non (ISyntaxOf (NonSyntaxOf Any) (NonSexpOf Any)))
|
|
||||||
(define-type ISyntax/Non-E (ISyntaxOf-E (NonSyntaxOf Any) (NonSexpOf Any)))
|
|
||||||
|
|
||||||
(define-type ISyntax (ISyntaxOf Nothing Nothing))
|
|
||||||
(define-type ISyntax-E (ISyntaxOf-E Nothing Nothing))
|
|
||||||
|
|
||||||
(define-type (Result A) (U (Pairof A (U 'modified 'unmodified))
|
|
||||||
(Pairof #f #f)))
|
|
||||||
(define Result#f (cons #f #f))
|
|
||||||
|
|
||||||
(: syntax->isyntax* (∀ (A B) (→ (Syntaxof Any)
|
|
||||||
(→ Any (Result A))
|
|
||||||
(→ Any (Result B))
|
|
||||||
(U (Result (Syntaxof (ISyntaxOf-E A B)))))))
|
|
||||||
(define (syntax->isyntax* stx nstx nsexp)
|
|
||||||
(define e (syntax-e stx))
|
|
||||||
(match-define (cons e* status) (any->isyntax-e* e nstx nsexp))
|
|
||||||
(case status
|
|
||||||
[(unmodified)
|
|
||||||
(cons (unsafe-cast e (Syntaxof (ISyntaxOf-E A B))) 'unmodified)]
|
|
||||||
[(modified)
|
|
||||||
(cons (datum->syntax* stx e* stx stx) 'modified)]
|
|
||||||
[(#f)
|
|
||||||
Result#f]))
|
|
||||||
|
|
||||||
(: any->isyntax* (∀ (A B) (→ Any
|
|
||||||
(→ Any (Result A))
|
|
||||||
(→ Any (Result B))
|
|
||||||
(Result (ISyntaxOf A B)))))
|
|
||||||
(define (any->isyntax* e nstx nsexp)
|
|
||||||
(if (syntax? e)
|
|
||||||
(syntax->isyntax* e nstx nsexp)
|
|
||||||
(nstx e)))
|
|
||||||
|
|
||||||
(: listof-any->listof-isyntax
|
|
||||||
(∀ (A B) (→ (Listof Any)
|
|
||||||
(→ Any (Result A))
|
|
||||||
(→ Any (Result B))
|
|
||||||
(Result (Listof (ISyntaxOf A B))))))
|
|
||||||
(define (listof-any->listof-isyntax e nstx nsexp)
|
|
||||||
(define e*+status
|
|
||||||
(foldr (λ ([eᵢ : Any] [acc : (Result (Listof (ISyntaxOf A B)))])
|
|
||||||
(match-let ([(cons eᵢ* status) (any->isyntax* eᵢ nstx nsexp)])
|
|
||||||
(cond
|
|
||||||
[(and (eq? status 'unmodified)
|
|
||||||
(eq? (cdr acc) 'unmodified))
|
|
||||||
(cons (cons eᵢ* (car acc)) 'unmodified)]
|
|
||||||
[(or (eq? status #f)
|
|
||||||
(eq? (cdr acc) #f))
|
|
||||||
Result#f]
|
|
||||||
[else
|
|
||||||
(cons (cons eᵢ* (car acc)) 'modified)])))
|
|
||||||
(cons '() 'unmodified)
|
|
||||||
e))
|
|
||||||
(define e* (car e*+status))
|
|
||||||
(define status (cdr e*+status))
|
|
||||||
(case status
|
|
||||||
[(unmodified) (cons (unsafe-cast e (Listof (ISyntaxOf A B))) 'unmodified)]
|
|
||||||
[(modified) (cons e* 'modified)]
|
|
||||||
[(#f) Result#f]))
|
|
||||||
|
|
||||||
#;(: handle-pair (case→ (→ (Listof Any)
|
|
||||||
(Values (Listof Syntax-E)
|
|
||||||
(U 'unmodified 'modified)))
|
|
||||||
(→ (Pairof Any (Rec L (U Any (Pairof Any L))))
|
|
||||||
(Values (Pairof Syntax-E
|
|
||||||
(Rec L (U Syntax-E
|
|
||||||
(Pairof Syntax-E L))))
|
|
||||||
(U 'unmodified 'modified)))
|
|
||||||
(→ Any
|
|
||||||
(Values ISyntax
|
|
||||||
(U 'unmodified 'modified)))))
|
|
||||||
#;(: handle-pair (case→ (→ (Pairof Any (Listof Any))
|
|
||||||
(Values (Listof Syntax-E)
|
|
||||||
(U 'unmodified 'modified)))
|
|
||||||
(→ (Pairof Any (Rec L (U Any (Pairof Any L))))
|
|
||||||
(Values (Pairof Syntax-E
|
|
||||||
(Rec L (U Syntax-E
|
|
||||||
(Pairof Syntax-E L))))
|
|
||||||
(U 'unmodified 'modified)))))
|
|
||||||
(: handle-pair (∀ (A B) (→ (U (Pairof Any (Listof Any))
|
|
||||||
(Pairof Any (Rec L (U Any (Pairof Any L)))))
|
|
||||||
(→ Any (Result A))
|
|
||||||
(→ Any (Result B))
|
|
||||||
(Result (Pairof (ISyntaxOf A B)
|
|
||||||
(Rec L (U (ISyntaxOf A B)
|
|
||||||
Null
|
|
||||||
(Pairof (ISyntaxOf A B)
|
|
||||||
L))))))))
|
|
||||||
(define (handle-pair e nstx nsexp)
|
|
||||||
(define car*+status (any->isyntax* (car e) nstx nsexp))
|
|
||||||
(define car* (car car*+status))
|
|
||||||
(define status-car (cdr car*+status))
|
|
||||||
(cond
|
|
||||||
[(pair? (cdr e))
|
|
||||||
(match-let ([(cons cdr* status-cdr)
|
|
||||||
(handle-pair (cdr e) nstx nsexp)])
|
|
||||||
(cond
|
|
||||||
#;[(and (eq? status-car 'unmodified)
|
|
||||||
(eq? status-cdr 'unmodified))
|
|
||||||
(cons (unsafe-cast e (Pairof ISyntax
|
|
||||||
(Rec L (U ISyntax
|
|
||||||
Null
|
|
||||||
(Pairof ISyntax L)))))
|
|
||||||
'unmodified)]
|
|
||||||
[(or (eq? status-car #f)
|
|
||||||
(eq? status-cdr #f))
|
|
||||||
Result#f]
|
|
||||||
[else
|
|
||||||
(cons (cons car* cdr*) 'modified)]))]
|
|
||||||
[(null? (cdr e))
|
|
||||||
(cond
|
|
||||||
#;[(eq? status-car 'unmodified)
|
|
||||||
(cons (unsafe-cast e (Pairof ISyntax Null)) 'unmodified)]
|
|
||||||
[(eq? status-car #f)
|
|
||||||
Result#f]
|
|
||||||
[else
|
|
||||||
(cons (ann (cons car* (cdr e))
|
|
||||||
(Pairof (ISyntaxOf A B)
|
|
||||||
(Rec L (U (ISyntaxOf A B)
|
|
||||||
Null
|
|
||||||
(Pairof (ISyntaxOf A B)
|
|
||||||
L)))))
|
|
||||||
'modified)])]
|
|
||||||
[else
|
|
||||||
(match-let ([(cons cdr* status-cdr) (any->isyntax* (cdr e) nstx nsexp)])
|
|
||||||
(cond
|
|
||||||
#;[(and (eq? status-car 'unmodified)
|
|
||||||
(eq? status-cdr 'unmodified))
|
|
||||||
(cons (unsafe-cast e (Pairof ISyntax
|
|
||||||
(Rec L (U ISyntax
|
|
||||||
Null
|
|
||||||
(Pairof ISyntax L)))))
|
|
||||||
'unmodified)]
|
|
||||||
[(or (eq? status-car #f)
|
|
||||||
(eq? status-cdr #f))
|
|
||||||
Result#f]
|
|
||||||
[else
|
|
||||||
(cons (cons car* cdr*) 'modified)]))]))
|
|
||||||
|
|
||||||
(: any->isyntax-e* (∀ (A B) (→ Any
|
|
||||||
(→ Any (Result A))
|
|
||||||
(→ Any (Result B))
|
|
||||||
(Result (ISyntaxOf-E A B)))))
|
|
||||||
(define (any->isyntax-e* e nstx nsexp)
|
|
||||||
(cond
|
|
||||||
[(boolean? e) (cons e 'unmodified)]
|
|
||||||
[(char? e) (cons e 'unmodified)]
|
|
||||||
[(number? e) (cons e 'unmodified)]
|
|
||||||
[(keyword? e) (cons e 'unmodified)]
|
|
||||||
[(null? e) (cons e 'unmodified)]
|
|
||||||
[(string? e) (if (immutable? e)
|
|
||||||
(cons e 'unmodified)
|
|
||||||
(cons (string->immutable-string e) 'modified))]
|
|
||||||
[(symbol? e) (cons e 'unmodified)]
|
|
||||||
[(box? e) (match-let ([(cons u* status) (any->isyntax* (unbox e) nstx nsexp)])
|
|
||||||
(case status
|
|
||||||
[(unmodified)
|
|
||||||
;(if (immutable? e)
|
|
||||||
;(values (unsafe-cast e (Sexpof A)) 'unmodified)
|
|
||||||
(cons (box-immutable u*) 'modified);)
|
|
||||||
]
|
|
||||||
[(modified)
|
|
||||||
(cons (box-immutable u*) 'modified)]
|
|
||||||
[(#f)
|
|
||||||
Result#f]))]
|
|
||||||
[(pair? e) (handle-pair e nstx nsexp)]
|
|
||||||
[(vector? e) (match-let ([(cons vs* status)
|
|
||||||
(listof-any->listof-isyntax (vector->list e) nstx nsexp)])
|
|
||||||
(case status
|
|
||||||
[(unmodified)
|
|
||||||
(if (immutable? e)
|
|
||||||
(cons (unsafe-cast e (ISyntaxOf-E A B))
|
|
||||||
'unmodified)
|
|
||||||
(cons (apply vector-immutable vs*)
|
|
||||||
'modified))]
|
|
||||||
[(modified)
|
|
||||||
(cons (apply vector-immutable vs*) 'modified)]
|
|
||||||
[(#f)
|
|
||||||
Result#f]))]
|
|
||||||
[else
|
|
||||||
(nsexp e)]))
|
|
||||||
|
|
||||||
(: any->isyntax/non (→ Any ISyntax/Non))
|
|
||||||
(define (any->isyntax/non e)
|
|
||||||
(define e*+status
|
|
||||||
(any->isyntax* e
|
|
||||||
(λ (n) (cons (NonSyntax n) 'modified))
|
|
||||||
(λ (n) (cons (NonSexp n) 'modified))))
|
|
||||||
(if (cdr e*+status)
|
|
||||||
(car e*+status)
|
|
||||||
(error "Got #f from any->isyntax* with handlers not returning #f")))
|
|
||||||
|
|
||||||
(: syntax->isyntax/non (→ (Syntaxof Any) (Syntaxof ISyntax/Non-E)))
|
|
||||||
(define (syntax->isyntax/non stx)
|
|
||||||
(define e*+status
|
|
||||||
(syntax->isyntax* stx
|
|
||||||
(λ (n) (cons (NonSyntax n) 'modified))
|
|
||||||
(λ (n) (cons (NonSexp n) 'modified))))
|
|
||||||
(if (cdr e*+status)
|
|
||||||
(car e*+status)
|
|
||||||
(error "Got #f from any->isyntax* with handlers not returning #f")))
|
|
||||||
|
|
||||||
(: any->isyntax/non-e (→ Any ISyntax/Non-E))
|
|
||||||
(define (any->isyntax/non-e e)
|
|
||||||
(define e*+status
|
|
||||||
(any->isyntax-e* e
|
|
||||||
(λ (n) (cons (NonSyntax n) 'modified))
|
|
||||||
(λ (n) (cons (NonSexp n) 'modified))))
|
|
||||||
(if (cdr e*+status)
|
|
||||||
(car e*+status)
|
|
||||||
(error "Got #f from any->isyntax* with handlers not returning #f")))
|
|
||||||
|
|
||||||
(: try-any->isyntax (→ Any (Maybe ISyntax)))
|
|
||||||
(define (try-any->isyntax e)
|
|
||||||
(define e*+status
|
|
||||||
((inst any->isyntax* Nothing Nothing) e
|
|
||||||
(λ (n) Result#f)
|
|
||||||
(λ (n) Result#f)))
|
|
||||||
(if (cdr e*+status)
|
|
||||||
(Some (car e*+status))
|
|
||||||
#f))
|
|
||||||
|
|
||||||
(: try-syntax->isyntax (→ (Syntaxof Any) (Maybe (Syntaxof ISyntax-E))))
|
|
||||||
(define (try-syntax->isyntax stx)
|
|
||||||
(define e*+status
|
|
||||||
((inst syntax->isyntax* Nothing Nothing) stx
|
|
||||||
(λ (n) Result#f)
|
|
||||||
(λ (n) Result#f)))
|
|
||||||
(if (cdr e*+status)
|
|
||||||
(Some (car e*+status))
|
|
||||||
#f))
|
|
||||||
|
|
||||||
(: try-any->isyntax-e (→ Any (Maybe ISyntax-E)))
|
|
||||||
(define (try-any->isyntax-e e)
|
|
||||||
(define e*+status
|
|
||||||
((inst any->isyntax-e* Nothing Nothing) e
|
|
||||||
(λ (n) Result#f)
|
|
||||||
(λ (n) Result#f)))
|
|
||||||
(if (cdr e*+status)
|
|
||||||
(Some (car e*+status))
|
|
||||||
#f))
|
|
||||||
|
|
||||||
(define isyntax?
|
|
||||||
(unsafe-cast (λ ([e : Any]) : Boolean
|
|
||||||
(define e*+status
|
|
||||||
((inst any->isyntax* Nothing Nothing) e
|
|
||||||
(λ (n) Result#f)
|
|
||||||
(λ (n) Result#f)))
|
|
||||||
(eq? (cdr e*+status) 'unmodified))
|
|
||||||
(→ Any Boolean : ISyntax)))
|
|
||||||
|
|
||||||
(define isyntax-e?
|
|
||||||
(unsafe-cast (λ ([e : Any]) : Boolean
|
|
||||||
(define e*+status
|
|
||||||
((inst any->isyntax-e* Nothing Nothing) e
|
|
||||||
(λ (n) Result#f)
|
|
||||||
(λ (n) Result#f)))
|
|
||||||
(eq? (cdr e*+status) 'unmodified))
|
|
||||||
(→ Any Boolean : ISyntax-E)))
|
|
||||||
|
|
@ -1,52 +0,0 @@
|
||||||
#lang typed/racket
|
|
||||||
|
|
||||||
(provide isexp?
|
|
||||||
CoreSexp)
|
|
||||||
|
|
||||||
(module unsafe racket
|
|
||||||
(provide isexp?)
|
|
||||||
|
|
||||||
(define isexp/c
|
|
||||||
(flat-rec-contract isexp
|
|
||||||
(or/c boolean?
|
|
||||||
char?
|
|
||||||
number?
|
|
||||||
keyword?
|
|
||||||
null?
|
|
||||||
(and/c string? immutable?)
|
|
||||||
symbol?
|
|
||||||
(box/c isexp #:immutable #t)
|
|
||||||
(cons/c isexp isexp)
|
|
||||||
(vectorof isexp #:immutable #t))))
|
|
||||||
|
|
||||||
(define sexp/c
|
|
||||||
(recursive-contract
|
|
||||||
(or/c boolean?
|
|
||||||
char?
|
|
||||||
number?
|
|
||||||
keyword?
|
|
||||||
null?
|
|
||||||
string?
|
|
||||||
symbol?
|
|
||||||
(box/c sexp/c)
|
|
||||||
(cons/c sexp/c sexp/c)
|
|
||||||
(vectorof sexp/c))))
|
|
||||||
|
|
||||||
(define isexp?
|
|
||||||
(flat-contract-predicate isexp/c)))
|
|
||||||
|
|
||||||
(define-type CoreSexp (Rec core-sexp
|
|
||||||
(U Boolean
|
|
||||||
Char
|
|
||||||
Number
|
|
||||||
Keyword
|
|
||||||
Null
|
|
||||||
String
|
|
||||||
Symbol
|
|
||||||
#|(Boxof sexp)|#
|
|
||||||
(Pairof core-sexp core-sexp)
|
|
||||||
#|(Vectorof sexp)|#)))
|
|
||||||
|
|
||||||
(require typed/racket/unsafe)
|
|
||||||
(unsafe-require/typed 'unsafe
|
|
||||||
[isexp? (→ Any Boolean : #:+ Sexp #:- (! CoreSexp))])
|
|
||||||
|
|
@ -1,29 +0,0 @@
|
||||||
#lang typed/racket
|
|
||||||
|
|
||||||
(provide isexp?
|
|
||||||
try-any->isexp
|
|
||||||
any->isexp+non-sexp
|
|
||||||
CoreSexp
|
|
||||||
isyntax?
|
|
||||||
isyntax-e?
|
|
||||||
ISyntax
|
|
||||||
ISyntax-E
|
|
||||||
ISyntaxOf
|
|
||||||
ISyntaxOf-E
|
|
||||||
ISyntax/Non
|
|
||||||
ISyntax/Non-E
|
|
||||||
any->isyntax/non
|
|
||||||
syntax->isyntax/non
|
|
||||||
any->isyntax/non-e
|
|
||||||
try-any->isyntax
|
|
||||||
try-syntax->isyntax
|
|
||||||
try-any->isyntax-e
|
|
||||||
NonSexp NonSexp? NonSexp-v NonSexpOf
|
|
||||||
NonSyntax NonSyntax? NonSyntax-v NonSyntaxOf
|
|
||||||
Some Some? Some-v)
|
|
||||||
|
|
||||||
(require "typed-syntax-convert.rkt"
|
|
||||||
"typed-syntax-convert2.rkt"
|
|
||||||
"typed-syntax-predicate.rkt"
|
|
||||||
"typed-prefab-declarations.rkt")
|
|
||||||
|
|
||||||
4
info.rkt
4
info.rkt
|
|
@ -9,7 +9,9 @@
|
||||||
"typed-racket-more"
|
"typed-racket-more"
|
||||||
"typed-racket-doc"
|
"typed-racket-doc"
|
||||||
"scribble-enhanced"
|
"scribble-enhanced"
|
||||||
"sexp-diff"))
|
"sexp-diff"
|
||||||
|
"tr-immutable"
|
||||||
|
"typed-map"))
|
||||||
(define build-deps '("scribble-lib"
|
(define build-deps '("scribble-lib"
|
||||||
"racket-doc"
|
"racket-doc"
|
||||||
"rackunit-doc"
|
"rackunit-doc"
|
||||||
|
|
|
||||||
|
|
@ -1,19 +1,19 @@
|
||||||
#lang typed/racket
|
#lang typed/racket
|
||||||
|
|
||||||
(require typed-map
|
(require typed-map
|
||||||
"../../comments/typed-syntax.rkt")
|
tr-immutable/typed-syntax)
|
||||||
|
|
||||||
(provide annotate-syntax)
|
(provide annotate-syntax)
|
||||||
|
|
||||||
(: annotate-syntax (->* (Syntax)
|
(: annotate-syntax (->* (Syntax)
|
||||||
(#:srcloc+scopes? Boolean)
|
(#:srcloc+scopes? Boolean)
|
||||||
Sexp))
|
Sexp/Non))
|
||||||
(define (annotate-syntax e #:srcloc+scopes? [srcloc+scopes? #f])
|
(define (annotate-syntax e #:srcloc+scopes? [srcloc+scopes? #f])
|
||||||
(annotate-syntax1 e srcloc+scopes?))
|
(annotate-syntax1 e srcloc+scopes?))
|
||||||
|
|
||||||
(: annotate-syntax1 (→ (U Syntax Syntax-E)
|
(: annotate-syntax1 (→ (U Syntax Syntax-E)
|
||||||
Boolean
|
Boolean
|
||||||
Sexp))
|
Sexp/Non))
|
||||||
(define (annotate-syntax1 e srcloc+scopes?)
|
(define (annotate-syntax1 e srcloc+scopes?)
|
||||||
(cond
|
(cond
|
||||||
[(syntax? e)
|
[(syntax? e)
|
||||||
|
|
@ -24,17 +24,17 @@
|
||||||
(eq? kᵢ 'comments-after))
|
(eq? kᵢ 'comments-after))
|
||||||
(not (syntax-property e kᵢ)))
|
(not (syntax-property e kᵢ)))
|
||||||
(list)
|
(list)
|
||||||
(list kᵢ (any->isexp (syntax-property e kᵢ)))))
|
(list kᵢ (any->isexp/non (syntax-property e kᵢ)))))
|
||||||
(syntax-property-symbol-keys e)))
|
(syntax-property-symbol-keys e)))
|
||||||
(if srcloc+scopes?
|
(if srcloc+scopes?
|
||||||
(list (any->isexp (syntax-source e))
|
(list (any->isexp/non (syntax-source e))
|
||||||
(any->isexp (syntax-line e))
|
(any->isexp/non (syntax-line e))
|
||||||
(any->isexp (syntax-column e))
|
(any->isexp/non (syntax-column e))
|
||||||
(any->isexp (syntax-position e))
|
(any->isexp/non (syntax-position e))
|
||||||
(any->isexp (syntax-span e))
|
(any->isexp/non (syntax-span e))
|
||||||
(any->isexp (syntax-source-module e))
|
(any->isexp/non (syntax-source-module e))
|
||||||
(any->isexp (hash-ref (syntax-debug-info e)
|
(any->isexp/non (hash-ref (syntax-debug-info e)
|
||||||
'context)))
|
'context)))
|
||||||
(list))
|
(list))
|
||||||
(list (annotate-syntax1 (syntax-e e) srcloc+scopes?)))]
|
(list (annotate-syntax1 (syntax-e e) srcloc+scopes?)))]
|
||||||
[(null? e)
|
[(null? e)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user