Paste: model-tuples
Author: | jder |
Mode: | factor |
Date: | Fri, 20 Feb 2009 18:45:29 |
Plain Text |
MODEL-TUPLE: my-tuple a b c ;
1 2 3 <my-tuple>
dup b>> .
dup models>> a>> my-control swap add-connection
7 >>a
: make-raw-class
name>> "-model-raw" append create-class-in ;
: lookup-writer-word
"(>>" ")" surround "accessors" lookup ;
: lookup-reader-word
">>" append "accessors" lookup ;
SLOT: models
: writer-body '[ models>> _ execute set-model ] ;
: reader-body '[ models>> _ execute value>> ] ;
: constructor-body
[ '[ [ <model> ] _ napply ] ] 2dip
'[ _ boa _ boa ] append ;
: define-writer
[ lookup-writer-word create-method ] keep
lookup-reader-word writer-body define ;
: define-reader
lookup-reader-word
[ create-method ] keep
reader-body define ;
: define-accessors
[
[ define-writer ]
[ define-reader ] 2bi
] with each ;
: define-constructor
[ constructor-body ] keep
name>> "<" ">" surround create-in
swap define ;
:: define-model-tuple
[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
Author: | jder |
Mode: | factor |
Date: | Fri, 20 Feb 2009 20:47:24 |
Plain Text |
: lookup-writer-word
name>> "(>>" ")" surround "accessors" lookup ;
: lookup-reader-word
name>> ">>" append "accessors" lookup ;
: model-reader-word
name>> "-model>>" append "accessors" create ;
SLOT: models
: writer-body model-reader-word '[ _ execute set-model ] ;
: reader-body model-reader-word '[ _ execute value>> ] ;
: constructor-body
[ '[ [ <model> ] _ napply ] ] dip
'[ _ boa ] append ;
: define-model-reader
[ model-reader-word ] [ reader-quot ] [ reader-props ] tri define-typecheck ;
: override-writer
[ lookup-writer-word create-method ] keep
writer-body define ;
: override-reader
[ lookup-reader-word create-method ] keep
reader-body define ;
: override-accessors
[
[ define-model-reader ]
[ override-writer ]
[ override-reader ] 2tri
] with each ;
: define-constructor
[ constructor-body ] keep
name>> "<" ">" surround create-in
swap define ;
:: define-model-tuple
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