From 9e1fadc94be2ab1dbe7e2085d3680d5371ec405f Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 24 Aug 2015 12:10:53 -0700 Subject: [PATCH] tidy core --- main-base.rkt | 54 +++++++++++++++++++++++-------------------------- reader-base.rkt | 48 ++++++++++++++++++++++++------------------- 2 files changed, 52 insertions(+), 50 deletions(-) diff --git a/main-base.rkt b/main-base.rkt index b1e1504..7cae217 100644 --- a/main-base.rkt +++ b/main-base.rkt @@ -1,38 +1,34 @@ #lang racket/base -(require (for-syntax racket/base 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) pollen/decode pollen/pagetree racket/list pollen/world markdown) (provide (all-defined-out) (all-from-out pollen/world)) -(define-syntax-rule (define+provide-module-begin-in-mode MODE-ARG) +(define-syntax-rule (define+provide-module-begin-in-mode PARSER-MODE-ARG) (begin (provide (except-out (all-from-out racket/base) #%module-begin) (rename-out [pollen-module-begin #%module-begin])) (define-syntax (pollen-module-begin stx) (syntax-case stx () - [(_ expr (... ...)) - (with-syntax ([EXPRS #'(expr (... ...))]) - (datum->syntax #'EXPRS - `(#%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)) - ,@(syntax->datum #'EXPRS)) - (require 'inner) - (define ,(world:current-main-export) - (let* ([parser-mode-undefined? (procedure? inner:parser-mode)] ; if undefined, #%top makes it a procedure - [parser-mode (if parser-mode-undefined? - 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)))])] - [doc-elements (if (list? doc-raw) ; discard all newlines at front of multi-line file - (dropf doc-raw (λ(ln) (equal? ln "\n"))) - doc-raw)]) ; single line - (apply proc doc-elements))) - (provide ,(world:current-main-export) (except-out (all-from-out 'inner) doc-raw #%top))) #'EXPRS))])))) ; hide internal exports \ No newline at end of file + [(_ 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 diff --git a/reader-base.rkt b/reader-base.rkt index 6e232f5..80738bc 100644 --- a/reader-base.rkt +++ b/reader-base.rkt @@ -55,28 +55,34 @@ 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)) - (with-syntax* ([(KEY ...) (datum->syntax source-stx meta-keys-plus-here)] - [(VALUE ...) (datum->syntax source-stx meta-values-plus-here)] - [KVS #'(append (list 'KEY VALUE) ...)]) + (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))] + [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)]) (syntax-property - (datum->syntax source-stx - `(module runtime-wrapper racket/base - (module metas racket/base - (provide (all-defined-out)) - (define ,(world:current-meta-export) (apply hash ,(syntax->datum #'KVS)))) - - (module pollen-lang-module pollen - (define parser-mode ',parser-mode) ; change names of exports for local use, to avoid conflicts - (provide (except-out (all-defined-out) parser-mode) - (prefix-out inner: parser-mode)) - ,(require+provide-directory-require-files path-string) - (require (submod ".." ".." metas)) ; get metas from adjacent submodule - (provide (all-from-out (submod ".." ".." metas))) - ,@meta-free-file-data) - - (require (submod pollen/runtime-config show) 'pollen-lang-module) - (provide (all-from-out 'pollen-lang-module)) - (show ,(world:current-main-export) inner:parser-mode)) source-stx) + (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 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))) 'module-language '#(pollen/language-info get-language-info #f)))))