Paste: boring enterprisey stuff

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 ) section new ;
: <segment> ( -- segment ) segment new ;
: <segment-group> ( repeat -- segment-group ) 0 <vector> segment-group boa ;
: <message> ( -- message ) message new ;

: first|blank ( seq -- first|blank )
    dup length 0 > [ first ] [ drop 32 ] if ;

SYMBOL: sg-stack

: push-sg ( seg-group -- ) sg-stack get push ;
: pop-sg  ( -- seg-group ) sg-stack get pop  ;
: top-sg  ( -- seg-group ) sg-stack get peek ;

: split-section-name ( line -- name first-line )
    " " split dup first { "CHAPTER" "PART" } member? 2 1 ? cut 
    [ " " join [ blank? ] trim ] bi@ ;

: new-section ( line sections -- )
    [ split-section-name 1vector <section> swap >>lines swap >>name ] dip push ;

: append-section ( line sections -- )
    [ [ blank? ] trim ] dip peek lines>> push ;

: parse-line ( line sections -- ) 
    over first|blank blank? [ append-section ] [ new-section ] if ;

: parse-sections ( lines -- sections )
    <section> "HEADER" >>name V{ } clone >>lines
    1vector [ [ parse-line ] curry each ] keep ;

: read-sections ( path -- sections )
    ascii <file-reader> lines parse-sections ;

: line-segment-group? ( line -- ? )
    first|blank CHAR: - = ;

: section-find ( sections name -- i elt )
    swap [ name>> = ] with find ;

: section-index ( sections name -- i ) section-find drop ;
: section-named ( sections name -- section ) section-find nip ;

: push-segment-group ( section -- )
    lines>> first " -" split [ empty? not ] filter 3 tail
    second string>number <segment-group> push-sg ;

: segment-name ( line -- name ) 3 head ;
: segment-opts ( line -- opts ) 
    46 tail " -" split [ empty? not ] filter
    dup length 3 < [ "" suffix ] when ;
: segment-repeat ( opts -- repeat ) second string>number ;
: segment-usage ( opts -- usage ) first ;
: segment-closes-count ( opts -- n )
    third [ CHAR: + = ] filter length ;

: finish-segment ( -- ) 
    pop-sg top-sg elements>> push ;

: append-segment ( section -- )
    <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 ( section -- )
    dup lines>> first line-segment-group? 
    [ push-segment-group ] [ append-segment ] if ;

: message-header ( sections -- header )
    "HEADER" section-named lines>> [ empty? not ] filter 3 tail
    [ ":" split [ [ blank? ] trim ] map ] map ;

: message-body ( sections -- root-group )
    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 ( root-group header -- message )
    <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 ( sections -- message )
    [ message-body ] [ message-header ] bi make-message-spec ;

! TODO
: parse-segment-spec ( sections -- message ) ;
: parse-composite-spec ( sections -- composites ) ;
: parse-element-spec ( sections -- elements ) ;

: assoc, ( value key -- ) swap 2array , ;
: message-xml-attrs ( message -- assoc )
    [
        {
            [ 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 ( segment -- assoc )
    [
        {
            [ id>> "id" assoc, ]
            [ name>> "name" assoc, ]
            [ repeat>> number>string "repeat" assoc, ]
            [ usage>> "usage" assoc, ]
        } cleave
    ] { } make ;

: segment-group-xml-attrs ( segment-group -- assoc )
    repeat>> number>string "repeat" swap 2array 1array ;

PRIVATE>

GENERIC: edifact-spec>xml ( object -- node )

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 ( path -- message ) 
    read-sections parse-message-spec ;
: segment-spec ( path -- segments ) 
    read-sections parse-segment-spec ;
: composite-spec ( path -- composites ) 
    read-sections parse-composite-spec ;
: element-spec ( path -- elements ) 
    read-sections parse-element-spec ;