Paste: model-tuples

! Make a tuple that has a model for each slot,
! but you can use the normal >>foo and foo>> words 
! which get at the model values

! Example:
MODEL-TUPLE: my-tuple a b c ;
1 2 3 <my-tuple> ! constructor automatically defined
dup b>> . ! prints 2
dup models>> a>> my-control swap add-connection ! get at raw models
7 >>a ! will notify my-control

! Source:

: make-raw-class ( class -- raw-class )
    name>> "-model-raw" append create-class-in ;

: lookup-writer-word ( slot-name -- writer )
    "(>>" ")" surround "accessors" lookup ;

: lookup-reader-word ( slot-name -- reader )
    ">>" append "accessors" lookup ;

SLOT: models

: writer-body ( reader-word -- quot ) '[ models>> _ execute set-model ] ;
: reader-body ( reader-word -- quot ) '[ models>> _ execute value>> ] ;
: constructor-body ( num-slots raw-class class -- quot )
    [ '[ [ <model> ] _ napply ] ] 2dip
    '[ _ boa _ boa ] append ;

: define-writer ( class slot -- )
    [ lookup-writer-word create-method ] keep
    lookup-reader-word writer-body define ;

: define-reader ( class slot -- )
    lookup-reader-word
    [ create-method ] keep
    reader-body define ;

: define-accessors ( final-class slots -- )
    [
        [ define-writer ]
        [ define-reader ] 2bi
    ] with each ;

: define-constructor ( num-slots raw-class class -- )
    [ constructor-body ] keep
    name>> "<" ">" surround create-in
    swap define ;

:: define-model-tuple ( final-class superclass slots -- )
    [let | raw-class [ final-class make-raw-class ] |
        raw-class tuple slots define-tuple-class
        final-class superclass { "models" } define-tuple-class
        final-class slots define-accessors
        slots length raw-class final-class define-constructor
    ] ;


: MODEL-TUPLE: parse-tuple-definition define-model-tuple ; parsing

Annotation: New version, handles superclasses

! Example:
! MODEL-TUPLE: my-tuple a b c ;
! 1 2 3 <my-tuple> ! boa constructor automatically defined
! dup b>> . ! prints 2
! dup a-model>> my-control swap add-connection
! 7 >>a ! will notify my-control

: lookup-writer-word ( slot -- writer )
    name>> "(>>" ")" surround "accessors" lookup ;

: lookup-reader-word ( slot -- reader )
    name>> ">>" append "accessors" lookup ;

: model-reader-word ( slot -- model-reader-word )
    name>> "-model>>" append "accessors" create ;

SLOT: models

: writer-body ( slot -- quot ) model-reader-word '[ _ execute set-model ] ;
: reader-body ( slot -- quot ) model-reader-word '[ _ execute value>> ] ;
: constructor-body ( num-slots class -- quot )
    [ '[ [ <model> ] _ napply ] ] dip
    '[ _ boa ] append ;

: define-model-reader ( class slot -- )
    [ model-reader-word ] [ reader-quot ] [ reader-props ] tri define-typecheck ;

: override-writer ( class slot -- )
    [ lookup-writer-word create-method ] keep
    writer-body define ;

: override-reader ( class slot -- )
    [ lookup-reader-word create-method ] keep
    reader-body define ;

: override-accessors ( final-class slots -- )
    [
        [ define-model-reader ]
        [ override-writer ]
        [ override-reader ] 2tri
    ] with each ;

: define-constructor ( num-slots class -- )
    [ constructor-body ] keep
    name>> "<" ">" surround create-in
    swap define ;

:: define-model-tuple ( class superclass slots -- )
    class superclass slots define-tuple-class    
    [let | slots-with-super [ class all-slots ] |
        class slots-with-super override-accessors
        slots-with-super length class define-constructor ] ;


: MODEL-TUPLE: parse-tuple-definition define-model-tuple ; parsing

New Annotation