extra/yaml/yaml.factor

   1 ! Copyright (C) 2013 Jon Harper.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.data arrays assocs byte-arrays
   4 classes.struct combinators combinators.extras
   5 combinators.short-circuit destructors fry generalizations
   6 hashtables hashtables.identity io.encodings.string
   7 io.encodings.utf8 kernel libc linked-assocs make math
   8 math.parser namespaces sequences sets strings yaml.config
   9 yaml.conversion yaml.ffi hash-sets.identity ;
  10 IN: yaml
  11
  12 ERROR: libyaml-parser-error
  13     error problem problem_offset
  14     problem_value problem_mark context context_mark ;
  15 ERROR: libyaml-initialize-error ;
  16 ERROR: libyaml-emitter-error error problem ;
  17
  18 ERROR: yaml-undefined-anchor anchor anchors ;
  19 ERROR: yaml-unexpected-event actual expected ;
  20 ERROR: yaml-no-document ;
  21
  22 <PRIVATE
  23
  24 : yaml-initialize-assert-ok ( ? -- )
  25     [ libyaml-initialize-error ] unless ;
  26
  27 : (libyaml-parser-error) ( parser -- )
  28     {
  29         [ error>> ]
  30         [ problem>> ]
  31         [ problem_offset>> ]
  32         [ problem_value>> ]
  33         [ problem_mark>> ]
  34         [ context>> ]
  35         [ context_mark>> ]
  36     } cleave [ clone ] 7 napply libyaml-parser-error ;
  37
  38 : (libyaml-emitter-error) ( emitter -- )
  39     [ error>> ] [ problem>> ] bi [ clone ] bi@ libyaml-emitter-error ;
  40
  41 : yaml-parser-assert-ok ( ? parser -- )
  42     swap [ drop ] [ (libyaml-parser-error) ] if ;
  43
  44 : yaml-emitter-assert-ok ( ? emitter -- )
  45     swap [ drop ] [ (libyaml-emitter-error) ] if ;
  46
  47 : yaml_parser_parse_asserted ( parser event -- )
  48     [ yaml_parser_parse ] [ drop yaml-parser-assert-ok ] 2bi ;
  49
  50 : yaml_emitter_emit_asserted ( emitter event -- )
  51     [ yaml_emitter_emit ] [ drop yaml-emitter-assert-ok ] 2bi ;
  52
  53 TUPLE: yaml-alias anchor ;
  54 C: <yaml-alias> yaml-alias
  55
  56 SYMBOL: anchors
  57
  58 : ?register-anchor ( obj event -- obj )
  59     dupd anchor>> [ anchors get set-at ] [ drop ] if* ;
  60
  61 : assert-anchor-exists ( anchor -- )
  62     anchors get 2dup at* nip
  63     [ 2drop ] [ yaml-undefined-anchor ] if ;
  64
  65 : deref-anchor ( event -- obj )
  66     data>> alias>> anchor>>
  67     [ assert-anchor-exists ]
  68     [ <yaml-alias> ] bi ;
  69
  70 : event>scalar ( mapping-key? event -- obj )
  71     data>> scalar>>
  72     [ swap construct-scalar ]
  73     [ ?register-anchor ] bi ;
  74
  75 ! TODO simplify this ?!?
  76 TUPLE: factor_sequence_start_event_data anchor tag implicit style ;
  77 TUPLE: factor_mapping_start_event_data anchor tag implicit style ;
  78 TUPLE: factor_event_data sequence_start mapping_start ;
  79 TUPLE: factor_yaml_event_t type data start_mark end_mark ;
  80
  81 : deep-copy-seq ( data -- data' )
  82     {
  83         [ anchor>> clone ]
  84         [ tag>> clone ]
  85         [ implicit>> ]
  86         [ style>> ]
  87     } cleave factor_sequence_start_event_data boa ;
  88
  89 : deep-copy-map ( data -- data' )
  90     {
  91         [ anchor>> clone ]
  92         [ tag>> clone ]
  93         [ implicit>> ]
  94         [ style>> ]
  95     } cleave factor_mapping_start_event_data boa ;
  96
  97 : deep-copy-data ( event -- data )
  98     [ data>> ] [ type>> ] bi {
  99         { YAML_SEQUENCE_START_EVENT [ sequence_start>> deep-copy-seq f ] }
 100         { YAML_MAPPING_START_EVENT [ mapping_start>> deep-copy-map f swap ] }
 101     } case factor_event_data boa ;
 102
 103 : deep-copy-event ( event -- event' )
 104     {
 105         [ type>> ]
 106         [ deep-copy-data ]
 107         [ start_mark>> ]
 108         [ end_mark>> ]
 109     } cleave factor_yaml_event_t boa ;
 110
 111 : (?scalar-value) ( mapping-key? event -- scalar/event scalar? )
 112     dup type>> {
 113         { YAML_SCALAR_EVENT [ event>scalar t ] }
 114         { YAML_ALIAS_EVENT [ nip deref-anchor t ] }
 115         [ drop nip deep-copy-event f ]
 116     } case ;
 117 : ?mapping-key-scalar-value ( event -- scalar/event scalar? ) t swap (?scalar-value) ;
 118 : ?scalar-value ( event -- scalar/event scalar? ) f swap (?scalar-value) ;
 119
 120 ! Must not reuse the event struct before with-destructors scope ends
 121 : next-event ( parser event -- event )
 122     [ yaml_parser_parse_asserted ] [ &yaml_event_delete ] bi ;
 123
 124 DEFER: parse-sequence
 125 DEFER: parse-mapping
 126
 127 : (parse-sequence) ( parser event prev-event -- obj )
 128     data>> sequence_start>> [ [ 2drop f ] dip ?register-anchor drop ]
 129     [ [ parse-sequence ] [ construct-sequence ] bi* ] [ 2nip ?register-anchor ] 3tri ;
 130
 131 : (parse-mapping) ( parser event prev-event -- obj )
 132     data>> mapping_start>> [ [ 2drop f ] dip ?register-anchor drop ]
 133     [ [ parse-mapping ] [ construct-mapping ] bi* ] [ 2nip ?register-anchor ] 3tri ;
 134
 135 : next-complex-value ( parser event prev-event -- obj )
 136     dup type>> {
 137         { YAML_SEQUENCE_START_EVENT [ (parse-sequence) ] }
 138         { YAML_MAPPING_START_EVENT [ (parse-mapping) ] }
 139     } case ;
 140
 141 :: next-value ( parser event -- obj )
 142     parser event [ next-event ?scalar-value ] with-destructors
 143     [ [ parser event ] dip next-complex-value ] unless ;
 144
 145 :: parse-mapping ( parser event -- map )
 146     [
 147         f :> done!
 148         [ done ] [
 149             [
 150                 parser event next-event type>>
 151                 YAML_MAPPING_END_EVENT = [
 152                     t done! f f
 153                 ] [
 154                     event ?mapping-key-scalar-value
 155                 ] if
 156             ] with-destructors
 157             done [ 2drop ] [
 158                 [ [ parser event ] dip next-complex-value ] unless
 159                 parser event next-value swap ,,
 160             ] if
 161         ] until
 162     ] H{ } make ;
 163
 164 :: parse-sequence ( parser event  -- seq )
 165     [
 166         f :> done!
 167         [ done ] [
 168             [
 169                 parser event next-event type>>
 170                 YAML_SEQUENCE_END_EVENT = [
 171                     t done! f f
 172                 ] [
 173                     event ?scalar-value
 174                 ] if
 175             ] with-destructors
 176             done [ 2drop ] [
 177               [ [ parser event ] dip next-complex-value ] unless ,
 178             ] if
 179         ] until
 180     ] { } make ;
 181
 182 : expect-event ( parser event type -- )
 183     [
 184         [ next-event type>> ] dip 2dup =
 185         [ 2drop ] [ 1array yaml-unexpected-event ] if
 186     ] with-destructors ;
 187
 188 GENERIC: (deref-aliases) ( anchors obj -- obj' )
 189
 190 M: object (deref-aliases) nip ;
 191
 192 M: byte-array (deref-aliases) nip ;
 193
 194 M: string (deref-aliases) nip ;
 195
 196 M: yaml-alias (deref-aliases) anchor>> of ;
 197
 198 M: sequence (deref-aliases)
 199     [ (deref-aliases) ] with map! ;
 200
 201 M: sets:set (deref-aliases)
 202     [ members (deref-aliases) ] [ clear-set ] [ swap union! ] tri ;
 203
 204 : assoc-map! ( assoc quot -- assoc' )
 205     [ assoc-map ] [ drop clear-assoc ] [ drop swap assoc-union! ] 2tri ; inline
 206
 207 M: assoc (deref-aliases)
 208      [ [ (deref-aliases) ] bi-curry@ bi ] withd assoc-map! ;
 209
 210 : merge-values ( seq -- assoc )
 211     reverse [ ] [ assoc-union ] map-reduce ;
 212 GENERIC: merge-value ( assoc value -- assoc' )
 213 M: sequence merge-value merge-values merge-value ;
 214 M: assoc merge-value over assoc-diff assoc-union! ;
 215 : pop-at* ( key assoc -- value/f ? )
 216     [ at* ] 2keep pick [ delete-at ] [ 2drop ] if ;
 217
 218 : ?apply-default-key ( assoc -- obj' )
 219     T{ yaml-value } over pop-at* [ nip ] [ drop ] if ;
 220 PRIVATE>
 221
 222 : ?apply-merge-key ( assoc -- assoc' )
 223     T{ yaml-merge } over pop-at*
 224     [ merge-value ] [ drop ] if ;
 225 : scalar-value ( obj -- obj' )
 226     dup hashtable? [ ?apply-default-key ] when ;
 227
 228 <PRIVATE
 229
 230 GENERIC: apply-merge-keys ( already-applied-set obj -- obj' )
 231 : ?apply-merge-keys ( set obj -- obj' )
 232     2dup swap ?adjoin [ apply-merge-keys ] [ nip ] if ;
 233 M: sequence apply-merge-keys
 234     [ ?apply-merge-keys ] with map! ;
 235 M: object apply-merge-keys nip ;
 236 M: byte-array apply-merge-keys nip ;
 237 M: string apply-merge-keys nip ;
 238 M: assoc apply-merge-keys
 239     [ [ ?apply-merge-keys ] bi-curry@ bi ] withd assoc-map!
 240     merge get [ ?apply-merge-key ] when
 241     value get [ ?apply-default-key ] when ;
 242
 243 :: parse-yaml-doc ( parser event -- obj )
 244     H{ } clone anchors [
 245         parser event next-value
 246         anchors get swap (deref-aliases)
 247         merge get value get or [ IHS{ } clone swap ?apply-merge-keys ] when
 248     ] with-variable ;
 249
 250 :: ?parse-yaml-doc ( parser event -- obj/f ? )
 251     [
 252         parser event next-event type>> {
 253             { YAML_DOCUMENT_START_EVENT [ t ] }
 254             { YAML_STREAM_END_EVENT [ f ] }
 255             [ { YAML_DOCUMENT_START_EVENT YAML_STREAM_END_EVENT } yaml-unexpected-event ]
 256         } case
 257     ] with-destructors [
 258         parser event parse-yaml-doc t
 259         parser event YAML_DOCUMENT_END_EVENT expect-event
 260     ] [ f f ] if ;
 261
 262 ! registers destructors (use with with-destructors)
 263 :: init-parser ( str -- parser event )
 264     yaml_parser_t (malloc-struct) &free :> parser
 265     parser yaml_parser_initialize yaml-initialize-assert-ok
 266     parser &yaml_parser_delete drop
 267
 268     str utf8 encode
 269     [ malloc-byte-array &free ] [ length ] bi :> ( input length )
 270     parser input length yaml_parser_set_input_string
 271
 272     yaml_event_t (malloc-struct) &free :> event
 273     parser event ;
 274
 275 PRIVATE>
 276
 277 : yaml> ( str -- obj )
 278     [
 279         init-parser
 280         [ YAML_STREAM_START_EVENT expect-event ]
 281         [ ?parse-yaml-doc [ yaml-no-document ] unless ] 2bi
 282     ] with-destructors ;
 283
 284 : yaml-docs> ( str -- arr )
 285     [
 286         init-parser
 287         [ YAML_STREAM_START_EVENT expect-event ]
 288         [ [ ?parse-yaml-doc ] 2curry [ ] produce nip ] 2bi
 289     ] with-destructors ;
 290
 291 <PRIVATE
 292
 293 TUPLE: yaml-anchors objects new-objects next-anchor ;
 294
 295 : <yaml-anchors> ( -- yaml-anchors )
 296     IH{ } clone IH{ } clone 0 yaml-anchors boa ;
 297
 298 GENERIC: (replace-aliases) ( yaml-anchors obj -- obj' )
 299
 300 : incr-anchor ( yaml-anchors -- current-anchor )
 301     [ next-anchor>> ] [
 302         [ [ number>string ] [ 1 + ] bi ]
 303         [ next-anchor<< ] bi*
 304     ] bi ;
 305
 306 :: (?replace-aliases) ( yaml-anchors obj -- obj' )
 307     yaml-anchors objects>> :> objects
 308     obj objects at* [
 309         [ yaml-anchors incr-anchor dup obj objects set-at ] unless*
 310         <yaml-alias>
 311     ] [
 312         drop f obj objects set-at
 313         yaml-anchors obj (replace-aliases) :> obj'
 314         obj obj' yaml-anchors new-objects>> set-at
 315         obj'
 316     ] if ;
 317
 318 : ?replace-aliases ( yaml-anchors obj -- obj' )
 319     dup fixnum? [ nip ] [ (?replace-aliases) ] if ;
 320
 321 M: object (replace-aliases) nip ;
 322
 323 M: byte-array (replace-aliases) nip ;
 324
 325 M: string (replace-aliases) nip ;
 326
 327 M: sequence (replace-aliases)
 328     [ ?replace-aliases ] with map ;
 329
 330 M: sets:set (replace-aliases)
 331     [ members (replace-aliases) ] keep set-like ;
 332
 333 M: assoc (replace-aliases)
 334     swap '[ [ _ swap ?replace-aliases ] bi@ ] assoc-map ;
 335
 336 TUPLE: yaml-anchor anchor obj ;
 337 C: <yaml-anchor> yaml-anchor
 338
 339 GENERIC: (replace-anchors) ( yaml-anchors obj -- obj' )
 340
 341 : (get-anchor) ( yaml-anchors obj -- anchor/f )
 342     swap objects>> at ;
 343
 344 : get-anchor ( yaml-anchors obj -- anchor/f )
 345     { [ (get-anchor) ] [ over new-objects>> at (get-anchor) ] } 2|| ;
 346
 347 : ?replace-anchors ( yaml-anchors obj -- obj' )
 348     [ (replace-anchors) ] [ get-anchor ] 2bi [ swap <yaml-anchor> ] when* ;
 349
 350 M: object (replace-anchors) nip ;
 351
 352 M: byte-array (replace-anchors) nip ;
 353
 354 M: string (replace-anchors) nip ;
 355
 356 M: sequence (replace-anchors)
 357     [ ?replace-anchors ] with map ;
 358
 359 M: sets:set (replace-anchors)
 360     [ members ?replace-anchors ] keep set-like ;
 361
 362 M: assoc (replace-anchors)
 363     swap '[ [ _ swap ?replace-anchors ] bi@ ] assoc-map ;
 364
 365 : replace-identities ( obj -- obj' )
 366     [ <yaml-anchors> ] dip dupd ?replace-aliases ?replace-anchors ;
 367
 368 ! TODO We can also pass some data when registering the write handler,
 369 ! use this to have several buffers if it can be interrupted.
 370 ! For now, only do operations on strings that are in memory
 371 ! so we don't need to be reentrant.
 372 SYMBOL: yaml-write-buffer
 373 : yaml-write-handler ( -- alien )
 374     [
 375         memory>byte-array yaml-write-buffer get-global
 376         push-all drop 1
 377     ] yaml_write_handler_t ;
 378
 379 GENERIC: emit-value ( emitter event anchor obj -- )
 380
 381 : emit-object ( emitter event obj -- ) [ f ] dip emit-value ;
 382
 383 : scalar-implicit-tag? ( tag str mapping-key? -- plain_implicit quoted_implicit )
 384     implicit-tags get [
 385         resolve-plain-scalar = t
 386     ] [ 3drop f f ] if ;
 387
 388 :: (emit-scalar) ( emitter event anchor obj mapping-key? -- )
 389     event anchor
 390     obj [ yaml-tag ] [ represent-scalar ] bi
 391     -1 2over mapping-key? scalar-implicit-tag? YAML_ANY_SCALAR_STYLE
 392     yaml_scalar_event_initialize yaml-initialize-assert-ok
 393     emitter event yaml_emitter_emit_asserted ;
 394
 395 : emit-mapping-key-scalar ( emitter event anchor obj -- ) t (emit-scalar) ;
 396 : emit-scalar ( emitter event anchor obj -- ) f (emit-scalar) ;
 397
 398 ! strings and special keys are the only things that need special treatment
 399 ! because they can have the same representation
 400 : emit-mapping-key ( emitter event obj -- )
 401     dup { [ string? ] [ yaml-merge? ] [ yaml-value? ] } 1||
 402     [ [ f ] dip emit-mapping-key-scalar ] [ emit-object ] if ;
 403
 404 M: object emit-value ( emitter event anchor obj -- ) emit-scalar ;
 405
 406 M: yaml-anchor emit-value ( emitter event unused obj -- )
 407     nip [ anchor>> ] [ obj>> ] bi emit-value ;
 408
 409 M:: yaml-alias emit-value ( emitter event unused obj -- )
 410     event obj anchor>> yaml_alias_event_initialize yaml-initialize-assert-ok
 411     emitter event yaml_emitter_emit_asserted ;
 412
 413 :: emit-sequence-start ( emitter event anchor tag implicit -- )
 414     event anchor tag implicit YAML_ANY_SEQUENCE_STYLE
 415     yaml_sequence_start_event_initialize yaml-initialize-assert-ok
 416     emitter event yaml_emitter_emit_asserted ;
 417
 418 : emit-sequence-end ( emitter event -- )
 419     dup yaml_sequence_end_event_initialize yaml-initialize-assert-ok
 420     yaml_emitter_emit_asserted ;
 421
 422 : emit-sequence-body ( emitter event seq -- )
 423     [ emit-object ] 2with each ;
 424
 425 : emit-assoc-body ( emitter event assoc -- )
 426     [
 427         [ emit-mapping-key ]
 428         [ emit-object ] bi-curry* 2bi
 429     ] withd withd assoc-each ;
 430
 431 : emit-linked-assoc-body ( emitter event linked-assoc -- )
 432     >alist [ first2 swap associate ] map emit-sequence-body ;
 433
 434 : emit-set-body ( emitter event set -- )
 435     [ members ] [ cardinality f <array> ] bi zip concat emit-sequence-body ;
 436
 437 M: f emit-value ( emitter event anchor f -- ) emit-scalar ;
 438
 439 M: string emit-value ( emitter event anchor string -- ) emit-scalar ;
 440
 441 M: byte-array emit-value ( emitter event anchor byte-array -- ) emit-scalar ;
 442
 443 M: sequence emit-value ( emitter event anchor seq -- )
 444     [ drop YAML_SEQ_TAG implicit-tags get emit-sequence-start ]
 445     [ nip emit-sequence-body ]
 446     [ 2drop emit-sequence-end ] 4tri ;
 447
 448 M: linked-assoc emit-value ( emitter event anchor assoc -- )
 449     [ drop YAML_OMAP_TAG f emit-sequence-start ]
 450     [ nip emit-linked-assoc-body ]
 451     [ 2drop emit-sequence-end ] 4tri ;
 452
 453 :: emit-assoc-start ( emitter event anchor tag implicit -- )
 454     event anchor tag implicit YAML_ANY_MAPPING_STYLE
 455     yaml_mapping_start_event_initialize yaml-initialize-assert-ok
 456     emitter event yaml_emitter_emit_asserted ;
 457
 458 : emit-assoc-end ( emitter event -- )
 459     dup yaml_mapping_end_event_initialize yaml-initialize-assert-ok
 460     yaml_emitter_emit_asserted ;
 461
 462 M: assoc emit-value ( emitter event anchor assoc -- )
 463     [ drop YAML_MAP_TAG implicit-tags get emit-assoc-start ]
 464     [ nip emit-assoc-body ]
 465     [ 2drop emit-assoc-end ] 4tri ;
 466
 467 M: sets:set emit-value ( emitter event anchor set -- )
 468     [ drop YAML_SET_TAG f emit-assoc-start ]
 469     [ nip emit-set-body ]
 470     [ 2drop emit-assoc-end ] 4tri ;
 471
 472 : unless-libyaml-default ( variable quot -- )
 473     [ get dup +libyaml-default+ = not ] dip
 474     [ 2drop ] if ; inline
 475
 476 : init-emitter-options ( emitter -- )
 477     {
 478         [ emitter-canonical [ yaml_emitter_set_canonical ] unless-libyaml-default ]
 479         [ emitter-indent [ yaml_emitter_set_indent ] unless-libyaml-default ]
 480         [ emitter-width [ yaml_emitter_set_width ] unless-libyaml-default ]
 481         [ emitter-unicode [ yaml_emitter_set_unicode ] unless-libyaml-default ]
 482         [ emitter-line-break [ yaml_emitter_set_break ] unless-libyaml-default ]
 483     } cleave ;
 484
 485 ! registers destructors (use with with-destructors)
 486 :: init-emitter ( -- emitter event )
 487     yaml_emitter_t (malloc-struct) &free :> emitter
 488     emitter yaml_emitter_initialize yaml-initialize-assert-ok
 489     emitter &yaml_emitter_delete drop
 490     emitter init-emitter-options
 491
 492     BV{ } clone :> output
 493     output yaml-write-buffer set-global
 494     emitter yaml-write-handler f yaml_emitter_set_output
 495
 496     yaml_event_t (malloc-struct) &free :> event
 497
 498     event YAML_UTF8_ENCODING
 499     yaml_stream_start_event_initialize yaml-initialize-assert-ok
 500
 501     emitter event yaml_emitter_emit_asserted
 502     emitter event ;
 503
 504 :: emit-doc ( emitter event obj -- )
 505     event f f f implicit-start get yaml_document_start_event_initialize yaml-initialize-assert-ok
 506     emitter event yaml_emitter_emit_asserted
 507
 508     emitter event obj emit-object
 509
 510     event implicit-end get yaml_document_end_event_initialize yaml-initialize-assert-ok
 511     emitter event yaml_emitter_emit_asserted ;
 512
 513 :: flush-emitter ( emitter event -- str )
 514     event yaml_stream_end_event_initialize yaml-initialize-assert-ok
 515     emitter event yaml_emitter_emit_asserted
 516
 517     emitter [ yaml_emitter_flush ] [ yaml-emitter-assert-ok ] bi
 518     yaml-write-buffer get utf8 decode ;
 519
 520 PRIVATE>
 521
 522 : >yaml ( obj -- str )
 523     [
 524         [ init-emitter ] dip
 525         [ replace-identities emit-doc ] [ drop flush-emitter ] 3bi
 526     ] with-destructors ;
 527
 528 : >yaml-docs ( seq -- str )
 529     [
 530         [ init-emitter ] dip
 531         [ [ replace-identities emit-doc ] 2with each ] [ drop flush-emitter ] 3bi
 532     ] with-destructors ;