[honu] clean up requires by separating code into modules
This commit is contained in:
Jon Rafkind
parent
c758069a09
commit
cb42b7ed6a
|
|
@ -2,87 +2,15 @@
|
|||
|
||||
(require syntax/parse
|
||||
"debug.rkt"
|
||||
(for-syntax racket/base "debug.rkt" syntax/parse
|
||||
macro-debugger/emit)
|
||||
"literals.rkt")
|
||||
"literals.rkt"
|
||||
(for-syntax racket/base
|
||||
"debug.rkt"))
|
||||
|
||||
;; to get syntax as a literal
|
||||
(require (for-template racket/base))
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(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 ...)))]
|
||||
[(stuff* ...) (map remove-repeats (syntax->list #'(stuff ...)))]
|
||||
[(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)
|
||||
|
||||
|
|
@ -103,30 +31,3 @@
|
|||
(begin
|
||||
(debug 2 "Racket syntax ~a\n" (syntax->datum #'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])))
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
syntax/stx
|
||||
racket/set
|
||||
racket/syntax
|
||||
"template.rkt"
|
||||
"literals.rkt"
|
||||
(prefix-in phase1: "parse2.rkt")
|
||||
"debug.rkt"
|
||||
|
|
@ -217,11 +218,12 @@
|
|||
#'rest
|
||||
#t)])))
|
||||
|
||||
#|
|
||||
;; FIXME: we shouldn't need this definition here
|
||||
(define-syntax (as-honu-syntax stx)
|
||||
(syntax-parse stx
|
||||
[(_ form)
|
||||
(define compressed (phase0:compress-dollars #'form))
|
||||
(define compressed (compress-dollars #'form))
|
||||
(with-syntax ([stuff* (datum->syntax #'form (syntax->list compressed)
|
||||
#'form #'form)])
|
||||
(syntax #'stuff*))]))
|
||||
|
|
@ -234,6 +236,7 @@
|
|||
(with-syntax ([stuff* (datum->syntax #'form (syntax->list compressed)
|
||||
#'form #'form)])
|
||||
(syntax #'stuff*))])))
|
||||
|#
|
||||
|
||||
(provide honu-syntax)
|
||||
;; Do any honu-specific expansion here
|
||||
|
|
@ -243,7 +246,7 @@
|
|||
#;
|
||||
[(_ (#%parens single) . rest)
|
||||
(define context #'single)
|
||||
(define compressed (phase0:compress-dollars #'single))
|
||||
(define compressed (compress-dollars #'single))
|
||||
(values
|
||||
(with-syntax ([stuff* (datum->syntax context compressed context context)])
|
||||
(phase1:racket-syntax #'stuff*))
|
||||
|
|
@ -251,7 +254,7 @@
|
|||
#f)]
|
||||
[(_ (#%parens stuff ...) . rest)
|
||||
(define context (stx-car #'(stuff ...)))
|
||||
(define compressed (phase0:compress-dollars #'(stuff ...)))
|
||||
(define compressed (compress-dollars #'(stuff ...)))
|
||||
(values
|
||||
(with-syntax ([stuff* (datum->syntax context
|
||||
(syntax->list compressed)
|
||||
|
|
|
|||
|
|
@ -8,6 +8,8 @@
|
|||
"literals.rkt"
|
||||
"debug.rkt"
|
||||
"compile.rkt"
|
||||
"template.rkt"
|
||||
"utils.rkt"
|
||||
racket/list
|
||||
(prefix-in transformer: "transformer.rkt")
|
||||
(prefix-in fixture: "fixture.rkt")
|
||||
|
|
@ -25,7 +27,7 @@
|
|||
;; phase -1
|
||||
(require (for-template racket/base
|
||||
racket/splicing
|
||||
"compile.rkt"
|
||||
;; "compile.rkt"
|
||||
"syntax.rkt"
|
||||
"extra.rkt"))
|
||||
|
||||
|
|
|
|||
95
collects/honu/core/private/template.rkt
Normal file
95
collects/honu/core/private/template.rkt
Normal file
|
|
@ -0,0 +1,95 @@
|
|||
#lang racket/base
|
||||
|
||||
(require syntax/parse
|
||||
"literals.rkt"
|
||||
"debug.rkt"
|
||||
(for-syntax racket/base
|
||||
"debug.rkt"
|
||||
syntax/parse
|
||||
macro-debugger/emit
|
||||
))
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(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 ...)))]
|
||||
[(stuff* ...) (map remove-repeats (syntax->list #'(stuff ...)))]
|
||||
[(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 (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]))
|
||||
19
collects/honu/core/private/utils.rkt
Normal file
19
collects/honu/core/private/utils.rkt
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
#lang racket/base
|
||||
|
||||
(require syntax/parse
|
||||
"literals.rkt")
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(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
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user