From 69f75c067970409cfe8bc38d27124c5e4bc23325 Mon Sep 17 00:00:00 2001 From: AlexKnauth Date: Thu, 30 Jun 2016 19:09:32 -0400 Subject: [PATCH] use #lang lang-extension --- afl/lang/reader.rkt | 60 ++++++++++++++------------------------------- 1 file changed, 18 insertions(+), 42 deletions(-) diff --git a/afl/lang/reader.rkt b/afl/lang/reader.rkt index 5450318..3ad9090 100644 --- a/afl/lang/reader.rkt +++ b/afl/lang/reader.rkt @@ -1,42 +1,18 @@ -(module reader racket/base - (require syntax/module-reader - (only-in "../reader.rkt" wrap-reader)) - - (provide (rename-out [afl-read read] - [afl-read-syntax read-syntax] - [afl-get-info get-info])) - - (define-values (afl-read afl-read-syntax afl-get-info) - (make-meta-reader - 'afl - "language path" - (lambda (bstr) - (let* ([str (bytes->string/latin-1 bstr)] - [sym (string->symbol str)]) - (and (module-path? sym) - (vector - ;; try submod first: - `(submod ,sym reader) - ;; fall back to /lang/reader: - (string->symbol (string-append str "/lang/reader")))))) - wrap-reader - (lambda (orig-read-syntax) - (define read-syntax (wrap-reader orig-read-syntax)) - (lambda args - (define stx (apply read-syntax args)) - (define old-prop (syntax-property stx 'module-language)) - (define new-prop `#(afl/lang/language-info get-language-info ,old-prop)) - (syntax-property stx 'module-language new-prop))) - (lambda (proc) - (lambda (key defval) - (define (fallback) (if proc (proc key defval) defval)) - (define (try-dynamic-require mod export) - (or (with-handlers ([exn:fail? (λ (x) #f)]) - (dynamic-require mod export)) - (fallback))) - (case key - [(color-lexer) - (try-dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)] - [(definitions-text-surrogate) - 'scribble/private/indentation] - [else (fallback)])))))) +#lang lang-extension +#:lang-extension afl make-afl-lang-reader +#:lang-reader afl-lang +(require lang-reader/lang-reader + (only-in "../reader.rkt" wrap-reader)) + +(define (make-afl-lang-reader lang-reader) + (define/lang-reader [-read -read-syntax -get-info] lang-reader) + (make-lang-reader + (wrap-reader -read) + (let ([read-syntax (wrap-reader -read-syntax)]) + (lambda args + (define stx (apply read-syntax args)) + (define old-prop (syntax-property stx 'module-language)) + (define new-prop `#(afl/lang/language-info get-language-info ,old-prop)) + (syntax-property stx 'module-language new-prop))) + -get-info)) +