diff --git a/main-base.rkt b/main-base.rkt index 7cae217..05da0dd 100644 --- a/main-base.rkt +++ b/main-base.rkt @@ -1,8 +1,26 @@ #lang racket/base -(require (for-syntax racket/base syntax/strip-context racket/syntax pollen/world) pollen/decode pollen/pagetree racket/list pollen/world markdown) +(require (for-syntax racket/base syntax/strip-context racket/syntax pollen/world racket/list) pollen/decode pollen/pagetree racket/list pollen/world markdown) (provide (all-defined-out) (all-from-out pollen/world)) +(define-for-syntax (split-metas tree) + (define (meta-matcher x) ; meta has form (define-meta key value) + (and (list? x) (>= (length x) 3) (eq? (first x) (world:current-define-meta-name)))) + (define matches empty) + (define rest + (let loop ([x tree]) + (cond + [(meta-matcher x) + (set! matches (cons x matches)) + (loop empty)] + [(list? x) + (define-values (new-matches rest) (partition meta-matcher x)) + (set! matches (append new-matches matches)) + (map loop rest)] + [else x]))) + (let ([meta-key second][meta-value third]) + (values (map meta-key matches) (map meta-value matches) rest))) + (define-syntax-rule (define+provide-module-begin-in-mode PARSER-MODE-ARG) (begin (provide (except-out (all-from-out racket/base) #%module-begin) @@ -10,25 +28,36 @@ (define-syntax (pollen-module-begin stx) (syntax-case stx () [(_ EXPR (... ...)) - (with-syntax ([DOC (format-id #'(EXPR (... ...)) "~a" (world:current-main-export))]) - (replace-context #'(EXPR (... ...)) - #'(#%module-begin - (module inner pollen/doclang-raw ; exports result as doc-raw - (require pollen/top pollen/world) - (provide #%top (all-defined-out) (all-from-out pollen/world)) - EXPR (... ...)) - (require 'inner) - (define DOC - (let* ([parser-mode-undefined? (procedure? inner:parser-mode)] ; if undefined, #%top makes it a procedure - [parser-mode (if parser-mode-undefined? PARSER-MODE-ARG inner:parser-mode)] - [proc (cond - [(eq? parser-mode world:mode-pagetree) (λ xs (decode-pagetree xs))] - [(eq? parser-mode world:mode-markup) root] ; if `root` undefined, it becomes a default tag function - [(eq? parser-mode world:mode-markdown) - (λ xs (apply root (apply (compose1 parse-markdown string-append) (map to-string xs))))] - [else ; for preprocessor output, just make a string - (λ xs (apply string-append (map to-string xs)))])] - ;; drop leading newlines, as they're often the result of `defines` and `requires` - [doc-elements (dropf doc-raw (λ(ln) (equal? ln "\n")))]) - (apply proc doc-elements))) - (provide DOC (except-out (all-from-out 'inner) doc-raw #%top)))))])))) ; hide internal exports \ No newline at end of file + (let-values ([(meta-keys meta-values expr-without-metas) (split-metas (syntax->datum #'(EXPR (... ...))))]) + (with-syntax ([(EXPR-WITHOUT-METAS (... ...)) (datum->syntax #'(EXPR (... ...)) expr-without-metas)] + [(KEY (... ...)) (datum->syntax #'(EXPR (... ...)) meta-keys)] + [(VALUE (... ...)) (datum->syntax #'(EXPR (... ...)) meta-values)] + [METAS (format-id #'(EXPR (... ...)) "~a" (world:current-meta-export))] + [META-MOD (format-symbol "~a" (world:current-meta-export))] + [DOC (format-id #'(EXPR (... ...)) "~a" (world:current-main-export))]) + (replace-context #'(EXPR (... ...)) + #'(#%module-begin + (module META-MOD racket/base + (provide (all-defined-out)) + (define METAS (apply hash (append (list 'KEY VALUE) (... ...))))) + + (module inner pollen/doclang-raw ; exports result as doc-raw + (require pollen/top pollen/world) + (provide #%top (all-defined-out) (all-from-out pollen/world)) + EXPR-WITHOUT-METAS (... ...)) + + (require 'inner 'META-MOD) + (define DOC + (let* ([parser-mode-undefined? (procedure? inner:parser-mode)] ; if undefined, #%top makes it a procedure + [parser-mode (if parser-mode-undefined? PARSER-MODE-ARG inner:parser-mode)] + [proc (cond + [(eq? parser-mode world:mode-pagetree) (λ xs (decode-pagetree xs))] + [(eq? parser-mode world:mode-markup) root] ; if `root` undefined, it becomes a default tag function + [(eq? parser-mode world:mode-markdown) + (λ xs (apply root (apply (compose1 parse-markdown string-append) (map to-string xs))))] + [else ; for preprocessor output, just make a string + (λ xs (apply string-append (map to-string xs)))])] + ;; drop leading newlines, as they're often the result of `defines` and `requires` + [doc-elements (dropf doc-raw (λ(ln) (equal? ln "\n")))]) + (apply proc doc-elements))) + (provide DOC METAS (except-out (all-from-out 'inner) doc-raw #%top))))))])))) ; hide internal exports \ No newline at end of file diff --git a/reader-base.rkt b/reader-base.rkt index eb17876..c660a80 100644 --- a/reader-base.rkt +++ b/reader-base.rkt @@ -8,25 +8,6 @@ (λ(p) (syntax->datum (custom-read-syntax-proc (object-name p) p)))) -(define (split-metas tree) - (define (meta-matcher x) ; meta has form (define-meta key value) - (and (list? x) (>= (length x) 3) (eq? (first x) (world:current-define-meta-name)))) - (define matches empty) - (define rest - (let loop ([x tree]) - (cond - [(meta-matcher x) - (set! matches (cons x matches)) - (loop empty)] - [(list? x) - (define-values (new-matches rest) (partition meta-matcher x)) - (set! matches (append new-matches matches)) - (map loop rest)] - [else x]))) - (let ([meta-key second][meta-value third]) - (values (map meta-key matches) (map meta-value matches) rest))) - - (define (make-custom-read-syntax reader-mode) (λ (path-string p) (define read-inner (make-at-reader @@ -38,7 +19,6 @@ #:syntax? #t #:inside? #t)) (define source-stx (read-inner path-string p)) - (define-values (meta-keys meta-values meta-free-file-data) (split-metas (syntax->datum source-stx))) (define reader-here-path (cond [(symbol? path-string) (symbol->string path-string)] [(equal? path-string "unsaved editor") path-string] @@ -53,34 +33,24 @@ [else world:mode-preproc])]) auto-computed-mode) reader-mode)) - (define meta-keys-plus-here (cons (world:current-here-path-key) meta-keys)) ; here-path at front so it can be overridden - (define meta-values-plus-here (cons reader-here-path meta-values)) (define post-parser-syntax - (with-syntax ([(KEY ...) (datum->syntax source-stx meta-keys-plus-here)] - [(VALUE ...) (datum->syntax source-stx meta-values-plus-here)] - [METAS (format-id source-stx "~a" (world:current-meta-export))] - [META-MOD (format-symbol "~a" (world:current-meta-export))] + (with-syntax ([HERE-KEY (format-id source-stx "~a" (world:current-here-path-key))] + [HERE-PATH (datum->syntax source-stx reader-here-path)] [POLLEN-MOD (format-symbol "~a" 'pollen-lang-module)] - [DOC (format-id source-stx "~a" (world:current-main-export))] [PARSER-MODE-VALUE (format-symbol "~a" parser-mode)] [DIRECTORY-REQUIRES (datum->syntax source-stx (require+provide-directory-require-files path-string))] - [(SOURCE-LINE ...) (datum->syntax source-stx meta-free-file-data)]) + [(SOURCE-LINE ...) source-stx] + [DOC (format-id source-stx "~a" (world:current-main-export))]) (replace-context source-stx #'(module runtime-wrapper racket/base - (module META-MOD racket/base - (provide (all-defined-out)) - (define METAS (apply hash (append (list 'KEY VALUE) ...)))) - (module POLLEN-MOD pollen + (define-meta HERE-KEY HERE-PATH) (define parser-mode 'PARSER-MODE-VALUE) (provide (except-out (all-defined-out) parser-mode) (prefix-out inner: parser-mode)) ; avoids conflicts with importing modules DIRECTORY-REQUIRES - (require (submod ".." ".." META-MOD)) ; get metas from adjacent submodule - (provide (all-from-out (submod ".." ".." META-MOD))) SOURCE-LINE ...) - (require (submod pollen/runtime-config show) 'POLLEN-MOD) (provide (all-from-out 'POLLEN-MOD)) (show DOC inner:parser-mode))))) diff --git a/test/test-inline-submodule.rkt b/test/test-inline-submodule.rkt new file mode 100644 index 0000000..f8a7914 --- /dev/null +++ b/test/test-inline-submodule.rkt @@ -0,0 +1,23 @@ +#lang racket/base + +(module inline pollen + (define-meta foo 42) + "Zut Alors") + +(module test-main racket/base + (require rackunit) + (require (submod ".." inline)) + (check-equal? doc "Zut Alors") + (check-equal? metas (hash 'foo 42))) + +(module test-metas-submod racket/base + (require rackunit) + (require (submod ".." inline metas)) + (let () + (define-syntax-rule (#%top . xs) + 'unbound-identifier) + (check-equal? doc 'unbound-identifier)) + (check-equal? metas (hash 'foo 42))) + +(require 'test-main) +(require 'test-metas-submod) \ No newline at end of file