From d418aa25e979c23cdd5f50d31631a5bc9fbf3ec1 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 6 Aug 2017 18:54:05 -0700 Subject: [PATCH] =?UTF-8?q?refactor=20main-base.rkt=20macros=20to=20emit?= =?UTF-8?q?=C2=A0less=20code?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- pollen/private/main-base.rkt | 109 +++++++++++++++++++---------------- pollen/private/ts.rktd | 2 +- 2 files changed, 61 insertions(+), 50 deletions(-) diff --git a/pollen/private/main-base.rkt b/pollen/private/main-base.rkt index 847622d..2decefe 100644 --- a/pollen/private/main-base.rkt +++ b/pollen/private/main-base.rkt @@ -1,61 +1,72 @@ #lang racket/base -(require (for-syntax racket/base syntax/strip-context racket/syntax "../setup.rkt" "split-metas.rkt") +(require (for-syntax racket/base racket/syntax "../setup.rkt" "split-metas.rkt") "to-string.rkt" "../pagetree.rkt" "splice.rkt" "../setup.rkt") -(require "../setup.rkt") (provide (except-out (all-from-out racket/base) #%module-begin) - (all-from-out "../setup.rkt") (rename-out [dialect-module-begin #%module-begin])) +(define (stringify xs) (apply string-append (map to-string xs))) + +(define (make-parse-proc parser-mode root-proc) + (cond + [(eq? parser-mode default-mode-pagetree) decode-pagetree] + [(eq? parser-mode default-mode-markup) (λ (xs) (apply root-proc xs))] + [(eq? parser-mode default-mode-markdown) + (λ (xs) (let* ([xs (stringify xs)] + [xs ((dynamic-require 'markdown 'parse-markdown) xs)] + [xs (map strip-empty-attrs xs)]) + (apply root-proc xs)))] + [else stringify])) ; preprocessor mode + +(define (strip-leading-newlines doc) + ;; drop leading newlines, as they're often the result of `defines` and `requires` + (or (memf (λ (ln) (not (equal? ln (setup:newline)))) doc) null)) + +(define-for-syntax (make-pmb-macro parser-mode-from-expander) + (λ (stx) + (syntax-case stx () + [(_ . EXPRS) + (let-values ([(meta-hash exprs-without-metas) (split-metas (syntax->datum #'EXPRS) (setup:define-meta-name))]) + (with-syntax (;; 'parser-mode-from-reader will be #f for an inline submodule + [PARSER-MODE-FROM-READER (syntax-property stx 'parser-mode-from-reader)] + [PARSER-MODE-FROM-EXPANDER parser-mode-from-expander] + [META-HASH meta-hash] + [EXPRS-WITHOUT-METAS exprs-without-metas] + [METAS-ID (setup:meta-export)] + [META-MOD-ID (setup:meta-export)] + [ROOT-ID (setup:main-root-node)] + [DOC-ID (setup:main-export)] + ;; prevents conflicts with other imported Pollen sources + [DOC-RAW (datum->syntax #'here (syntax->datum (generate-temporary 'pollen-)))]) + #'(#%module-begin + (require pollen/top) ; could be at top of this module, but better to contain it + + (module META-MOD-ID racket/base + (provide METAS-ID) + (define METAS-ID META-HASH)) + (require 'META-MOD-ID) + + (module inner pollen/private/doclang-raw + DOC-RAW ; positional arg for doclang-raw that sets name of export + (require pollen/top pollen/core pollen/setup (submod ".." META-MOD-ID)) + (provide (all-defined-out)) + . EXPRS-WITHOUT-METAS) + (require 'inner) + + (define DOC-ID + ;; parser-mode must be resolved at runtime, not compile time + (let* ([parser-mode (or 'PARSER-MODE-FROM-READER PARSER-MODE-FROM-EXPANDER)] + [proc (make-parse-proc parser-mode ROOT-ID)] + [doc-elements (strip-leading-newlines DOC-RAW)] + [doc-elements-spliced (splice doc-elements (setup:splicing-tag))]) + (proc doc-elements-spliced))) + + (provide DOC-ID METAS-ID (except-out (all-from-out 'inner) DOC-RAW)))))]))) + (define-syntax-rule (dialect-module-begin PARSER-MODE-FROM-EXPANDER . READER-SUBMOD-AND-OTHER-EXPRS) (#%module-begin (require racket/base) (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 () - [(_ . EXPRS) - (let-values ([(meta-hash exprs-without-metas) (split-metas (syntax->datum #'EXPRS) (setup:define-meta-name))]) - (with-syntax (;; 'parser-mode-from-reader will be #f for an inline submodule - [PARSER-MODE-FROM-READER-PROPERTY (syntax-property stx 'parser-mode-from-reader)] - [META-HASH meta-hash] - [EXPRS-WITHOUT-METAS exprs-without-metas] - [METAS (setup:meta-export)] - [META-MOD (setup:meta-export)] - [ROOT (setup:main-root-node)] - [NEWLINE (setup:newline)] - [MODE-PAGETREE default-mode-pagetree] - [MODE-MARKUP default-mode-markup] - [MODE-MARKDOWN default-mode-markdown] - [SPLICING-TAG (setup:splicing-tag)] - [DOC (setup:main-export)] - [DOC-RAW (generate-temporary 'pollen-)]); prevents conflicts with other imported Pollen sources - (replace-context - #'here - #'(#%module-begin - (module META-MOD racket/base - (provide METAS) - (define METAS META-HASH)) - - (module inner pollen/private/doclang-raw - DOC-RAW ; positional arg for doclang-raw that sets name of export. - (require pollen/top (submod ".." META-MOD) pollen/core pollen/setup) - (provide (all-defined-out) #%top (all-from-out (submod ".." META-MOD) pollen/core)) - . EXPRS-WITHOUT-METAS) - - (require 'inner) - - (define DOC - (let* ([parser-mode (or 'PARSER-MODE-FROM-READER-PROPERTY PARSER-MODE-FROM-EXPANDER)] - [proc (case parser-mode - [(MODE-PAGETREE) decode-pagetree] - [(MODE-MARKUP) (λ (xs) (apply ROOT xs))] ; if `root` undefined, it becomes a default tag function - [(MODE-MARKDOWN) (λ (xs) (apply ROOT (map strip-empty-attrs ((dynamic-require 'markdown 'parse-markdown) (apply string-append (map to-string xs))))))] - [else (λ (xs) (apply string-append (map to-string xs)))])] ; string output for preprocessor - ;; drop leading newlines, as they're often the result of `defines` and `requires` - [doc-elements (or (memf (λ (ln) (not (equal? ln NEWLINE))) DOC-RAW) null)] - [doc-elements-spliced (splice doc-elements 'SPLICING-TAG)]) - (proc doc-elements-spliced))) - - (provide DOC METAS (except-out (all-from-out 'inner) DOC-RAW #%top))))))])) + (define-syntax pollen-module-begin (make-pmb-macro 'PARSER-MODE-FROM-EXPANDER)) . READER-SUBMOD-AND-OTHER-EXPRS)) \ No newline at end of file diff --git a/pollen/private/ts.rktd b/pollen/private/ts.rktd index 2b580ce..cf98acb 100644 --- a/pollen/private/ts.rktd +++ b/pollen/private/ts.rktd @@ -1 +1 @@ -1502063717 +1502070845