You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
118 lines
3.3 KiB
Racket
118 lines
3.3 KiB
Racket
7 years ago
|
#lang at-exp racket/base
|
||
|
|
(require (for-syntax racket/base racket/match))
|
||
|
|
|
||
|
|
;; adapted from the far superior work of Jay McCarthy
|
||
|
|
;; https://github.com/jeapostrophe/remix/blob/master/remix/stx0.rkt
|
||
|
|
|
||
|
|
(provide module/lang module*/lang)
|
||
|
|
|
||
|
|
(define-syntax (module/lang stx)
|
||
|
|
(do-lang 'module/lang #'module stx))
|
||
|
|
|
||
|
|
(define-syntax (module*/lang stx)
|
||
|
|
(do-lang 'module*/lang #'module* stx))
|
||
|
|
|
||
|
|
(define-for-syntax (do-lang caller-id module-maker-stx stx)
|
||
|
|
(syntax-case stx ()
|
||
|
|
[(_ MODULE-NAME . STX-STRS)
|
||
|
|
(identifier? #'MODULE-NAME)
|
||
|
|
(let ()
|
||
|
|
(define input-port (syntax-strings->input-port
|
||
|
|
(syntax-source stx)
|
||
|
|
(syntax->list #'STX-STRS)))
|
||
|
|
(define module-body (parameterize ([read-accept-reader #t]
|
||
|
|
[read-accept-lang #t])
|
||
|
|
(read-syntax #'MODULE-NAME input-port)))
|
||
|
|
(with-handlers ([exn:fail:syntax?
|
||
|
|
(λ (exn) (raise-syntax-error caller-id "body did not read as module" stx module-body))])
|
||
|
|
(with-syntax ([(_ _ MODULE-LANG . REST) module-body]
|
||
|
|
[MODULE-MAKER module-maker-stx])
|
||
|
|
(syntax/loc stx (MODULE-MAKER MODULE-NAME MODULE-LANG . REST)))))]))
|
||
|
|
|
||
|
|
|
||
|
|
(define-for-syntax (syntax-strings->input-port name first-ss)
|
||
|
|
#;(-> any/c (listof syntax?) input-port?)
|
||
|
|
(unless (and (pair? first-ss) (andmap syntax? first-ss))
|
||
|
|
(raise-argument-error 'syntax-strings->input-port "list of syntax" first-ss))
|
||
|
|
|
||
|
|
(define line 1)
|
||
|
|
(define col 0)
|
||
|
|
(define pos 1)
|
||
|
|
(define current-idx #f)
|
||
|
|
(define current-bs #f)
|
||
|
|
(define next-ss first-ss)
|
||
|
|
|
||
|
|
(define (consume-ss!)
|
||
|
|
(match next-ss
|
||
|
|
['() (void)]
|
||
|
|
[(cons ss more-ss)
|
||
|
|
(set! line (syntax-line ss))
|
||
|
|
(set! col (syntax-column ss))
|
||
|
|
(set! pos (syntax-position ss))
|
||
|
|
(set! current-bs (string->bytes/utf-8 (syntax->datum ss)))
|
||
|
|
(set! current-idx 0)
|
||
|
|
(set! next-ss more-ss)]))
|
||
|
|
|
||
|
|
(consume-ss!)
|
||
|
|
|
||
|
|
(define (read-in bs)
|
||
|
|
(cond
|
||
|
|
[(not current-bs)
|
||
|
|
(match next-ss
|
||
|
|
['() eof]
|
||
|
|
[(cons ss more-ss)
|
||
|
|
(consume-ss!)
|
||
|
|
(read-in bs)])]
|
||
|
|
[(< current-idx (bytes-length current-bs))
|
||
|
|
(define how-many
|
||
|
|
(min (bytes-length bs)
|
||
|
|
(- (bytes-length current-bs)
|
||
|
|
current-idx)))
|
||
|
|
(define end (+ current-idx how-many))
|
||
|
|
(bytes-copy! bs 0 current-bs current-idx end)
|
||
|
|
(set! current-idx end)
|
||
|
|
(set! col (+ col how-many))
|
||
|
|
(set! pos (+ pos how-many))
|
||
|
|
(unless (< current-idx (bytes-length current-bs))
|
||
|
|
(consume-ss!))
|
||
|
|
how-many]
|
||
|
|
[else
|
||
|
|
(set! current-bs #f)
|
||
|
|
(read-in bs)]))
|
||
|
|
|
||
|
|
(define (get-location) (values line col pos))
|
||
|
|
|
||
|
|
(parameterize ([port-count-lines-enabled #t])
|
||
|
|
(make-input-port name read-in #f void #f #f
|
||
|
|
get-location void #f #f)))
|
||
|
|
|
||
|
|
|
||
|
|
;; can't run tests without the underlying languages installed
|
||
|
|
#;(module+ test
|
||
|
|
(require rackunit)
|
||
|
|
|
||
|
|
@module/lang[pollen-pre]{
|
||
|
|
#lang pollen
|
||
|
|
◊whoomp{there it is}
|
||
|
|
}
|
||
|
|
|
||
|
|
(require 'pollen-pre)
|
||
|
|
(check-equal? doc "'(whoomp \"there it is\")")
|
||
|
|
|
||
|
|
#|
|
||
|
|
;; raises "body did not read as module" error
|
||
|
|
@module/lang[pollen-pre]{
|
||
|
|
◊whoomp{there it is}
|
||
|
|
}
|
||
|
|
|#
|
||
|
|
|
||
|
|
@module/lang[brag]{
|
||
|
|
#lang brag
|
||
|
|
top: /"x"
|
||
|
|
}
|
||
|
|
|
||
|
|
(require 'brag)
|
||
|
|
(check-equal? (parse-to-datum "x") '(top))
|
||
|
|
|
||
|
|
)
|