110 lines
4.1 KiB
Racket
110 lines
4.1 KiB
Racket
#lang typed/racket
|
|
|
|
;; The module needs to be defined using racket, as typed/racket doesn't support
|
|
;; provide `for-meta` nor `for-syntax`.
|
|
(module dotlang racket
|
|
(require typed/racket)
|
|
|
|
(provide (except-out (all-from-out typed/racket)
|
|
#;#%top
|
|
#%module-begin)
|
|
(rename-out #;[new-#%top #%top]
|
|
[new-#%module-begin #%module-begin]))
|
|
|
|
|
|
(require "get.lp2.rkt"
|
|
(submod "../lib/low.rkt" untyped)
|
|
(for-syntax racket/string
|
|
syntax/parse
|
|
racket/syntax
|
|
syntax/strip-context
|
|
racket/struct
|
|
racket/function
|
|
syntax/srcloc
|
|
(submod "../lib/low.rkt" untyped)))
|
|
|
|
#|
|
|
(define-syntax/parse (dot x:id)
|
|
(let* ([str (symbol->string (syntax-e #'x))]
|
|
[components (regexp-match* #px"([^.…]|\\.\\.+)+|…" str)]
|
|
[unescaped (map (λ (m) (regexp-replace* #px"\\.(\\.+)" m "\\1"))
|
|
components)]
|
|
[identifiers (map (λ (u) (datum->syntax #'x (string->symbol u)))
|
|
unescaped)]
|
|
[leading-dot? (regexp-match #px"^(\\.|…)" str)]
|
|
[trailing-dot? (regexp-match #px"\\.$" str)])
|
|
(define/with-syntax (id …) identifiers)
|
|
(cond
|
|
[leading-dot? #'(λget id …)]
|
|
[trailing-dot? (raise-syntax-error 'dot "Found trailing dot" #'x)]
|
|
[else #'(get id …)])))
|
|
|
|
(define-syntax (new-#%top stx)
|
|
(syntax-case stx ()
|
|
[(_ . x)
|
|
(if (regexp-match #rx"\\." (symbol->string (syntax-e #'x)))
|
|
#`(dot x)
|
|
#'(#%top . x))]))|#
|
|
|
|
(define-syntax (new-#%module-begin stx)
|
|
(syntax-case stx ()
|
|
[(_ . body)
|
|
#`(#%module-begin
|
|
. #,(fold-syntax replace-dots
|
|
#'body))]))
|
|
|
|
(define-for-syntax (replace-dots stx)
|
|
(syntax-parse stx
|
|
[x:id
|
|
#:when (regexp-match #px"^.*[.…].*[^.…]$"
|
|
(symbol->string (syntax-e #'x)))
|
|
(let* ([str (symbol->string (syntax-e #'x))]
|
|
[components (regexp-match* #px"([^.…]|\\.\\.+)+|…" str)]
|
|
[unescaped (map (λ (m) (regexp-replace* #px"\\.(\\.+)" m "\\1"))
|
|
components)]
|
|
[identifiers (map (λ (u) (datum->syntax stx
|
|
(string->symbol u)
|
|
stx
|
|
stx))
|
|
unescaped)]
|
|
[leading-dot? (regexp-match #px"^(\\.|…)" str)]
|
|
[trailing-dot? (regexp-match #px"\\.$" str)])
|
|
(define/with-syntax (id …) identifiers)
|
|
(if leading-dot?
|
|
(let* ([loc (update-source-location stx #:span 1)])
|
|
(quasisyntax/loc stx (#,(datum->syntax stx 'λget loc stx) id …)))
|
|
(if (= (length identifiers) 1)
|
|
(quasisyntax/loc stx #,(car identifiers))
|
|
(quasisyntax/loc stx
|
|
(#,(datum->syntax stx 'get stx stx) id …)))))]
|
|
[x:id
|
|
#:when (regexp-match #px"\\.$" (symbol->string (syntax-e #'x)))
|
|
(let* ([str (symbol->string (syntax-e #'x))]
|
|
[unescaped (substring str 0 (sub1 (string-length str)))])
|
|
(datum->syntax stx (string->symbol unescaped) stx stx))]
|
|
[_ stx]))
|
|
|
|
(define-for-syntax (fold-syntax f e)
|
|
(cond
|
|
[(syntax? e)
|
|
(let ([new-e (f e)])
|
|
(if (eq? new-e e)
|
|
(datum->syntax e (fold-syntax f (syntax-e e)) e e)
|
|
new-e))]
|
|
[(pair? e)
|
|
(cons (fold-syntax f (car e))
|
|
(fold-syntax f (cdr e)))]
|
|
[(vector? e)
|
|
(list->vector (fold-syntax f (vector->list e)))]
|
|
[(box? e)
|
|
(box (fold-syntax f (unbox e)))]
|
|
[(prefab-struct-key e)
|
|
=> (λ (k) (apply make-prefab-struct
|
|
k
|
|
(fold-syntax f (struct->list e))))]
|
|
[else e])))
|
|
|
|
(require 'dotlang)
|
|
(provide (all-from-out 'dotlang))
|
|
|