-
Notifications
You must be signed in to change notification settings - Fork 0
/
gqlm.scm
205 lines (173 loc) · 5.75 KB
/
gqlm.scm
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
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
;; gqlm is licensed under the terms of the GNU Affero General Public License, v3.0
;;; Helper macro definitions
(define-macro (->string expr)
`(js-invoke ,expr "toString")) ; Shortcut for JS .toString()
(define-macro (assert expr msg)
`(when (not ,expr)
(print ,msg)
(exit)))
(define-macro (get-cli-arg arg param)
`(let ((subset-args (member ,arg args)))
(when subset-args
(,param (cadr subset-args)))))
;;; Parser combinators
;; Match a given character
(define (char match-char)
(assert (char? match-char) "Error: Character parser must take a character as input")
(lambda (input)
(if (and (< 0 (string-length input)) (equal? (string-ref input 0) match-char))
(cons match-char (substring input 1 (string-length input)))
#f)))
;; Match any character
(define (any)
(lambda (input)
(if (< 0 (string-length input))
(cons (string-ref input 0) (substring input 1 (string-length input)))
#f)))
;; Match any character except for the one given
(define (any-but parser)
(lambda (input)
(if (and (< 0 (string-length input)) (not (parser input)))
(cons (string-ref input 0) (substring input 1 (string-length input)))
#f)))
;; Match a sequence of parsers
(define (seq . parsers)
(define (match-next p result rest)
(let ((parser (list-ref parsers p)))
(if (js-undefined? parser) (cons result rest)
(let ((parse-result (parser rest)))
(if parse-result
(match-next (+ 1 p)
(append result (list (car parse-result)))
(cdr parse-result))
#f)))))
(lambda (input)
(match-next 0 '() input)))
;; Match a parser * times
(define (many parser)
(define (match-next result rest)
(let ((parse-result (parser rest)))
(if parse-result
(match-next (append result (list (car parse-result)))
(cdr parse-result))
(cons result rest))))
(lambda (input)
(match-next '() input)))
;; Match a word
(define (word match-word)
(apply seq (map (lambda (x) (char x)) (string->list match-word))))
;; Match the first of any parsers
(define (either . parsers)
(define (test-parser p input)
(if (null? p) #f
(let ((parser (car p)))
(let ((parse-result (parser input)))
(if parse-result
parse-result
(test-parser (cdr p)
input))))))
(lambda (input)
(test-parser parsers input)))
;; Discard parser result
(define (discard parser)
(lambda (input)
(let ((result (parser input)))
(if result
(cons '() (cdr result))
#f))))
;;; Import filesystem
(define fs (node-require "fs"))
;; Get commandline args
;; We remove the head args, which are always node, biwas, and gqlm.scm
(define args (list-tail (vector->list (js-eval "process.argv")) 3))
;; Print help if called with no args
(define (print-help)
(print "-f <schema file> -o <output file>"))
(when (= 0 (length args))
(print-help)
(exit))
;; Get schema file path, cli -f arg
(define schema-file (make-parameter "schema.graphql"))
(get-cli-arg "-f" schema-file)
;; Exit if the given schema file doesn't exist
(assert (file-exists? (schema-file)) "Error: Schema file does not exist")
;; Get output file path, cli -o arg
(define output-file (make-parameter (schema-file)))
(get-cli-arg "-o" output-file)
;; Get the text of the schema file
(define schema-text (->string (js-invoke fs "readFileSync" (schema-file))))
;; Get enum definitions and bodies
(define match-enum (seq (word "enum")
(many (char #\space))
(many (any-but (char #\space)))
(many (char #\space))
(char #\{)
(many (any-but (char #\})))
(char #\})))
(define match-enums (many (either match-enum (discard (any)))))
(define enums (map (lambda (x)
(fold-left string-append ""
(map (lambda (y) (if (list? y)
(list->string y)
(string y))) x)))
(filter (lambda (x) (not (null? x))) (car (match-enums schema-text)))))
;; This is terrible
(define match-comment-lines (js-new "RegExp" "\\n^\\s*#.*$" "gm"))
(define match-inline-comments (js-new "RegExp" "#.*$" "gm"))
(define (remove-comment-lines input)
(js-invoke
input
"replace"
match-comment-lines
""))
(define (remove-inline-comments input)
(js-invoke
input
"replace"
match-inline-comments
""))
;; List of pairs in form ( enum . enum without comments )
(define enums-with-replacements (map (lambda (x) (cons x (remove-inline-comments (remove-comment-lines x)))) enums))
;; Replace enums with their replacements
(map (lambda (pr)
(set! schema-text
(js-invoke
schema-text
"replace"
(car pr)
(cdr pr))))
enums-with-replacements)
;; Get interface definitions and their bodies
(define interface-header (seq (word "interface")
(many (char #\space))
(many (any-but (char #\space)))
(many (char #\space))
(char #\{)))
(define (match-interface-header input)
(let ((parse-result (interface-header input)))
(if parse-result
(cons (list->string (list-ref (car parse-result) 2)) (cdr parse-result))
#f)))
(define type-body (many (any-but (char #\}))))
(define (match-type-body input)
(let ((parse-result (type-body input)))
(if parse-result
(cons (list->string (car parse-result)) (cdr parse-result))
#f)))
(define match-interface (seq match-interface-header match-type-body))
(define match-interfaces (many (either match-interface (discard (any)))))
;; This is an alist of every interface definition
(define interfaces (filter (lambda (x) (not (null? x))) (car (match-interfaces schema-text))))
;; Replace expansions
(map (lambda (obj)
(let ((body-segment (js-invoke ;; This is a bit crap, it doesn't handle indentation correctly
(car (cdr obj))
"trim")))
(set! schema-text
(regexp-replace-all
(string->regexp (format "[\ \t]...~a" (car obj)))
schema-text
body-segment))))
interfaces)
;; Write to a file
(js-invoke fs "writeFileSync" (output-file) schema-text)