Re-finagle module-begin to a more incremental style
Fixes 33
This commit is contained in:
parent
f64ad8389a
commit
f1c51661c7
|
@ -1,6 +1,7 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(require (for-syntax racket/base syntax/kerncase))
|
(require (for-syntax racket/base syntax/kerncase))
|
||||||
|
(require (for-syntax syntax/parse))
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "main.rkt")
|
(require "main.rkt")
|
||||||
|
@ -43,52 +44,54 @@
|
||||||
(raise-syntax-error #f "allowed only around a module body" stx))
|
(raise-syntax-error #f "allowed only around a module body" stx))
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ forms ...)
|
[(_ forms ...)
|
||||||
(let ()
|
#'(#%module-begin (syndicate-module () ((module+ syndicate-main) forms ...)))]))
|
||||||
(define (accumulate-actions action-ids final-forms forms)
|
|
||||||
(if (null? forms)
|
(define-syntax (syndicate-module stx)
|
||||||
(let ((final-stx
|
(syntax-parse stx
|
||||||
#`(#%module-begin (module+ syndicate-main
|
[(_ (action-ids ...) (form forms ...))
|
||||||
|
(define expanded (local-expand #'form
|
||||||
|
'module
|
||||||
|
(append (list #'module+
|
||||||
|
#'begin-for-declarations)
|
||||||
|
(kernel-form-identifier-list))))
|
||||||
|
(syntax-parse expanded
|
||||||
|
#:literals (begin)
|
||||||
|
[(begin more-forms ...)
|
||||||
|
#'(syndicate-module (action-ids ...) (more-forms ... forms ...))]
|
||||||
|
[(head rest ...)
|
||||||
|
(if (ormap (lambda (i) (free-identifier=? #'head i))
|
||||||
|
(syntax->list #'(require
|
||||||
|
provide
|
||||||
|
define-values
|
||||||
|
define-syntaxes
|
||||||
|
begin-for-syntax
|
||||||
|
module
|
||||||
|
module*
|
||||||
|
module+
|
||||||
|
#%require
|
||||||
|
#%provide
|
||||||
|
#%declare
|
||||||
|
begin-for-declarations)))
|
||||||
|
#`(begin #,expanded (syndicate-module (action-ids ...) (forms ...)))
|
||||||
|
(with-syntax ([action-id (car (generate-temporaries (list #'form)))])
|
||||||
|
#`(begin (define action-id (capture-actor-actions (lambda () #,expanded)))
|
||||||
|
(syndicate-module (action-ids ... action-id) (forms ...)))))]
|
||||||
|
[non-pair-syntax
|
||||||
|
#'(begin form (syndicate-module (action-ids ...) (forms ...)))])]
|
||||||
|
[(_ (action-ids ...) ())
|
||||||
|
(let ([final-stx
|
||||||
|
#`(begin (module+ syndicate-main
|
||||||
(provide boot-actions activate!)
|
(provide boot-actions activate!)
|
||||||
(define activated? #f)
|
(define activated? #f)
|
||||||
(define boot-actions (list #,@(reverse action-ids)))
|
(define boot-actions (list action-ids ...))
|
||||||
(define (activate!)
|
(define (activate!)
|
||||||
(when (not activated?)
|
(when (not activated?)
|
||||||
(set! activated? #t)
|
(set! activated? #t)
|
||||||
boot-actions)))
|
boot-actions)))
|
||||||
(module+ main
|
(module+ main
|
||||||
(current-ground-dataspace run-ground))
|
(current-ground-dataspace run-ground))
|
||||||
#,@(reverse final-forms)
|
|
||||||
(module+ main
|
(module+ main
|
||||||
(require (submod ".." syndicate-main))
|
(require (submod ".." syndicate-main))
|
||||||
((current-ground-dataspace) (activate!))))))
|
((current-ground-dataspace) (activate!))))])
|
||||||
;;(pretty-print (syntax->datum final-stx))
|
;;(pretty-print (syntax->datum final-stx))
|
||||||
final-stx)
|
final-stx)]))
|
||||||
(syntax-case (local-expand (car forms)
|
|
||||||
'module
|
|
||||||
(append (list #'module+
|
|
||||||
#'begin-for-declarations)
|
|
||||||
(kernel-form-identifier-list))) ()
|
|
||||||
[(head rest ...)
|
|
||||||
(if (free-identifier=? #'head #'begin)
|
|
||||||
(accumulate-actions action-ids
|
|
||||||
final-forms
|
|
||||||
(append (syntax->list #'(rest ...)) (cdr forms)))
|
|
||||||
(if (ormap (lambda (i) (free-identifier=? #'head i))
|
|
||||||
(syntax->list #'(define-values define-syntaxes begin-for-syntax
|
|
||||||
module module* module+
|
|
||||||
#%module-begin
|
|
||||||
#%require #%provide
|
|
||||||
begin-for-declarations)))
|
|
||||||
(accumulate-actions action-ids
|
|
||||||
(cons (car forms) final-forms)
|
|
||||||
(cdr forms))
|
|
||||||
(accumulate-action (car forms) action-ids final-forms (cdr forms))))]
|
|
||||||
[non-pair-syntax
|
|
||||||
(accumulate-action (car forms) action-ids final-forms (cdr forms))])))
|
|
||||||
(define (accumulate-action action action-ids final-forms remaining-forms)
|
|
||||||
(define temp (car (generate-temporaries (list action))))
|
|
||||||
(accumulate-actions (cons temp action-ids)
|
|
||||||
(cons #`(define #,temp (capture-actor-actions (lambda () #,action)))
|
|
||||||
final-forms)
|
|
||||||
remaining-forms))
|
|
||||||
(accumulate-actions '() '() (syntax->list #'(forms ...))))]))
|
|
||||||
|
|
Loading…
Reference in New Issue