-
Notifications
You must be signed in to change notification settings - Fork 0
/
expander.rkt
84 lines (76 loc) · 3.38 KB
/
expander.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
#lang racket/base
(require (for-syntax pollen/setup
racket/base
racket/match
"private/constants.rkt")
pollen/core
pollen/pagetree
pollen/private/splice
pollen/setup
racket/contract
racket/list)
(provide (except-out (all-from-out racket/base) #%module-begin)
(rename-out [beeswax-module-begin #%module-begin]))
(define (strip-leading-whitespace lst)
(dropf lst (λ (ln) (or (member ln (list "" (void))) (regexp-match #px"^[\\s]+$" ln)))))
;; Split top-level stuff (requires, provides etc.) and defines out of a list of expressions
(define-for-syntax (forms-splitter lst)
(let loop ([body lst]
[toplevelstuff '()]
[defines '()]
[normalstuff '()])
(syntax-case body ()
[() (list (reverse toplevelstuff) (reverse defines) (reverse normalstuff))]
[((id rest ...) . body2)
(and (identifier? #'id)
(ormap (lambda (kw) (free-identifier=? #'id kw))
(syntax->list #'(require
provide
define-syntaxes
begin-for-syntax
module
module*
#%require
#%provide))))
(loop #'body2 (cons #'(id rest ...) toplevelstuff) defines normalstuff)]
[((id rest ...) . body2)
(and (identifier? #'id)
(ormap (lambda (kw) (free-identifier=? #'id kw))
(syntax->list #'(define define-values match-define))))
(loop #'body2 toplevelstuff (cons #'(id rest ...) defines) normalstuff)]
[(body1 . body2)
(loop #'body2 toplevelstuff defines (cons #'body1 normalstuff))])))
(define-for-syntax (pollen-requires)
(define pollen-rkt
(match (find-nearest-default-directory-require (current-project-root))
[(? path? p) `((file ,(path->string p)))]
[_ '()]))
`(require pollen/core pollen/template pollen/pagetree ,@pollen-rkt))
(define-syntax (beeswax-module-begin stx)
(syntax-case stx ()
[(_ . EXPRS)
(with-syntax ([((TOPLEVEL ...) (DEFINES ...) (BODY ...)) (forms-splitter #'EXPRS)]
[REQUIRES (datum->syntax #'EXPRS (pollen-requires))]
[EXPORT-FUNC (datum->syntax #'EXPRS template-proc-provide)]
[DOC (datum->syntax #'EXPRS 'doc)]
[METAS (datum->syntax #'EXPRS 'metas)]
[HERE (datum->syntax #'EXPRS 'here)])
#'(#%module-begin
(provide EXPORT-FUNC)
REQUIRES
TOPLEVEL ...
(define/contract (EXPORT-FUNC DOC METAS HERE)
(-> any/c hash? pagenode? bytes?)
DEFINES ...
(define result
(parameterize ([current-metas METAS]
[current-pagetree (make-project-pagetree (current-project-root))])
(strip-leading-whitespace (splice (list . (BODY ...))))))
(apply bytes-append (map ->bytes result)))))]))
(define (->bytes x)
(cond
[(bytes? x) x]
[(string? x) (string->bytes/utf-8 x)]
[(or (null? x) (void? x)) #""]
[(or (symbol? x) (number? x) (path? x) (char? x)) (string->bytes/utf-8 (format "~a" x))]
[else (string->bytes/utf-8 (format "~v" x))]))