Permalink
Browse files

addenda.classes.tuple: add clone-as, rename new-derived to clone-as*,…

… add error handling and docs
  • Loading branch information...
1 parent f63c580 commit 33b5aee9fc83b55a2951c0de89752148e6abcc61 @k7f committed Apr 16, 2012
@@ -0,0 +1,56 @@
+! Copyright (C) 2012 krzYszcz.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: assocs classes help.markup help.syntax kernel sequences ;
+IN: addenda.classes.tuple
+
+HELP: not-a-subclass
+{ $values
+ { "base-obj" object }
+ { "obj" object }
+ { "base-class" class }
+ { "class" class }
+}
+{ $description "" } ;
+
+HELP: clone-as
+{ $values
+ { "obj" object }
+ { "exemplar" object }
+ { "newobj" object }
+}
+{ $description "If " { $snippet "exemplar" } "'s class is derived from " { $snippet "obj" } "'s, outputs a newly-allocated tuple with the same values of base slots as " { $snippet "obj" } ", but of the same type and with the same values of remaining slots as " { $snippet "exemplar" } "." }
+{ $errors { $link not-a-subclass } " is thrown, if the class of " { $snippet "exemplar" } " is not a subclass of the class of " { $snippet "obj" } "." }
+{ $notes "This is similar to " { $link clone-like } ", which, however, preserves only the type of " { $snippet "exemplar" } ", but ignores its length. Overloading " { $link clone-like } " would lead to confusion anyway, because it is declared in " { $vocab-link "sequences" } "." }
+{ $see-also clone-as* } ;
+
+HELP: clone-as*
+{ $values
+ { "obj" object }
+ { "newslots" null }
+ { "newclass" class }
+ { "newobj" object }
+}
+{ $description "If " { $snippet "newclass" } " is derived from " { $snippet "obj" } "'s class, outputs a newly-allocated tuple with the same values of base slots as " { $snippet "obj" } ", but of the " { $snippet "newclass" } " type and with the values of remaining slots copied from " { $snippet "newslots" } "." }
+{ $errors { $link not-a-subclass } " is thrown, if the " { $snippet "newclass" } " is not a subclass of the class of " { $snippet "obj" } "." }
+{ $see-also clone-as } ;
+
+HELP: tuple>assoc
+{ $values
+ { "tuple" tuple }
+ { "assoc" assoc }
+}
+{ $description "" } ;
+
+HELP: supply-defaults
+{ $values
+ { "tuple" tuple }
+ { "defaults" assoc }
+ { "tuple'" tuple }
+}
+{ $description "" } ;
+
+ARTICLE: "addenda.classes.tuple" "addenda.classes.tuple"
+{ $vocab-link "addenda.classes.tuple" } ;
+
+ABOUT: "addenda.classes.tuple"
@@ -1,9 +1,30 @@
! Copyright (C) 2012 krzYszcz.
! See http://factorcode.org/license.txt for BSD license.
-USING: addenda.classes.tuple kernel tools.test ;
+USING: addenda.classes.tuple continuations kernel tools.test ;
IN: addenda.classes.tuple.tests
+TUPLE: base x ;
+TUPLE: derived < base y ;
+
+[ T{ derived f "b" "d" } ] [
+ "b" base boa f "d" derived boa clone-as
+] unit-test
+
+[ T{ not-a-subclass f T{ derived f f "d" } T{ base f "b" } derived base } ] [
+ "b" base boa f "d" derived boa swap
+ [ clone-as ] [ 2nip ] recover
+] unit-test
+
+[ T{ derived f "b" "d" } ] [
+ "b" base boa { "d" } derived clone-as*
+] unit-test
+
+[ T{ not-a-subclass f T{ derived f "b" "d" } f derived base } ] [
+ "b" "d" derived boa { "x" } base
+ [ clone-as* ] [ [ 3drop ] dip ] recover
+] unit-test
+
TUPLE: acbd a c b d ;
[ { { "a" f } { "c" f } { "b" f } { "d" f } } ] [
@@ -13,10 +34,3 @@ TUPLE: acbd a c b d ;
[ T{ acbd f f f t f } ] [
acbd new { { "b" t } } supply-defaults
] unit-test
-
-TUPLE: base x ;
-TUPLE: derived < base y ;
-
-[ T{ derived f "b" "d" } ] [
- "b" base boa { "d" } derived new-derived
-] unit-test
@@ -4,6 +4,23 @@
USING: accessors assocs classes classes.tuple kernel sequences ;
IN: addenda.classes.tuple
+ERROR: not-a-subclass base-obj obj base-class class ;
+
+GENERIC: clone-as ( obj exemplar -- newobj )
+
+M: tuple clone-as ( obj exemplar -- newobj )
+ [ dup class-of ] bi@ rot 2dup subclass-of? [
+ drop [
+ [ tuple-slots ] bi@
+ [ 0 swap copy ] keep
+ ] dip slots>tuple
+ ] [ swap not-a-subclass ] if ;
+
+: clone-as* ( obj newslots newclass -- newobj )
+ pick class-of 2dup subclass-of? [
+ drop [ tuple-slots ] [ append ] [ slots>tuple ] tri*
+ ] [ [ drop f ] 2dip swap not-a-subclass ] if ;
+
: tuple>assoc ( tuple -- assoc )
[ class-of all-slots [ name>> ] map ]
[ tuple-slots ] bi zip ;
@@ -14,6 +31,3 @@ IN: addenda.classes.tuple
first swap at [ f ] unless*
] if*
] with map swap class-of slots>tuple ;
-
-: new-derived ( obj newslots newclass -- newobj )
- [ tuple-slots ] [ append ] [ slots>tuple ] tri* ;

0 comments on commit 33b5aee

Please sign in to comment.