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 ! Same as 'with', but for combinators that
 189 ! put 2 arguments on the stack
 190 : with2 ( param obj quot -- obj curry )
 191     swapd '[ [ _ ] 2dip @ ] ; inline
 192
 193 GENERIC: (deref-aliases) ( anchors obj -- obj' )
 194
 195 M: object (deref-aliases) nip ;
 196
 197 M: byte-array (deref-aliases) nip ;
 198
 199 M: string (deref-aliases) nip ;
 200
 201 M: yaml-alias (deref-aliases) anchor>> of ;
 202
 203 M: sequence (deref-aliases)
 204     [ (deref-aliases) ] with map! ;
 205
 206 M: sets:set (deref-aliases)
 207     [ members (deref-aliases) ] [ clear-set ] [ swap union! ] tri ;
 208
 209 : assoc-map! ( assoc quot -- assoc' )
 210     [ assoc-map ] [ drop clear-assoc ] [ drop swap assoc-union! ] 2tri ; inline
 211
 212 M: assoc (deref-aliases)
 213      [ [ (deref-aliases) ] bi-curry@ bi ] with2 assoc-map! ;
 214
 215 : merge-values ( seq -- assoc )
 216     reverse [ ] [ assoc-union ] map-reduce ;
 217 GENERIC: merge-value ( assoc value -- assoc' )
 218 M: sequence merge-value merge-values merge-value ;
 219 M: assoc merge-value over assoc-diff assoc-union! ;
 220 : pop-at* ( key assoc -- value/f ? )
 221     [ at* ] 2keep pick [ delete-at ] [ 2drop ] if ;
 222
 223 : ?apply-default-key ( assoc -- obj' )
 224     T{ yaml-value } over pop-at* [ nip ] [ drop ] if ;
 225 PRIVATE>
 226
 227 : ?apply-merge-key ( assoc -- assoc' )
 228     T{ yaml-merge } over pop-at*
 229     [ merge-value ] [ drop ] if ;
 230 : scalar-value ( obj -- obj' )
 231     dup hashtable? [ ?apply-default-key ] when ;
 232
 233 <PRIVATE
 234
 235 GENERIC: apply-merge-keys ( already-applied-set obj -- obj' )
 236 : ?apply-merge-keys ( set obj -- obj' )
 237     2dup swap ?adjoin [ apply-merge-keys ] [ nip ] if ;
 238 M: sequence apply-merge-keys
 239     [ ?apply-merge-keys ] with map! ;
 240 M: object apply-merge-keys nip ;
 241 M: byte-array apply-merge-keys nip ;
 242 M: string apply-merge-keys nip ;
 243 M: assoc apply-merge-keys
 244     [ [ ?apply-merge-keys ] bi-curry@ bi ] with2 assoc-map!
 245     merge get [ ?apply-merge-key ] when
 246     value get [ ?apply-default-key ] when ;
 247
 248 :: parse-yaml-doc ( parser event -- obj )
 249     H{ } clone anchors [
 250         parser event next-value
 251         anchors get swap (deref-aliases)
 252         merge get value get or [ IHS{ } clone swap ?apply-merge-keys ] when
 253     ] with-variable ;
 254
 255 :: ?parse-yaml-doc ( parser event -- obj/f ? )
 256     [
 257         parser event next-event type>> {
 258             { YAML_DOCUMENT_START_EVENT [ t ] }
 259             { YAML_STREAM_END_EVENT [ f ] }
 260             [ { YAML_DOCUMENT_START_EVENT YAML_STREAM_END_EVENT } yaml-unexpected-event ]
 261         } case
 262     ] with-destructors [
 263         parser event parse-yaml-doc t
 264         parser event YAML_DOCUMENT_END_EVENT expect-event
 265     ] [ f f ] if ;
 266
 267 ! registers destructors (use with with-destructors)
 268 :: init-parser ( str -- parser event )
 269     yaml_parser_t (malloc-struct) &free :> parser
 270     parser yaml_parser_initialize yaml-initialize-assert-ok
 271     parser &yaml_parser_delete drop
 272
 273     str utf8 encode
 274     [ malloc-byte-array &free ] [ length ] bi :> ( input length )
 275     parser input length yaml_parser_set_input_string
 276
 277     yaml_event_t (malloc-struct) &free :> event
 278     parser event ;
 279
 280 PRIVATE>
 281
 282 : yaml> ( str -- obj )
 283     [
 284         init-parser
 285         [ YAML_STREAM_START_EVENT expect-event ]
 286         [ ?parse-yaml-doc [ yaml-no-document ] unless ] 2bi
 287     ] with-destructors ;
 288
 289 : yaml-docs> ( str -- arr )
 290     [
 291         init-parser
 292         [ YAML_STREAM_START_EVENT expect-event ]
 293         [ [ ?parse-yaml-doc ] 2curry [ ] produce nip ] 2bi
 294     ] with-destructors ;
 295
 296 <PRIVATE
 297
 298 TUPLE: yaml-anchors objects new-objects next-anchor ;
 299
 300 : <yaml-anchors> ( -- yaml-anchors )
 301     IH{ } clone IH{ } clone 0 yaml-anchors boa ;
 302
 303 GENERIC: (replace-aliases) ( yaml-anchors obj -- obj' )
 304
 305 : incr-anchor ( yaml-anchors -- current-anchor )
 306     [ next-anchor>> ] [
 307         [ [ number>string ] [ 1 + ] bi ]
 308         [ next-anchor<< ] bi*
 309     ] bi ;
 310
 311 :: (?replace-aliases) ( yaml-anchors obj -- obj' )
 312     yaml-anchors objects>> :> objects
 313     obj objects at* [
 314         [ yaml-anchors incr-anchor dup obj objects set-at ] unless*
 315         <yaml-alias>
 316     ] [
 317         drop f obj objects set-at
 318         yaml-anchors obj (replace-aliases) :> obj'
 319         obj obj' yaml-anchors new-objects>> set-at
 320         obj'
 321     ] if ;
 322
 323 : ?replace-aliases ( yaml-anchors obj -- obj' )
 324     dup fixnum? [ nip ] [ (?replace-aliases) ] if ;
 325
 326 M: object (replace-aliases) nip ;
 327
 328 M: byte-array (replace-aliases) nip ;
 329
 330 M: string (replace-aliases) nip ;
 331
 332 M: sequence (replace-aliases)
 333     [ ?replace-aliases ] with map ;
 334
 335 M: sets:set (replace-aliases)
 336     [ members (replace-aliases) ] keep set-like ;
 337
 338 M: assoc (replace-aliases)
 339     swap '[ [ _ swap ?replace-aliases ] bi@ ] assoc-map ;
 340
 341 TUPLE: yaml-anchor anchor obj ;
 342 C: <yaml-anchor> yaml-anchor
 343
 344 GENERIC: (replace-anchors) ( yaml-anchors obj -- obj' )
 345
 346 : (get-anchor) ( yaml-anchors obj -- anchor/f )
 347     swap objects>> at ;
 348
 349 : get-anchor ( yaml-anchors obj -- anchor/f )
 350     { [ (get-anchor) ] [ over new-objects>> at (get-anchor) ] } 2|| ;
 351
 352 : ?replace-anchors ( yaml-anchors obj -- obj' )
 353     [ (replace-anchors) ] [ get-anchor ] 2bi [ swap <yaml-anchor> ] when* ;
 354
 355 M: object (replace-anchors) nip ;
 356
 357 M: byte-array (replace-anchors) nip ;
 358
 359 M: string (replace-anchors) nip ;
 360
 361 M: sequence (replace-anchors)
 362     [ ?replace-anchors ] with map ;
 363
 364 M: sets:set (replace-anchors)
 365     [ members ?replace-anchors ] keep set-like ;
 366
 367 M: assoc (replace-anchors)
 368     swap '[ [ _ swap ?replace-anchors ] bi@ ] assoc-map ;
 369
 370 : replace-identities ( obj -- obj' )
 371     [ <yaml-anchors> ] dip dupd ?replace-aliases ?replace-anchors ;
 372
 373 ! TODO We can also pass some data when registering the write handler,
 374 ! use this to have several buffers if it can be interrupted.
 375 ! For now, only do operations on strings that are in memory
 376 ! so we don't need to be reentrant.
 377 SYMBOL: yaml-write-buffer
 378 : yaml-write-handler ( -- alien )
 379     [
 380         memory>byte-array yaml-write-buffer get-global
 381         push-all drop 1
 382     ] yaml_write_handler_t ;
 383
 384 GENERIC: emit-value ( emitter event anchor obj -- )
 385
 386 : emit-object ( emitter event obj -- ) [ f ] dip emit-value ;
 387
 388 : scalar-implicit-tag? ( tag str mapping-key? -- plain_implicit quoted_implicit )
 389     implicit-tags get [
 390         resolve-plain-scalar = t
 391     ] [ 3drop f f ] if ;
 392
 393 :: (emit-scalar) ( emitter event anchor obj mapping-key? -- )
 394     event anchor
 395     obj [ yaml-tag ] [ represent-scalar ] bi
 396     -1 2over mapping-key? scalar-implicit-tag? YAML_ANY_SCALAR_STYLE
 397     yaml_scalar_event_initialize yaml-initialize-assert-ok
 398     emitter event yaml_emitter_emit_asserted ;
 399
 400 : emit-mapping-key-scalar ( emitter event anchor obj -- ) t (emit-scalar) ;
 401 : emit-scalar ( emitter event anchor obj -- ) f (emit-scalar) ;
 402
 403 ! strings and special keys are the only things that need special treatment
 404 ! because they can have the same representation
 405 : emit-mapping-key ( emitter event obj -- )
 406     dup { [ string? ] [ yaml-merge? ] [ yaml-value? ] } 1||
 407     [ [ f ] dip emit-mapping-key-scalar ] [ emit-object ] if ;
 408
 409 M: object emit-value ( emitter event anchor obj -- ) emit-scalar ;
 410
 411 M: yaml-anchor emit-value ( emitter event unused obj -- )
 412     nip [ anchor>> ] [ obj>> ] bi emit-value ;
 413
 414 M:: yaml-alias emit-value ( emitter event unused obj -- )
 415     event obj anchor>> yaml_alias_event_initialize yaml-initialize-assert-ok
 416     emitter event yaml_emitter_emit_asserted ;
 417
 418 :: emit-sequence-start ( emitter event anchor tag implicit -- )
 419     event anchor tag implicit YAML_ANY_SEQUENCE_STYLE
 420     yaml_sequence_start_event_initialize yaml-initialize-assert-ok
 421     emitter event yaml_emitter_emit_asserted ;
 422
 423 : emit-sequence-end ( emitter event -- )
 424     dup yaml_sequence_end_event_initialize yaml-initialize-assert-ok
 425     yaml_emitter_emit_asserted ;
 426
 427 : emit-sequence-body ( emitter event seq -- )
 428     [ emit-object ] 2with each ;
 429
 430 : emit-assoc-body ( emitter event assoc -- )
 431     [
 432         [ emit-mapping-key ]
 433         [ emit-object ] bi-curry* 2bi
 434     ] with2 with2 assoc-each ;
 435
 436 : emit-linked-assoc-body ( emitter event linked-assoc -- )
 437     >alist [ first2 swap associate ] map emit-sequence-body ;
 438
 439 : emit-set-body ( emitter event set -- )
 440     [ members ] [ cardinality f <array> ] bi zip concat emit-sequence-body ;
 441
 442 M: f emit-value ( emitter event anchor f -- ) emit-scalar ;
 443
 444 M: string emit-value ( emitter event anchor string -- ) emit-scalar ;
 445
 446 M: byte-array emit-value ( emitter event anchor byte-array -- ) emit-scalar ;
 447
 448 M: sequence emit-value ( emitter event anchor seq -- )
 449     [ drop YAML_SEQ_TAG implicit-tags get emit-sequence-start ]
 450     [ nip emit-sequence-body ]
 451     [ 2drop emit-sequence-end ] 4tri ;
 452
 453 M: linked-assoc emit-value ( emitter event anchor assoc -- )
 454     [ drop YAML_OMAP_TAG f emit-sequence-start ]
 455     [ nip emit-linked-assoc-body ]
 456     [ 2drop emit-sequence-end ] 4tri ;
 457
 458 :: emit-assoc-start ( emitter event anchor tag implicit -- )
 459     event anchor tag implicit YAML_ANY_MAPPING_STYLE
 460     yaml_mapping_start_event_initialize yaml-initialize-assert-ok
 461     emitter event yaml_emitter_emit_asserted ;
 462
 463 : emit-assoc-end ( emitter event -- )
 464     dup yaml_mapping_end_event_initialize yaml-initialize-assert-ok
 465     yaml_emitter_emit_asserted ;
 466
 467 M: assoc emit-value ( emitter event anchor assoc -- )
 468     [ drop YAML_MAP_TAG implicit-tags get emit-assoc-start ]
 469     [ nip emit-assoc-body ]
 470     [ 2drop emit-assoc-end ] 4tri ;
 471
 472 M: sets:set emit-value ( emitter event anchor set -- )
 473     [ drop YAML_SET_TAG f emit-assoc-start ]
 474     [ nip emit-set-body ]
 475     [ 2drop emit-assoc-end ] 4tri ;
 476
 477 : unless-libyaml-default ( variable quot -- )
 478     [ get dup +libyaml-default+ = not ] dip
 479     [ 2drop ] if ; inline
 480
 481 : init-emitter-options ( emitter -- )
 482     {
 483         [ emitter-canonical [ yaml_emitter_set_canonical ] unless-libyaml-default ]
 484         [ emitter-indent [ yaml_emitter_set_indent ] unless-libyaml-default ]
 485         [ emitter-width [ yaml_emitter_set_width ] unless-libyaml-default ]
 486         [ emitter-unicode [ yaml_emitter_set_unicode ] unless-libyaml-default ]
 487         [ emitter-line-break [ yaml_emitter_set_break ] unless-libyaml-default ]
 488     } cleave ;
 489
 490 ! registers destructors (use with with-destructors)
 491 :: init-emitter ( -- emitter event )
 492     yaml_emitter_t (malloc-struct) &free :> emitter
 493     emitter yaml_emitter_initialize yaml-initialize-assert-ok
 494     emitter &yaml_emitter_delete drop
 495     emitter init-emitter-options
 496
 497     BV{ } clone :> output
 498     output yaml-write-buffer set-global
 499     emitter yaml-write-handler f yaml_emitter_set_output
 500
 501     yaml_event_t (malloc-struct) &free :> event
 502
 503     event YAML_UTF8_ENCODING
 504     yaml_stream_start_event_initialize yaml-initialize-assert-ok
 505
 506     emitter event yaml_emitter_emit_asserted
 507     emitter event ;
 508
 509 :: emit-doc ( emitter event obj -- )
 510     event f f f implicit-start get yaml_document_start_event_initialize yaml-initialize-assert-ok
 511     emitter event yaml_emitter_emit_asserted
 512
 513     emitter event obj emit-object
 514
 515     event implicit-end get yaml_document_end_event_initialize yaml-initialize-assert-ok
 516     emitter event yaml_emitter_emit_asserted ;
 517
 518 :: flush-emitter ( emitter event -- str )
 519     event yaml_stream_end_event_initialize yaml-initialize-assert-ok
 520     emitter event yaml_emitter_emit_asserted
 521
 522     emitter [ yaml_emitter_flush ] [ yaml-emitter-assert-ok ] bi
 523     yaml-write-buffer get utf8 decode ;
 524
 525 PRIVATE>
 526
 527 : >yaml ( obj -- str )
 528     [
 529         [ init-emitter ] dip
 530         [ replace-identities emit-doc ] [ drop flush-emitter ] 3bi
 531     ] with-destructors ;
 532
 533 : >yaml-docs ( seq -- str )
 534     [
 535         [ init-emitter ] dip
 536         [ [ replace-identities emit-doc ] 2with each ] [ drop flush-emitter ] 3bi
 537     ] with-destructors ;