-
Notifications
You must be signed in to change notification settings - Fork 18
/
Copy pathebnf.rkt
101 lines (93 loc) · 4.23 KB
/
ebnf.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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
#lang at-exp racket/base
(require scribble/base scribble/core scribble/decode scribble/basic scribble/html-properties
racket/list "ragged.rkt" racket/string)
(provide bnf prod-link prod-ref)
(define (prod-tag grammar prod-name) (list 'bnf-prod (list grammar prod-name)))
(define (prod-ref name) (string-append "‹" name "›"))
(define (prod-link grammar name)
(elemref (prod-tag grammar name) (prod-ref name)))
(define grammar-prod-counts (make-hash))
(define (get-next-grammar-prod-tag grammar prod-name)
(define grammar-prod (hash-ref! grammar-prod-counts grammar make-hash))
(define prod-num (+ 1 (hash-ref grammar-prod prod-name 0)))
(hash-set! grammar-prod prod-name prod-num)
(if (= prod-num 1)
(prod-tag grammar prod-name)
(prod-tag grammar (format "~a@~a" prod-name prod-num))))
(define (render grammar parsed)
(define-values (constants prods) (partition constant? parsed))
(define names (map (λ(c) (list (lhs-id-val (constant-lhs c)) (pattern-lit-val (constant-val c)))) constants))
(define (meta s)
(elem s #:style (make-style #f (list (attributes '((class . "bnf-meta")))))))
(define (phantom s)
(elem "" #:style (make-style #f (list (attributes `((class . "bnf-phantom")
(data-prod . ,s)))))))
(define (lit s)
(elem s #:style (make-style #f (list (attributes '((class . "bnf-lit")))))))
(define (eps)
(elem "ε" #:style (make-style #f (list (attributes '((class . "bnf-eps")))))))
(define (unknown-lit s)
(elem s #:style (make-style #f (list (attributes '((class . "bnf-lit bnf-unknown")))))))
(define rule-name (make-parameter #f))
(define (render-help p #:start [start #f])
(cond
[(pattern-seq? p)
(add-between (map render-help (pattern-seq-vals p)) " ")]
[(pattern-maybe? p)
(list (meta "[") (render-help (pattern-maybe-val p)) (meta "]"))]
[(pattern-repeat? p)
(list (meta "(") (render-help (pattern-repeat-val p)) (meta ")")
(if (= 0 (pattern-repeat-min p)) (meta "*") (meta "+")))]
[(pattern-choice? p)
(define choices (pattern-choice-vals p))
(define pat-breaks
(filter (λ(i) i)
(for/list
([c1 choices] [c2 (rest choices)])
(if (> (pos-line (pattern-start c2)) (pos-line (pattern-start c1))) c2 #f))))
(define breaks
(if (> (pos-line (pattern-start (first choices))) (pos-line (pattern-start p)))
(cons (first choices) pat-breaks)
pat-breaks))
(define indent (list "\n" (phantom (prod-ref (rule-name))) (meta "| ")))
(define translated
(map (λ(c)
(list (if (member c breaks) indent (meta " | "))
(render-help c))) choices))
(if (and start (> (pos-line (pattern-start (first choices))) (pos-line start)))
(cons indent (flatten translated))
(drop (flatten translated) 1))]
[(pattern-token? p)
(define tok (assoc (pattern-token-val p) names))
(cond
[tok (lit (second tok))]
[(string=? (pattern-token-val p) "...") (meta "...")]
[else (unknown-lit (pattern-token-val p))])]
[(pattern-lit? p)
(lit (pattern-lit-val p))]
[(pattern-id? p)
(prod-link grammar (pattern-id-val p))]
[(pattern-epsilon? p)
(eps)]
[else
(printf "Unknown prod: ~a" p)]))
(nested #:style (make-style 'code-inset (list (attributes '((style . "white-space: pre;")))))
(add-between
(for/list [(p prods)]
(parameterize ([rule-name (lhs-id-val (rule-lhs p))])
(list (elemtag (get-next-grammar-prod-tag grammar (rule-name))
(elem (prod-ref (rule-name))
#:style (make-style #f (list (attributes '((class . "bnf-rule")))))))
(meta ":")
" "
(render-help (rule-pattern p) #:start (rule-start p)))))
"\n")
)
)
(define (bnf grammar . stx)
(define text (string-join stx ""))
(define text-port (open-input-string text))
(port-count-lines! text-port)
(define parsed (grammar-parser (tokenize text-port)))
(render grammar parsed)
)