Paste: boring enterprisey stuff
Author: | eiz |
Mode: | factor |
Date: | Sun, 19 Apr 2009 21:39:41 |
Plain Text |
USING: kernel sequences io io.files io.encodings.ascii ascii assocs
vectors splitting math accessors namespaces math.parser prettyprint
xml xml.data xml.writer arrays make combinators strings ;
IN: edifact.directory
TUPLE: message id version release controlling-agency revision date elements ;
TUPLE: segment id name description repeat usage ;
TUPLE: segment-group repeat elements ;
<PRIVATE
TUPLE: section lines name ;
: <section> section new ;
: <segment> segment new ;
: <segment-group> 0 <vector> segment-group boa ;
: <message> message new ;
: first|blank
dup length 0 > [ first ] [ drop 32 ] if ;
SYMBOL: sg-stack
: push-sg sg-stack get push ;
: pop-sg sg-stack get pop ;
: top-sg sg-stack get peek ;
: split-section-name
" " split dup first { "CHAPTER" "PART" } member? 2 1 ? cut
[ " " join [ blank? ] trim ] bi@ ;
: new-section
[ split-section-name 1vector <section> swap >>lines swap >>name ] dip push ;
: append-section
[ [ blank? ] trim ] dip peek lines>> push ;
: parse-line
over first|blank blank? [ append-section ] [ new-section ] if ;
: parse-sections
<section> "HEADER" >>name V{ } clone >>lines
1vector [ [ parse-line ] curry each ] keep ;
: read-sections
ascii <file-reader> lines parse-sections ;
: line-segment-group?
first|blank CHAR: - = ;
: section-find
swap [ name>> = ] with find ;
: section-index section-find drop ;
: section-named section-find nip ;
: push-segment-group
lines>> first " -" split [ empty? not ] filter 3 tail
second string>number <segment-group> push-sg ;
: segment-name 3 head ;
: segment-opts
46 tail " -" split [ empty? not ] filter
dup length 3 < [ "" suffix ] when ;
: segment-repeat second string>number ;
: segment-usage first ;
: segment-closes-count
third [ CHAR: + = ] filter length ;
: finish-segment
pop-sg top-sg elements>> push ;
: append-segment
<segment>
over name>> >>id
over lines>> first
[ segment-name >>name ] [ segment-opts ] bi
[ segment-repeat >>repeat ] [ segment-usage >>usage ] bi
top-sg elements>> push
lines>> first segment-opts segment-closes-count [ finish-segment ] times ;
: segment-section
dup lines>> first line-segment-group?
[ push-segment-group ] [ append-segment ] if ;
: message-header
"HEADER" section-named lines>> [ empty? not ] filter 3 tail
[ ":" split [ [ blank? ] trim ] map ] map ;
: message-body
dup "4.3.1" section-index 2 + tail-slice
1 <segment-group> 1vector sg-stack [
[ segment-section ] each
sg-stack get first
] with-variable ;
: make-message-spec
<message>
"Message Type" pick at >>id
"Version" pick at >>version
"Release" pick at >>release
"Contr. Agency" pick at >>controlling-agency
"Revision" pick at string>number >>revision
"Date" pick at >>date
nip swap elements>> >>elements ;
: parse-message-spec
[ message-body ] [ message-header ] bi make-message-spec ;
: parse-segment-spec ;
: parse-composite-spec ;
: parse-element-spec ;
: assoc, swap 2array , ;
: message-xml-attrs
[
{
[ id>> "id" assoc, ]
[ version>> "version" assoc, ]
[ release>> "release" assoc, ]
[ controlling-agency>> "agency" assoc, ]
[ revision>> number>string "revision" assoc, ]
[ date>> "date" assoc, ]
} cleave
] { } make ;
: segment-xml-attrs
[
{
[ id>> "id" assoc, ]
[ name>> "name" assoc, ]
[ repeat>> number>string "repeat" assoc, ]
[ usage>> "usage" assoc, ]
} cleave
] { } make ;
: segment-group-xml-attrs
repeat>> number>string "repeat" swap 2array 1array ;
PRIVATE>
GENERIC: edifact-spec>xml
M: segment edifact-spec>xml
"segment" swap segment-xml-attrs <contained-tag> ;
M: segment-group edifact-spec>xml
"group" over segment-group-xml-attrs
rot elements>> [ edifact-spec>xml ] map <tag> ;
M: message edifact-spec>xml
"message" over message-xml-attrs
rot elements>> [ edifact-spec>xml ] map <tag> ;
: message-spec
read-sections parse-message-spec ;
: segment-spec
read-sections parse-segment-spec ;
: composite-spec
read-sections parse-composite-spec ;
: element-spec
read-sections parse-element-spec ;
New Annotation