extra/bare/bare.factor

   1 ! Copyright (C) 2022 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   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 ;
   9
  10 IN: bare
  11
  12 ! types
  13
  14 SINGLETONS: uint ;
  15 SINGLETONS: int ;
  16 SINGLETONS: u8 u16 u32 u64 ;
  17 SINGLETONS: i8 i16 i32 i64 ;
  18 SINGLETONS: f32 f64 ;
  19 SINGLETONS: bool ;
  20 SINGLETONS: str ;
  21 TUPLE: data length ;
  22 SINGLETONS: void ;
  23 TUPLE: enum values ;
  24 TUPLE: optional type ;
  25 TUPLE: list type length ;
  26 TUPLE: map from to ;
  27 TUPLE: union members ;
  28 TUPLE: struct fields ;
  29 TUPLE: schema types ;
  30
  31 ! errors
  32
  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 ;
  41
  42 <PRIVATE
  43
  44 : check-length ( length/f -- length/f )
  45     dup [ 1 64 on-bits between? [ invalid-length ] unless ] when* ;
  46
  47 : check-duplicate-keys ( alist -- alist )
  48     dup keys duplicates [ duplicate-keys ] unless-empty ;
  49
  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 ;
  54
  55 : check-duplicates ( alist -- alist )
  56     check-duplicate-keys check-duplicate-values ;
  57
  58 : assign-values ( alist -- alist' )
  59     0 swap [ rot or dup 1 + -rot ] assoc-map nip ;
  60
  61 : check-entries ( alist -- alist )
  62     dup assoc-empty? [ not-enough-entries ] when ;
  63
  64 : check-void ( type -- type )
  65     dup void? [ cannot-be-void ] when ;
  66
  67 PRIVATE>
  68
  69 ! constructors
  70
  71 : <data> ( length -- data )
  72     check-length data boa ;
  73
  74 : <enum> ( values -- enum )
  75     assign-values check-duplicates check-entries enum boa ;
  76
  77 : <optional> ( type -- optional )
  78     check-void optional boa ;
  79
  80 : <list> ( type length -- list )
  81     [ check-void ] [ check-length ] bi* list boa ;
  82
  83 : <map> ( from to -- map )
  84     ! XXX: check key types?
  85     [ check-void ] bi@ map boa ;
  86
  87 : <union> ( members -- union )
  88     assign-values check-duplicates check-entries union boa ;
  89
  90 : <struct> ( fields -- struct )
  91     check-duplicate-keys check-entries
  92     dup [ check-void 2drop ] assoc-each struct boa ;
  93
  94 : <schema> ( types -- schema )
  95     check-entries schema boa ;
  96
  97 ! main interface
  98
  99 GENERIC: read-bare ( schema -- obj )
 100
 101 GENERIC: write-bare ( obj schema -- )
 102
 103 : bare> ( encoded schema -- obj )
 104     swap binary [ read-bare ] with-byte-reader ;
 105
 106 : >bare ( obj schema -- encoded )
 107     binary [ write-bare ] with-byte-writer ;
 108
 109 ! writing implementation
 110
 111 M: uint write-bare
 112     drop [ dup 0x80 >= ] [
 113         [ 0x7f bitand 0x80 bitor write1 ] [ -7 shift ] bi
 114     ] while write1 ;
 115
 116 M: int write-bare
 117     drop 2 * dup 0 < [ neg 1 - ] when uint write-bare ;
 118
 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 ;
 123
 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 ;
 128
 129 M: f32 write-bare drop float>bits u32 write-bare ;
 130 M: f64 write-bare drop double>bits u64 write-bare ;
 131
 132 M: bool write-bare drop >boolean 1 0 ? u8 write-bare ;
 133
 134 M: str write-bare drop utf8 encode T{ data } write-bare ;
 135
 136 M: data write-bare
 137     length>> [ dup length uint write-bare ] unless write ;
 138
 139 M: void write-bare 2drop ;
 140
 141 M: enum write-bare
 142     values>> ?at [ uint write-bare ] [ invalid-enum ] if ;
 143
 144 M: optional write-bare
 145     over 1 0 ? u8 write-bare
 146     '[ _ type>> write-bare ] when* ;
 147
 148 M: list write-bare
 149     [ length>> [ dup length uint write-bare ] unless ]
 150     [ type>> '[ _ write-bare ] each ] bi ;
 151
 152 M: map write-bare
 153     over assoc-size uint write-bare
 154     [ from>> ] [ to>> ] bi [ write-bare ] bi-curry@
 155     '[ _ _ bi* ] assoc-each ;
 156
 157 ! XXX: M: union write-bare
 158
 159 M: struct write-bare
 160     fields>> [ [ dupd of ] [ write-bare ] bi* ] assoc-each drop ;
 161
 162 ! reading implementation
 163
 164 M: uint read-bare
 165     drop 0 0 [
 166         read1
 167         [ 0x7f bitand rot [ 7 * shift bitor ] keep 1 + swap ]
 168         [ 0x80 bitand zero? not ] bi
 169     ] loop nip ;
 170
 171 M: int read-bare
 172     drop uint read-bare dup odd? [ 1 + neg ] when 2 /i ;
 173
 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> ;
 178
 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> ;
 183
 184 M: f32 read-bare drop 4 read le> bits>float ;
 185 M: f64 read-bare drop 8 read le> bits>double ;
 186
 187 M: bool read-bare
 188     drop read1 {
 189         { 0 [ f ] }
 190         { 1 [ t ] }
 191         [ throw ]
 192     } case ;
 193
 194 M: str read-bare drop T{ data } read-bare utf8 decode ;
 195
 196 M: data read-bare
 197     length>> [ read ] [ uint read-bare read ] if* ;
 198
 199 M: void read-bare drop f ; ! XXX: this isn't right
 200
 201 M: enum read-bare
 202     [ uint read-bare ] dip values>> ?value-at
 203     [ invalid-enum ] unless ;
 204
 205 M: optional read-bare
 206     u8 read-bare 1 = [ type>> read-bare ] [ drop f ] if ;
 207
 208 M: list read-bare
 209     [ length>> [ uint read-bare ] unless* ]
 210     [ type>> '[ _ read-bare ] replicate ] bi ;
 211
 212 M: map read-bare
 213     [ uint read-bare ] dip [ from>> ] [ to>> ] bi
 214     '[ _ _ [ read-bare ] bi@ 2array ] replicate ;
 215
 216 M: union read-bare
 217     [ uint read-bare ] dip members>> ?value-at
 218     [ read-bare ] [ invalid-union ] if ;
 219
 220 M: struct read-bare
 221     fields>> [ read-bare ] assoc-map ;
 222
 223 ! schema
 224
 225 <PRIVATE
 226
 227 SYMBOL: user-types
 228
 229 : lookup-user-type ( name -- type )
 230     user-types get ?at [ unknown-type ] unless ;
 231
 232 : insert-user-type ( name type -- )
 233     swap user-types [ ?set-at ] change ;
 234
 235 EBNF: (parse-schema) [=[
 236
 237 space     = [ \t\n]
 238 comment   = "#" [^\n]* "\n"?
 239 ws        = ((space | comment)*)~
 240 upper     = [A-Z]
 241 alpha     = [A-Za-z]
 242 digit     = [0-9]
 243 number    = digit+                         => [[ string>number ]]
 244
 245 length    = ws "["~ ws number ws "]"~
 246 value     = ws "="~ ws number
 247
 248 type      = ws "<"~ ws any-type ws ">"~
 249
 250 uint      = "uint"                         => [[ uint ]]
 251 u8        = "u8"                           => [[ u8 ]]
 252 u16       = "u16"                          => [[ u16 ]]
 253 u32       = "u32"                          => [[ u32 ]]
 254 u64       = "u64"                          => [[ u64 ]]
 255
 256 int       = "int"                          => [[ int ]]
 257 i8        = "i8"                           => [[ i8 ]]
 258 i16       = "i16"                          => [[ i16 ]]
 259 i32       = "i32"                          => [[ i32 ]]
 260 i64       = "i64"                          => [[ i64 ]]
 261
 262 f32       = "f32"                          => [[ f32 ]]
 263 f64       = "f64"                          => [[ f64 ]]
 264
 265 bool      = "bool"                         => [[ bool ]]
 266 str       = "str"                          => [[ str ]]
 267 data      = "data"~ length?                => [[ <data> ]]
 268 void      = "void"                         => [[ void ]]
 269
 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> ]]
 274
 275 uints     = uint|u8|u16|u32|u64
 276 ints      = int|i8|i16|i32|i64
 277 floats    = f32|f64
 278 primitive = uints|ints|floats|bool|str|data|void|enum
 279
 280 optional  = "optional"~ type               => [[ <optional> ]]
 281 list      = "list"~ type length?           => [[ first2 <list> ]]
 282 map       = "map"~ type type               => [[ first2 <map> ]]
 283
 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> ]]
 288
 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> ]]
 292
 293 aggregate = optional|list|map|struct|union
 294
 295 defined   = user-type-name => [[ lookup-user-type ]]
 296
 297 any-type  = aggregate|primitive|defined
 298
 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 ]]
 302
 303 schema = (ws user-type ws)* => [[ <schema> ]]
 304
 305 ]=]
 306
 307 PRIVATE>
 308
 309 : parse-schema ( string -- schema )
 310     H{ } clone user-types [ (parse-schema) ] with-variable ;
 311
 312 : load-schema ( path -- schema )
 313     utf8 file-contents parse-schema ;
 314
 315 : define-schema ( schema -- )
 316     ! XXX: define user types as tuples with bare-fields word-prop?
 317     types>> [
 318         [ create-word-in dup reset-generic ]
 319         [ define-constant ] bi*
 320     ] assoc-each ;
 321
 322 SYNTAX: SCHEMA: scan-object parse-schema define-schema ;