readit

  1(module (readit parser)
  2  (make-meta meta-state meta-key meta-title parse-fields
  3   parse-readit readit-ref? readit-set? parse-indent parse-note parse-notes)
  4  (import scheme (chicken base) comparse srfi-1 srfi-14)
  5
  6  (define-record-type metadata
  7    (make-meta state key title)
  8    metadata?
  9    (state meta-state)
 10    (key meta-key)
 11    (title meta-title))
 12
 13  (define-record-printer (metadata input port)
 14    (define (join . strings)
 15      (fold (lambda (str output)
 16              (string-append
 17                (if (zero? (string-length output))
 18                  output
 19                  (string-append output " ")) str)) "" strings))
 20
 21    (display (join
 22               (string (meta-state input))
 23               (string-append "[" (symbol->string (meta-key input)) "]:")
 24               (meta-title input))))
 25
 26  (define symbol-charset
 27    (char-set-union
 28      char-set:letter
 29      char-set:digit
 30      (->char-set "!$%&*+-./:<=>?@^_~")))
 31
 32  (define symbol-charset-start
 33    (char-set-difference symbol-charset char-set:digit))
 34
 35  ;;;;
 36  ;; Utility functions
 37  ;;;;
 38
 39  (define parse-symbol
 40    (bind (as-string (all-of
 41                       (in symbol-charset-start)
 42                       (zero-or-more (in symbol-charset))))
 43          (lambda (str) (result (string->symbol str)))))
 44
 45  (define (parse-any-except char . chars)
 46    (as-string (one-or-more
 47      (in (char-set-complement (list->char-set
 48                                  (cons char chars)))))))
 49
 50  (define parse-indent
 51    (any-of
 52      (is #\tab)
 53      (repeated (is #\space) min: 4 max: 4)))
 54
 55  (define parse-blanks
 56    (zero-or-more (in char-set:blank)))
 57
 58  (define parse-text
 59    (parse-any-except #\newline))
 60
 61  ;;;;
 62  ;; Parser for literals
 63  ;;;;
 64
 65  (define (parse-escaped ctrl-chars)
 66    (define parse-char
 67      (any-of
 68        (sequence* ((_ (is #\\))
 69                    (i item))
 70          (result i))
 71        (in (char-set-complement (list->char-set ctrl-chars)))))
 72
 73    (as-string (one-or-more parse-char)))
 74
 75  (define (parse-vector parser)
 76    (define (parse-vector*)
 77      (one-or-more
 78        (sequence* ((elem parser)
 79                    (_    (maybe (is #\,)))
 80                    (_    parse-blanks))
 81          (result elem))))
 82
 83    (bind (parse-vector*)
 84          (lambda (lst)
 85            (result (list->vector lst)))))
 86
 87  (define parse-set
 88    (enclosed-by (is #\{)
 89                 (parse-vector (parse-escaped '(#\, #\})))
 90                 (is #\})))
 91
 92  (define parse-ref
 93    (enclosed-by (is #\[)
 94                 (parse-vector parse-symbol)
 95                 (is #\])))
 96
 97  ;;;;
 98  ;; Parsers for entry parts
 99  ;;;;
100
101  (define parse-state
102    (in (string->char-set "-x")))
103
104  (define parse-key
105    (enclosed-by (is #\[) parse-symbol (is #\])))
106
107  (define parse-title
108    parse-text)
109
110  ;;;;
111  ;; Parsers for optional field values
112  ;;;;
113
114  (define parse-field-name
115    (parse-any-except #\:))
116
117  (define parse-field-value
118    (any-of
119      parse-set
120      parse-ref
121      parse-text))
122
123  (define parse-field
124    (sequence* ((_     parse-indent)
125                (_     (is #\*))
126                (_     parse-blanks)
127                (name  parse-field-name)
128                (_     (is #\:))
129                (_     parse-blanks)
130                (value parse-field-value)
131                (_     parse-blanks)
132                (_     (is #\newline)))
133      (result (cons name value))))
134
135  (define parse-fields
136    (zero-or-more parse-field))
137
138  ;;;;
139  ;; Parser for optional notes
140  ;;;;
141
142  (define parse-note
143    (sequence* ((_    parse-indent)
144                (text parse-text)
145                (_    (one-or-more (is #\newline))))
146      (result (string-append text "\n"))))
147
148  (define parse-notes
149    (as-string (zero-or-more parse-note)))
150
151  ;;;;
152  ;; Combine utility parsers
153  ;;;;
154
155  (define parse-info
156    (sequence* ((fields (maybe parse-fields '()))
157                (notes  (maybe (preceded-by
158                                 (is #\newline)
159                                 parse-notes) "")))
160      (result (list fields notes))))
161
162  (define parse-entry
163    (sequence* ((state  parse-state)
164                (_      parse-blanks)
165                (key    parse-key)
166                (_      (is #\:))
167                (_      parse-blanks)
168                (title  parse-title)
169                (_      (is #\newline))
170                (info   (maybe parse-info (list '() '()))))
171      (result (cons (make-meta state key title) info))))
172
173  (define parse-entries
174    (one-or-more (preceded-by
175                   (zero-or-more (in char-set:whitespace))
176                   parse-entry)))
177
178  ;;;;
179  ;; Interface functions
180  ;;;;
181
182  (define (readit-ref? obj)
183    (and (vector? obj)
184         (>= (vector-length obj) 1)
185         (every symbol? (vector->list obj))))
186
187  (define (readit-set? obj)
188    (and (vector? obj)
189         (>= (vector-length obj) 1)
190         (every string? (vector->list obj))))
191
192  (define (parse-readit input)
193    (parse (sequence* ((r parse-entries)
194                       (_ end-of-input))
195           (result r)) input)))