92 行
2.1 KiB
Scheme
92 行
2.1 KiB
Scheme
(define-module (juniority grammar)
|
|
#:use-module (ice-9 peg)
|
|
#:export (import-line
|
|
export-idol-stmt
|
|
export-volume-stmt
|
|
))
|
|
|
|
;; Whitespace
|
|
(define-peg-pattern NL none "\n")
|
|
(define-peg-pattern WS none (+ " "))
|
|
|
|
;; Date
|
|
(define-peg-pattern digit body (range #\0 #\9))
|
|
(define-peg-pattern date all
|
|
(and (+ digit)
|
|
"-"
|
|
(+ digit)
|
|
"-"
|
|
(+ digit)))
|
|
|
|
;; Tags
|
|
(define-peg-pattern tag-chars body
|
|
(and (* (and peg-any (not-followed-by "'")))
|
|
(and peg-any (followed-by "'"))))
|
|
(define-peg-pattern tag-body body
|
|
(and (ignore "'")
|
|
tag-chars
|
|
(ignore "'")))
|
|
(define-peg-pattern tag all
|
|
tag-body)
|
|
(define-peg-pattern untag all
|
|
(and (ignore "!")
|
|
tag-body))
|
|
(define-peg-pattern tags all (* (and WS (or tag untag))))
|
|
|
|
;; Idols
|
|
(define-peg-pattern idol-tag all
|
|
(and (ignore "@")
|
|
tag-body))
|
|
(define-peg-pattern idol-untag all
|
|
(and (ignore "!")
|
|
(ignore "@")
|
|
tag-body))
|
|
(define-peg-pattern idols all (* (and WS (or idol-tag idol-untag))))
|
|
(define-peg-pattern idol-entry all
|
|
(and idol-tag
|
|
tags
|
|
(? (and WS date))))
|
|
|
|
;; Volumes
|
|
(define-peg-pattern caps-alpha body
|
|
(range #\A #\Z))
|
|
(define-peg-pattern volume all
|
|
(and (+ caps-alpha)
|
|
"-"
|
|
(+ digit)
|
|
))
|
|
(define-peg-pattern volume-entry all
|
|
(and volume
|
|
idols
|
|
tags
|
|
(? (and WS date))
|
|
))
|
|
|
|
;; Entry point
|
|
(define-peg-pattern import-line body
|
|
(or idol-entry
|
|
volume-entry
|
|
NL))
|
|
|
|
;; Export procedures
|
|
(define (export-date-expr date)
|
|
(if date
|
|
(format #f " ~a" date)
|
|
""))
|
|
(define (export-idol-expr name)
|
|
(format #f " @'~a'" name))
|
|
(define (export-tag-expr name)
|
|
(format #f " '~a'" name))
|
|
|
|
(define* (export-idol-stmt name tags #:optional born)
|
|
(format #f "@'~a'~a~a"
|
|
name
|
|
(string-concatenate (map export-tag-expr tags))
|
|
(export-date-expr born)))
|
|
(define* (export-volume-stmt identifier idols tags #:optional published)
|
|
(format #f "~a~a~a~a"
|
|
identifier
|
|
(string-concatenate (map export-idol-expr idols))
|
|
(string-concatenate (map export-tag-expr tags))
|
|
(export-date-expr published)))
|