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