146 lines
5.4 KiB
Racket
146 lines
5.4 KiB
Racket
#lang racket/base
|
|
|
|
(require syntax/parse
|
|
"debug.rkt"
|
|
(for-syntax racket/base "debug.rkt" syntax/parse
|
|
macro-debugger/emit)
|
|
"literals.rkt")
|
|
|
|
;; to get syntax as a literal
|
|
(require (for-template racket/base))
|
|
|
|
(provide (all-defined-out))
|
|
|
|
(define (honu->racket forms)
|
|
(define-literal-set literals (%racket))
|
|
forms
|
|
#;
|
|
(syntax-parse forms #:literal-sets (literals)
|
|
#:literals ([literal-syntax syntax])
|
|
[(%racket x) #'x
|
|
#;
|
|
(honu->racket #'x)]
|
|
[(literal-syntax form) #'#'form]
|
|
[(form ...)
|
|
(datum->syntax forms
|
|
(map honu->racket (syntax->list #'(form ...)))
|
|
forms
|
|
forms)]
|
|
[x #'x]
|
|
[() forms]))
|
|
|
|
(define (strip-stops code)
|
|
(define-syntax-class stopper #:literal-sets (cruft)
|
|
#;
|
|
[pattern semicolon]
|
|
[pattern honu-comma]
|
|
[pattern colon])
|
|
#;
|
|
(syntax-parse code
|
|
[(x:stopper rest ...) (strip-stops #'(rest ...))]
|
|
[else code])
|
|
code
|
|
)
|
|
|
|
(define-syntax repeat$ (lambda (stx) (raise-syntax-error 'repeat$ "dont use this")))
|
|
|
|
(define (remove-repeats input)
|
|
(debug 2 "Remove repeats from ~a\n" (syntax->datum input))
|
|
(debug 2 "Properties ~a\n" (syntax-property-symbol-keys input))
|
|
(define-literal-set locals (repeat$))
|
|
(syntax-parse input #:literal-sets ([locals #:at input])
|
|
[(out ... ((~literal repeat$) stuff ...) rest ...)
|
|
(debug 2 " Found a repeat\n")
|
|
(with-syntax ([(out* ...) (map remove-repeats (syntax->list #'(out ...)))]
|
|
[(rest* ...) (map remove-repeats (syntax->list #'(rest ...)))])
|
|
(remove-repeats (datum->syntax input
|
|
(syntax->list #'(out* ... stuff ... rest* ...))
|
|
input input)))]
|
|
[(normal ...) (with-syntax ([(normal* ...) (map remove-repeats (syntax->list #'(normal ...)))])
|
|
(datum->syntax input
|
|
(syntax->list #'(normal* ...))
|
|
input input))]
|
|
[x #'x]
|
|
[else (raise-syntax-error 'repeats "unhandled case" input)]))
|
|
|
|
(define-syntax (unexpand-honu-syntax stx)
|
|
(define (remove-repeats input)
|
|
(debug 2 "Remove repeats from ~a\n" (syntax->datum input))
|
|
(debug 2 "Properties ~a\n" (syntax-property-symbol-keys input))
|
|
(define-literal-set locals (repeat$))
|
|
(syntax-parse input #:literal-sets (locals)
|
|
[(out ... (repeat$ stuff ...) rest ...)
|
|
(debug 2 " Found a repeat\n")
|
|
(with-syntax ([(out* ...) (map remove-repeats (syntax->list #'(out ...)))]
|
|
[(rest* ...) (map remove-repeats (syntax->list #'(rest ...)))])
|
|
(remove-repeats (datum->syntax input
|
|
(syntax->list #'(out* ... stuff ... rest* ...))
|
|
input input)))]
|
|
[(normal ...) (with-syntax ([(normal* ...) (map remove-repeats (syntax->list #'(normal ...)))])
|
|
(datum->syntax input
|
|
(syntax->list #'(normal* ...))
|
|
input input))]
|
|
[x #'x]
|
|
[else (raise-syntax-error 'repeats "unhandled case" input)]))
|
|
|
|
(syntax-case stx ()
|
|
[(_ expr)
|
|
(begin
|
|
(debug "Expand honu syntax at phase ~a\n" (syntax-local-phase-level))
|
|
#;
|
|
(debug " Is ~a expanded ~a\n" (syntax->datum #'expr) (syntax->datum #'#'expr))
|
|
(emit-remark (format "Unexpand honu syntax at phase ~a" (syntax-local-phase-level))
|
|
#'expr)
|
|
#;
|
|
(syntax-case #'expr ()
|
|
[(_ what) (debug "Properties on ~a are ~a\n" #'what (syntax-property-symbol-keys #'what))])
|
|
(define removed (remove-repeats #'expr))
|
|
(emit-local-step #'expr removed #:id #'unexpand-honu-syntax)
|
|
(debug "Cleansed ~a\n" (syntax->datum removed))
|
|
(debug "Syntax properties ~a\n" (syntax-property-symbol-keys removed))
|
|
removed)]))
|
|
|
|
; (define parsed-property (gensym 'honu-parsed))
|
|
(define parsed-property 'honu-parsed)
|
|
|
|
(define (parsed-syntax syntax)
|
|
(debug "Add parsed syntax property to ~a\n" syntax)
|
|
(if syntax
|
|
(syntax-property syntax parsed-property #t)
|
|
syntax))
|
|
|
|
(define (parsed-syntax? syntax)
|
|
(syntax-property syntax parsed-property))
|
|
|
|
(define-syntax (racket-syntax stx)
|
|
(syntax-case stx ()
|
|
[(_ form)
|
|
#'(parsed-syntax #'form)]))
|
|
|
|
(begin-for-syntax
|
|
(provide compress-dollars)
|
|
(define (compress-dollars stx)
|
|
(define-literal-set local-literals (honu-$ repeat$))
|
|
(define-splicing-syntax-class not-dollar
|
|
#:literal-sets (local-literals)
|
|
[pattern x #:when (or (not (identifier? #'x))
|
|
(not (free-identifier=? #'honu-$ #'x)))
|
|
#:with out #'x])
|
|
(debug 2 "Compress dollars ~a\n" stx)
|
|
(syntax-parse stx #:literal-sets (local-literals)
|
|
[(honu-$ x:not-dollar ... honu-$ rest ...)
|
|
(debug 2 "Compressing ~a\n" #'(x.out ...))
|
|
(with-syntax ([(rest* ...) (compress-dollars #'(rest ...))])
|
|
(datum->syntax stx (syntax->list #'((repeat$ x.out ...) rest* ...))
|
|
stx stx))]
|
|
[(honu-$ rest ...)
|
|
(error 'compress-dollars "unmatched $ ~a" (syntax->datum stx))]
|
|
[(x rest ...)
|
|
(with-syntax ([x* (compress-dollars #'x)]
|
|
[(rest* ...) (compress-dollars #'(rest ...))])
|
|
(datum->syntax stx
|
|
(syntax->list #'(x* rest* ...))
|
|
stx stx))]
|
|
[x #'x])))
|
|
|