1 ! Copyright (C) 2022 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
4 USING: accessors arrays assocs combinators endian hashtables io
5 io.encodings.binary io.encodings.string io.encodings.utf8
6 io.files io.streams.byte-array kernel math math.bitwise
7 math.order math.parser multiline namespaces parser peg.ebnf
8 sequences sets strings words words.constant ;
16 SINGLETONS: u8 u16 u32 u64 ;
17 SINGLETONS: i8 i16 i32 i64 ;
24 TUPLE: optional type ;
25 TUPLE: list type length ;
27 TUPLE: union members ;
28 TUPLE: struct fields ;
33 ERROR: invalid-length length ;
34 ERROR: invalid-enum value ;
35 ERROR: invalid-union value ;
36 ERROR: unknown-type name ;
37 ERROR: duplicate-keys keys ;
38 ERROR: duplicate-values values ;
39 ERROR: not-enough-entries ;
40 ERROR: cannot-be-void type ;
44 : check-length ( length/f -- length/f )
45 dup [ 1 64 on-bits between? [ invalid-length ] unless ] when* ;
47 : check-duplicate-keys ( alist -- alist )
48 dup keys duplicates [ duplicate-keys ] unless-empty ;
50 : check-duplicate-values ( alist -- alist )
51 dup H{ } clone [ '[ _ push-at ] assoc-each ] keep
52 [ nip length 1 > ] { } assoc-filter-as
53 [ duplicate-values ] unless-empty ;
55 : check-duplicates ( alist -- alist )
56 check-duplicate-keys check-duplicate-values ;
58 : assign-values ( alist -- alist' )
59 0 swap [ rot or dup 1 + -rot ] assoc-map nip ;
61 : check-entries ( alist -- alist )
62 dup assoc-empty? [ not-enough-entries ] when ;
64 : check-void ( type -- type )
65 dup void? [ cannot-be-void ] when ;
71 : <data> ( length -- data )
72 check-length data boa ;
74 : <enum> ( values -- enum )
75 assign-values check-duplicates check-entries enum boa ;
77 : <optional> ( type -- optional )
78 check-void optional boa ;
80 : <list> ( type length -- list )
81 [ check-void ] [ check-length ] bi* list boa ;
83 : <map> ( from to -- map )
84 ! XXX: check key types?
85 [ check-void ] bi@ map boa ;
87 : <union> ( members -- union )
88 assign-values check-duplicates check-entries union boa ;
90 : <struct> ( fields -- struct )
91 check-duplicate-keys check-entries
92 dup [ check-void 2drop ] assoc-each struct boa ;
94 : <schema> ( types -- schema )
95 check-entries schema boa ;
99 GENERIC: read-bare ( schema -- obj )
101 GENERIC: write-bare ( obj schema -- )
103 : bare> ( encoded schema -- obj )
104 swap binary [ read-bare ] with-byte-reader ;
106 : >bare ( obj schema -- encoded )
107 binary [ write-bare ] with-byte-writer ;
109 ! writing implementation
112 drop [ dup 0x80 >= ] [
113 [ 0x7f bitand 0x80 bitor write1 ] [ -7 shift ] bi
117 drop 2 * dup 0 < [ neg 1 - ] when uint write-bare ;
119 M: u8 write-bare drop write1 ;
120 M: u16 write-bare drop 2 >le write ;
121 M: u32 write-bare drop 4 >le write ;
122 M: u64 write-bare drop 8 >le write ;
124 M: i8 write-bare drop 1 >le write ;
125 M: i16 write-bare drop 2 >le write ;
126 M: i32 write-bare drop 4 >le write ;
127 M: i64 write-bare drop 8 >le write ;
129 M: f32 write-bare drop float>bits u32 write-bare ;
130 M: f64 write-bare drop double>bits u64 write-bare ;
132 M: bool write-bare drop >boolean 1 0 ? u8 write-bare ;
134 M: str write-bare drop utf8 encode T{ data } write-bare ;
137 length>> [ dup length uint write-bare ] unless write ;
139 M: void write-bare 2drop ;
142 values>> ?at [ uint write-bare ] [ invalid-enum ] if ;
144 M: optional write-bare
145 over 1 0 ? u8 write-bare
146 '[ _ type>> write-bare ] when* ;
149 [ length>> [ dup length uint write-bare ] unless ]
150 [ type>> '[ _ write-bare ] each ] bi ;
153 over assoc-size uint write-bare
154 [ from>> ] [ to>> ] bi [ write-bare ] bi-curry@
155 '[ _ _ bi* ] assoc-each ;
157 ! XXX: M: union write-bare
160 fields>> [ [ dupd of ] [ write-bare ] bi* ] assoc-each drop ;
162 ! reading implementation
167 [ 0x7f bitand rot [ 7 * shift bitor ] keep 1 + swap ]
168 [ 0x80 bitand zero? not ] bi
172 drop uint read-bare dup odd? [ 1 + neg ] when 2 /i ;
174 M: u8 read-bare drop read1 ;
175 M: u16 read-bare drop 2 read le> ;
176 M: u32 read-bare drop 4 read le> ;
177 M: u64 read-bare drop 8 read le> ;
179 M: i8 read-bare drop 1 read signed-le> ;
180 M: i16 read-bare drop 2 read signed-le> ;
181 M: i32 read-bare drop 4 read signed-le> ;
182 M: i64 read-bare drop 8 read signed-le> ;
184 M: f32 read-bare drop 4 read le> bits>float ;
185 M: f64 read-bare drop 8 read le> bits>double ;
194 M: str read-bare drop T{ data } read-bare utf8 decode ;
197 length>> [ read ] [ uint read-bare read ] if* ;
199 M: void read-bare drop f ; ! XXX: this isn't right
202 [ uint read-bare ] dip values>> ?value-at
203 [ invalid-enum ] unless ;
205 M: optional read-bare
206 u8 read-bare 1 = [ type>> read-bare ] [ drop f ] if ;
209 [ length>> [ uint read-bare ] unless* ]
210 [ type>> '[ _ read-bare ] replicate ] bi ;
213 [ uint read-bare ] dip [ from>> ] [ to>> ] bi
214 '[ _ _ [ read-bare ] bi@ 2array ] replicate ;
217 [ uint read-bare ] dip members>> ?value-at
218 [ read-bare ] [ invalid-union ] if ;
221 fields>> [ read-bare ] assoc-map ;
229 : lookup-user-type ( name -- type )
230 user-types get ?at [ unknown-type ] unless ;
232 : insert-user-type ( name type -- )
233 swap user-types [ ?set-at ] change ;
235 EBNF: (parse-schema) [=[
238 comment = "#" [^\n]* "\n"?
239 ws = ((space | comment)*)~
243 number = digit+ => [[ string>number ]]
245 length = ws "["~ ws number ws "]"~
246 value = ws "="~ ws number
248 type = ws "<"~ ws any-type ws ">"~
250 uint = "uint" => [[ uint ]]
251 u8 = "u8" => [[ u8 ]]
252 u16 = "u16" => [[ u16 ]]
253 u32 = "u32" => [[ u32 ]]
254 u64 = "u64" => [[ u64 ]]
256 int = "int" => [[ int ]]
257 i8 = "i8" => [[ i8 ]]
258 i16 = "i16" => [[ i16 ]]
259 i32 = "i32" => [[ i32 ]]
260 i64 = "i64" => [[ i64 ]]
262 f32 = "f32" => [[ f32 ]]
263 f64 = "f64" => [[ f64 ]]
265 bool = "bool" => [[ bool ]]
266 str = "str" => [[ str ]]
267 data = "data"~ length? => [[ <data> ]]
268 void = "void" => [[ void ]]
270 enum-value-name = upper (upper|digit|[_])* => [[ first2 swap prefix >string ]]
271 enum-value = enum-value-name value? => [[ >array ]]
272 enum-values = (ws enum-value ws)*
273 enum = "enum"~ ws "{"~ ws enum-values ws "}"~ => [[ <enum> ]]
275 uints = uint|u8|u16|u32|u64
276 ints = int|i8|i16|i32|i64
278 primitive = uints|ints|floats|bool|str|data|void|enum
280 optional = "optional"~ type => [[ <optional> ]]
281 list = "list"~ type length? => [[ first2 <list> ]]
282 map = "map"~ type type => [[ first2 <map> ]]
284 struct-field-name = alpha+ => [[ >string ]]
285 struct-field = struct-field-name ws ":"~ ws any-type => [[ >array ]]
286 struct-fields = (ws struct-field ws)*
287 struct = "struct"~ ws "{"~ ws struct-fields ws "}"~ => [[ <struct> ]]
289 union-member = any-type value? => [[ >array ]]
290 union-members = union-member (ws "|"~ ws union-member)* => [[ first2 swap prefix ]]
291 union = "union"~ ws "{"~ ws ("|"?)~ ws union-members? ws ("|"?)~ ws "}"~ => [[ <union> ]]
293 aggregate = optional|list|map|struct|union
295 defined = user-type-name => [[ lookup-user-type ]]
297 any-type = aggregate|primitive|defined
299 user-type-name = (alpha|digit)+ => [[ >string ]]
300 user-type = "type"~ ws user-type-name ws any-type
301 => [[ first2 [ insert-user-type ] [ 2array ] 2bi ]]
303 schema = (ws user-type ws)* => [[ <schema> ]]
309 : parse-schema ( string -- schema )
310 H{ } clone user-types [ (parse-schema) ] with-variable ;
312 : load-schema ( path -- schema )
313 utf8 file-contents parse-schema ;
315 : define-schema ( schema -- )
316 ! XXX: define user types as tuples with bare-fields word-prop?
318 [ create-word-in dup reset-generic ]
319 [ define-constant ] bi*
322 SYNTAX: SCHEMA: scan-object parse-schema define-schema ;