bsl/lang/reader.rkt
#lang s-exp syntax/module-reader
(planet wrturtle/pyret/bsl/language)
#:read my-read
#:read-syntax my-read-syntax
#:whole-body-readers? #t
#:language-info
'#((planet wrturtle/pyret/bsl/lang/lang-info) get-info #f)
#:info (lambda (key defval default)
         (case key
           [(color-lexer)
            (dynamic-require '(planet wrturtle/pyret/bsl/tool/syntax-color) 'get-syntax-token)]
           [else (default key defval)]))

(require "../lexer.rkt")
(require "../parser.rkt")
(require racket/contract/base)

(define (stx->orig-stx stx)
  (define (datum? o)
    (or (symbol? o)
        (string? o)
        (number? o)
        (boolean? o)))
  (let ([se (syntax-e stx)])
    (cond
      [((listof syntax?) se)
       (datum->syntax stx (map stx->orig-stx se) stx)]
      [(datum? se)
       (begin
         (define p (open-input-string (if (string? se) (format "~e" se) (format "~a" se))))
         (port-count-lines! p)
         (define source (syntax-source stx))
         (define line (syntax-line stx))
         (define col (syntax-column stx))
         (define off (syntax-position stx))
         (define span (syntax-span stx))
         (set-port-next-location! p line col off)
         (read-syntax source p))]
      [else
       stx])))

(define (my-read in)
  (syntax->datum (car (my-read-syntax #f in))))

(define (my-read-syntax src in)
  (let ([srcname (if (string? src)
                     src
                     (if (symbol? src)
                         src
                         (if (path? src)
                             src
                             (begin
                               (printf "using false as source name\n")
                               #f))))])
    (parameterize ([lexer-source-name srcname]
                   [parser-source-name srcname]
                   [nal-state (newline-adding-lexer-state #f)])
      (map stx->orig-stx (program-parser (lambda () (newline-adding-lexer in)))))))