steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

YAML: indent/docs

db4
Jon Harper 2014-02-21 00:19:03 +01:00 committed by John Benediktsson
parent 4ccb1a9e54
commit d1b1a40e6d
2 changed files with 216 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
extra/yaml/yaml-docs.factor Normal file
View File

@ -0,0 +1,48 @@
! Copyright (C) 2014 Jon Harper.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs help.markup help.syntax kernel sequences
strings ;
IN: yaml
HELP: >yaml
{ $values
{ "obj" object }
{ "str" string }
}
{ $description "Serializes the object into a YAML formatted string." } ;
HELP: >yaml-docs
{ $values
{ "seq" sequence }
{ "str" string }
}
{ $description "Serializes the sequence into a YAML formatted string. Each element is outputted as a YAML document" } ;
HELP: yaml-docs>
{ $values
{ "str" string }
{ "arr" array }
}
{ $description "Deserializes the YAML formatted string into a Factor array. Each document becomes an element of the array" } ;
HELP: yaml>
{ $values
{ "str" string }
{ "obj" object }
}
{ $description "Deserializes the YAML formatted string into a Factor object." } ;
ARTICLE: "yaml" "YAML serialization"
"The " { $vocab-link "yaml" } " vocabulary implements YAML serialization/deserialization."
{ $subsections
>yaml
>yaml-docs
yaml>
yaml-docs>
}
;
{ >yaml >yaml-docs } related-words
{ yaml> yaml-docs> } related-words
ABOUT: "yaml"

295
extra/yaml/yaml.factor
View File

@ -6,10 +6,17 @@ io.encodings.string io.encodings.utf8 kernel libc locals make
math namespaces prettyprint sequences strings yaml.ffi ; math namespaces prettyprint sequences strings yaml.ffi ;
IN: yaml IN: yaml
<PRIVATE
: yaml-assert-ok ( n -- ) 0 = [ "yaml error" throw ] when ; : yaml-assert-ok ( n -- ) 0 = [ "yaml error" throw ] when ;
: event>scalar ( event -- obj ) data>> scalar>> [ value>> ] [ length>> ] bi memory>byte-array utf8 decode ;
: event>scalar ( event -- obj )
data>> scalar>> [ value>> ] [ length>> ] bi
memory>byte-array utf8 decode ;
: ?scalar-value ( event -- scalar/f f/type ) : ?scalar-value ( event -- scalar/f f/type )
dup type>> YAML_SCALAR_EVENT = [ event>scalar f ] [ type>> clone f swap ] if ; dup type>> YAML_SCALAR_EVENT =
[ event>scalar f ] [ type>> clone f swap ] if ;
! Must not reuse the event struct before with-destructors scope ends ! Must not reuse the event struct before with-destructors scope ends
: next-event ( parser event -- event ) : next-event ( parser event -- event )
@ -18,84 +25,100 @@ IN: yaml
DEFER: parse-sequence DEFER: parse-sequence
DEFER: parse-mapping DEFER: parse-mapping
: next-complex-value ( parser event type -- obj ) : next-complex-value ( parser event type -- obj )
{ {
{ YAML_SEQUENCE_START_EVENT [ parse-sequence ] } { YAML_SEQUENCE_START_EVENT [ parse-sequence ] }
{ YAML_MAPPING_START_EVENT [ parse-mapping ] } { YAML_MAPPING_START_EVENT [ parse-mapping ] }
[ throw ] [ throw ]
} case ; } case ;
:: next-value ( parser event -- obj )
parser event [ next-event ?scalar-value ] with-destructors
[ [ drop parser event ] dip next-complex-value ] when* ;
:: parse-mapping ( parser event -- map ) [ :: next-value ( parser event -- obj )
f :> done! parser event [ next-event ?scalar-value ] with-destructors
[ done ] [ [ [ [ drop parser event ] dip next-complex-value ] when* ;
parser event next-event type>>
YAML_MAPPING_END_EVENT = [ :: parse-mapping ( parser event -- map )
t done! f f [
] [ f :> done!
event ?scalar-value [ done ] [
] if [
] with-destructors 2dup or [ parser event next-event type>>
[ nip [ parser event ] dip next-complex-value ] when* YAML_MAPPING_END_EVENT = [
parser event next-value swap ,, t done! f f
] [ 2drop ] if ] until ] [
] H{ } make ; event ?scalar-value
:: parse-sequence ( parser event -- seq ) [ ] if
f :> done! ] with-destructors
[ done ] [ [ 2dup or [
parser event next-event type>> [ nip [ parser event ] dip next-complex-value ] when*
YAML_SEQUENCE_END_EVENT = [ parser event next-value swap ,,
t done! f ] [ 2drop ] if
] [ ] until
event ?scalar-value dup [ nip ] [ [ , ] dip ] if ] H{ } make ;
] if
] with-destructors [ [ parser event ] dip next-complex-value , ] when* ] until :: parse-sequence ( parser event -- seq )
] { } make ; [
f :> done!
[ done ] [
[
parser event next-event type>>
YAML_SEQUENCE_END_EVENT = [
t done! f
] [
event ?scalar-value dup [ nip ] [ [ , ] dip ] if
] if
] with-destructors
[ [ parser event ] dip next-complex-value , ] when*
] until
] { } make ;
: expect-event ( parser event type -- ) : expect-event ( parser event type -- )
[ [
[ next-event type>> ] dip = [ next-event type>> ] dip =
[ "wrong event" throw ] unless [ "wrong event" throw ] unless
] with-destructors ; ] with-destructors ;
:: ?parse-yaml-doc ( parser event -- obj/f ? ) :: ?parse-yaml-doc ( parser event -- obj/f ? )
[ parser event next-event type>> { [
{ YAML_DOCUMENT_START_EVENT [ t ] } parser event next-event type>> {
{ YAML_STREAM_END_EVENT [ f ] } { YAML_DOCUMENT_START_EVENT [ t ] }
[ "wrong event" throw ] { YAML_STREAM_END_EVENT [ f ] }
} case ] with-destructors [ "wrong event" throw ]
[ parser event next-value t } case
parser event YAML_DOCUMENT_END_EVENT expect-event ] with-destructors
] [ f f ] if ; [
parser event next-value t
parser event YAML_DOCUMENT_END_EVENT expect-event
] [ f f ] if ;
! registers destructors (use with with-destructors) ! registers destructors (use with with-destructors)
:: init-parser ( str -- parser event ) :: init-parser ( str -- parser event )
yaml_parser_t (malloc-struct) &free :> parser yaml_parser_t (malloc-struct) &free :> parser
parser yaml_parser_initialize yaml-assert-ok parser yaml_parser_initialize yaml-assert-ok
parser &yaml_parser_delete drop parser &yaml_parser_delete drop
str utf8 encode [ malloc-byte-array &free ] [ length ] bi :> ( input length ) str utf8 encode
parser input length yaml_parser_set_input_string [ malloc-byte-array &free ] [ length ] bi :> ( input length )
parser input length yaml_parser_set_input_string
yaml_event_t (malloc-struct) &free :> event yaml_event_t (malloc-struct) &free :> event
parser event parser event ;
;
PRIVATE>
: yaml> ( str -- obj ) [ : yaml> ( str -- obj )
init-parser [
[ YAML_STREAM_START_EVENT expect-event ] init-parser
[ ?parse-yaml-doc [ "No Document" throw ] unless ] 2bi [ YAML_STREAM_START_EVENT expect-event ]
] with-destructors [ ?parse-yaml-doc [ "No Document" throw ] unless ] 2bi
; ] with-destructors ;
: yaml-docs> ( str -- seq ) [ : yaml-docs> ( str -- arr )
init-parser [
[ YAML_STREAM_START_EVENT expect-event ] init-parser
[ [ ?parse-yaml-doc ] 2curry [ ] produce nip ] 2bi [ YAML_STREAM_START_EVENT expect-event ]
] with-destructors [ [ ?parse-yaml-doc ] 2curry [ ] produce nip ] 2bi
; ] with-destructors ;
<PRIVATE
! TODO We can also pass some data when registering the write handler, ! TODO We can also pass some data when registering the write handler,
! use this to have several buffers if it can be interrupted. ! use this to have several buffers if it can be interrupted.
@ -103,95 +126,113 @@ DEFER: parse-mapping
! so we don't need to be reentrant. ! so we don't need to be reentrant.
SYMBOL: yaml-write-buffer SYMBOL: yaml-write-buffer
: yaml-write-handler ( -- alien ) : yaml-write-handler ( -- alien )
[ [
memory>byte-array yaml-write-buffer get-global memory>byte-array yaml-write-buffer get-global
push-all drop 1 push-all drop 1
] yaml_write_handler_t ; ] yaml_write_handler_t ;
GENERIC: emit-value ( emitter event obj -- ) GENERIC: emit-value ( emitter event obj -- )
M:: string emit-value ( emitter event string -- ) M:: string emit-value ( emitter event string -- )
[ [
string utf8 encode [ malloc-byte-array &free ] [ length ] bi :> ( value length ) string utf8 encode
"tag:yaml.org,2002:str" utf8 malloc-string &free :> tag [ malloc-byte-array &free ] [ length ] bi :> ( value length )
event f tag value length 0 0 0 yaml_scalar_event_initialize yaml-assert-ok
emitter event yaml_emitter_emit yaml-assert-ok "tag:yaml.org,2002:str" utf8 malloc-string &free :> tag
] with-destructors ;
event f tag value length 0 0 0
yaml_scalar_event_initialize yaml-assert-ok
emitter event yaml_emitter_emit yaml-assert-ok
] with-destructors ;
:: emit-sequence-start ( emitter event -- ) :: emit-sequence-start ( emitter event -- )
[ [
"tag:yaml.org,2002:seq" utf8 malloc-string &free :> tag "tag:yaml.org,2002:seq" utf8 malloc-string &free :> tag
event f tag 0 0 yaml_sequence_start_event_initialize yaml-assert-ok
emitter event yaml_emitter_emit yaml-assert-ok event f tag 0 0
] with-destructors ; yaml_sequence_start_event_initialize yaml-assert-ok
emitter event yaml_emitter_emit yaml-assert-ok
] with-destructors ;
: emit-sequence-end ( emitter event -- ) : emit-sequence-end ( emitter event -- )
dup yaml_sequence_end_event_initialize yaml-assert-ok dup yaml_sequence_end_event_initialize yaml-assert-ok
yaml_emitter_emit yaml-assert-ok ; yaml_emitter_emit yaml-assert-ok ;
: emit-sequence ( emitter event seq -- ) : emit-sequence ( emitter event seq -- )
[ emit-value ] with with each ; [ emit-value ] with with each ;
M: sequence emit-value ( emitter event seq -- ) M: sequence emit-value ( emitter event seq -- )
[ drop emit-sequence-start ] [ emit-sequence ] [ drop emit-sequence-end ] 3tri ; [ drop emit-sequence-start ]
[ emit-sequence ]
[ drop emit-sequence-end ] 3tri ;
:: emit-assoc-start ( emitter event -- ) :: emit-assoc-start ( emitter event -- )
[ [
"tag:yaml.org,2002:map" utf8 malloc-string &free :> tag "tag:yaml.org,2002:map" utf8 malloc-string &free :> tag
event f tag 0 0 yaml_mapping_start_event_initialize yaml-assert-ok
emitter event yaml_emitter_emit yaml-assert-ok event f tag 0 0
] with-destructors ; yaml_mapping_start_event_initialize yaml-assert-ok
emitter event yaml_emitter_emit yaml-assert-ok
] with-destructors ;
: emit-assoc-end ( emitter event -- ) : emit-assoc-end ( emitter event -- )
dup yaml_mapping_end_event_initialize yaml-assert-ok dup yaml_mapping_end_event_initialize yaml-assert-ok
yaml_emitter_emit yaml-assert-ok ; yaml_emitter_emit yaml-assert-ok ;
: emit-assoc ( emitter event assoc -- ) : emit-assoc ( emitter event assoc -- )
[ [ emit-value ] with with bi@ ] with with assoc-each ; [ [ emit-value ] with with bi@ ] with with assoc-each ;
M: assoc emit-value ( emitter event seq -- ) M: assoc emit-value ( emitter event seq -- )
[ drop emit-assoc-start ] [ emit-assoc ] [ drop emit-assoc-end ] 3tri ; [ drop emit-assoc-start ]
[ emit-assoc ]
[ drop emit-assoc-end ] 3tri ;
! registers destructors (use with with-destructors) ! registers destructors (use with with-destructors)
:: init-emitter ( -- emitter event ) :: init-emitter ( -- emitter event )
yaml_emitter_t (malloc-struct) &free :> emitter yaml_emitter_t (malloc-struct) &free :> emitter
emitter yaml_emitter_initialize yaml-assert-ok emitter yaml_emitter_initialize yaml-assert-ok
emitter &yaml_emitter_delete drop emitter &yaml_emitter_delete drop
BV{ } clone :> output BV{ } clone :> output
output yaml-write-buffer set-global output yaml-write-buffer set-global
emitter yaml-write-handler f yaml_emitter_set_output emitter yaml-write-handler f yaml_emitter_set_output
yaml_event_t (malloc-struct) &free :> event yaml_event_t (malloc-struct) &free :> event
event YAML_UTF8_ENCODING yaml_stream_start_event_initialize yaml-assert-ok event YAML_UTF8_ENCODING
emitter event yaml_emitter_emit yaml-assert-ok yaml_stream_start_event_initialize yaml-assert-ok
emitter event
; emitter event yaml_emitter_emit yaml-assert-ok
emitter event ;
:: emit-doc ( emitter event obj -- ) :: emit-doc ( emitter event obj -- )
event f f f 0 yaml_document_start_event_initialize yaml-assert-ok event f f f 0 yaml_document_start_event_initialize yaml-assert-ok
emitter event yaml_emitter_emit yaml-assert-ok emitter event yaml_emitter_emit yaml-assert-ok
emitter event obj emit-value emitter event obj emit-value
event 0 yaml_document_end_event_initialize yaml-assert-ok event 0 yaml_document_end_event_initialize yaml-assert-ok
emitter event yaml_emitter_emit yaml-assert-ok emitter event yaml_emitter_emit yaml-assert-ok ;
;
! registers destructors (use with with-destructors) ! registers destructors (use with with-destructors)
:: flush-emitter ( emitter event -- str ) :: flush-emitter ( emitter event -- str )
event yaml_stream_end_event_initialize yaml-assert-ok event yaml_stream_end_event_initialize yaml-assert-ok
emitter event yaml_emitter_emit yaml-assert-ok emitter event yaml_emitter_emit yaml-assert-ok
emitter yaml_emitter_flush yaml-assert-ok emitter yaml_emitter_flush yaml-assert-ok
yaml-write-buffer get utf8 decode yaml-write-buffer get utf8 decode ;
;
: >yaml ( obj -- str ) [ PRIVATE>
[ init-emitter ] dip
[ emit-doc ] [ drop flush-emitter ] 3bi
] with-destructors
;
: >yaml-docs ( seq -- str ) [ : >yaml ( obj -- str )
[ init-emitter ] dip [
[ [ emit-doc ] with with each ] [ drop flush-emitter ] 3bi [ init-emitter ] dip
] with-destructors [ emit-doc ] [ drop flush-emitter ] 3bi
; ] with-destructors ;
: >yaml-docs ( seq -- str )
[
[ init-emitter ] dip
[ [ emit-doc ] with with each ] [ drop flush-emitter ] 3bi
] with-destructors ;