change-tracking-tuple class. subclasses will have a "changed?" slot that gets set to true when any slot is modified

core/classes/classes-docs.factor

@@ -35,6 +35,7 @@ $nl
 "You can ask a class for its superclass:"
 { $subsection superclass }
 { $subsection superclasses }
+{ $subsection subclass-of? }
 "Class predicates can be used to test instances directly:"
 { $subsection "class-predicates" }
 "There is a universal class which all objects are an instance of, and an empty class with no instances:"
@@ -102,7 +103,21 @@ HELP: superclasses
     }
 } ;
 
-{ superclass superclasses } related-words
+HELP: subclass-of?
+{ $values
+    { "class" class }
+    { "superclass" class }
+    { "?" boolean }
+}
+{ $description "Outputs a boolean value indicating whether " { $snippet "class" } " is at any level a subclass of " { $snippet "superclass" } "." }
+{ $examples 
+    { $example "USING: classes classes.tuple prettyprint words ;"
+               "tuple-class \\ class subclass-of? ."
+               "t"
+    }
+} ;
+
+{ superclass superclasses subclass-of? } related-words
 
 HELP: members
 { $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }

core/classes/classes.factor

@@ -59,6 +59,9 @@ M: predicate reset-word
 : superclasses ( class -- supers )
     [ superclass ] follow reverse ;
 
+: subclass-of? ( class superclass -- ? )
+    swap superclasses member? ;
+
 : members ( class -- seq )
     #! Output f for non-classes to work with algebra code
     dup class? [ "members" word-prop ] [ drop f ] if ;

core/slots/slots.factor

@@ -26,8 +26,10 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
     [ drop define ]
     3bi ;
 
-: reader-quot ( slot-spec -- quot )
+GENERIC# reader-quot 1 ( class slot-spec -- quot )
-    [
+
+M: object reader-quot 
+    nip [
         dup offset>> ,
         \ slot ,
         dup class>> object bootstrap-word eq?
@@ -51,8 +53,12 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
 : define-reader ( class slot-spec -- )
     [ nip name>> define-reader-generic ]
     [
-        [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
+        {
-        define-typecheck
+            [ drop ]
+            [ nip name>> reader-word ]
+            [ reader-quot ]
+            [ nip reader-props ]
+        } 2cleave define-typecheck
     ] 2bi ;
 
 : writer-word ( name -- word )
@@ -83,8 +89,10 @@ ERROR: bad-slot-value value class ;
 : writer-quot/fixnum ( slot-spec -- )
     [ [ >fixnum ] dip ] % writer-quot/check ;
 
-: writer-quot ( slot-spec -- quot )
+GENERIC# writer-quot 1 ( class slot-spec -- quot )
-    [
+
+M: object writer-quot
+    nip [
         {
             { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] }
             { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] }
@@ -101,8 +109,12 @@ ERROR: bad-slot-value value class ;
 
 : define-writer ( class slot-spec -- )
     [ nip name>> define-writer-generic ] [
-        [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
+        {
-        define-typecheck
+            [ drop ]
+            [ nip name>> writer-word ]
+            [ writer-quot ]
+            [ nip writer-props ]
+        } 2cleave define-typecheck
     ] 2bi ;
 
 : setter-word ( name -- word )

extra/classes/tuple/change-tracking/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/classes/tuple/change-tracking/change-tracking-tests.factor

@@ -0,0 +1,10 @@
+USING: classes.tuple.change-tracking tools.test ;
+IN: classes.tuple.change-tracking.tests
+
+TUPLE: resource < change-tracking-tuple
+    { pathname string } ;
+
+: <resource> ( pathname -- resource ) f swap resource boa ;
+
+[ t ] [ "foo" <resource> "bar" >>pathname changed?>> ] unit-test
+[ f ] [ "foo" <resource> [ 123 >>pathname ] [ drop ] recover changed?>> ] unit-test

extra/classes/tuple/change-tracking/change-tracking.factor

@@ -0,0 +1,23 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors classes classes.tuple fry kernel sequences slots ;
+IN: classes.tuple.change-tracking
+
+TUPLE: change-tracking-tuple
+    { changed? boolean } ;
+
+PREDICATE: change-tracking-tuple-class < tuple-class
+    change-tracking-tuple subclass-of? ;
+
+: changed? ( tuple -- changed? ) changed?>> ; inline
+: clear-changed ( tuple -- tuple ) f >>changed? ; inline
+
+: filter-changed ( sequence -- sequence' ) [ changed? ] filter ; inline
+
+<PRIVATE
+
+M: change-tracking-tuple-class writer-quot ( class slot-spec -- )
+    [ call-next-method ]
+    [ name>> "changed?" = [ '[ _ [ t >>changed? drop ] bi ] ] unless ] bi ;
+
+PRIVATE>
+

extra/classes/tuple/change-tracking/summary.txt

@@ -0,0 +1 @@
+Tuple classes that keep track of when they've been modified