Paste: Paste: [PATCH] extras/roles/roles-test.factor [REV2]

Author: mncharity
Mode: factor
Date: Mon, 12 Jul 2010 15:56:31
Plain Text | 
Add a (currently failing) test of method overriding. [REV2]

--- extra/roles/roles-tests.factor.orig	2010-07-08 19:39:57.000000000 -0400
+++ extra/roles/roles-tests.factor	2010-07-12 11:54:24.000000000 -0400
@@ -66,3 +66,23 @@
 
 [ "potato got poked" "potato got scooped" "potato got tuned" ]
 [ "potato" tuning-spork new [ poke ] [ scoop ] [ tune ] 2tri ] unit-test
+
+! test method overriding
+ROLE: Cx ;
+TUPLE: Ca ;
+TUPLE: Cb <{ Ca Cx } ;
+TUPLE: Cc <{ Cb } ;
+
+GENERIC: m1 ( a -- b )
+M: Ca m1 drop "m1a" ;
+M: Cx m1 drop "m1x" ;
+
+[ "m1a" ] [ Ca new m1 ] unit-test
+[ "m1x" ] [ Cb new m1 ] unit-test
+[ "m1x" ] [ Cc new m1 ] unit-test
+: f1a ( -- o ) Ca new m1 ;
+: f1b ( -- o ) Cb new m1 ;
+: f1c ( -- o ) Cc new m1 ;
+[ "m1a" ] [ f1a ] unit-test
+[ "m1x" ] [ f1b ] unit-test
+[ "m1x" ] [ f1c ] unit-test

Annotation: workaround

Author: j
Mode: factor
Date: Mon, 12 Jul 2010 16:29:41
Plain Text | 
ROLE: Cx ;
ROLE: Ca ;
TUPLE: Cai <{ Ca } ;
TUPLE: Cb <{ Ca Cx } ;
TUPLE: Cc <{ Cb } ;

GENERIC: m1 ( a -- b )
M: Ca m1 drop "m1a" ;
M: Cx m1 drop "m1x" ;

[ "m1a" ] [ Cai new m1 ] unit-test
[ "m1a" ] [ Cb new m1 ] unit-test
[ "m1a" ] [ Cc new m1 ] unit-test
: f1a ( -- o ) Cai new m1 ;
: f1b ( -- o ) Cb new m1 ;
: f1c ( -- o ) Cc new m1 ;
[ "m1a" ] [ f1a ] unit-test
[ "m1a" ] [ f1b ] unit-test
[ "m1a" ] [ f1c ] unit-test

Annotation: no overriding?

Author: mncharity
Mode: factor
Date: Mon, 12 Jul 2010 16:56:38
Plain Text | 
! Unit Test: { [ "m1x" ] [ Cb new m1 ] }
! fails.
! A ROLE tree doesn't seem to provide method overriding?

IN: exploring-workaround
USING: kernel prettyprint tools.test ;
USE: roles
FROM: roles => TUPLE: ;

ROLE: Cxr ;
ROLE: Car ;
TUPLE: Ca <{ Car } ;
ROLE: Cbr <{ Car Cxr } ;
TUPLE: Cb <{ Cbr } ;
ROLE: Ccr <{ Cbr } ;
TUPLE: Cc <{ Ccr } ;

GENERIC: m1 ( a -- b )
M: Car m1 drop "m1a" ;
M: Cxr m1 drop "m1x" ;

[ "m1a" ] [ Ca new m1 ] unit-test
[ "m1x" ] [ Cb new m1 ] unit-test
[ "m1x" ] [ Cc new m1 ] unit-test
: f1a ( -- o ) Ca new m1 ;
: f1b ( -- o ) Cb new m1 ;
: f1c ( -- o ) Cc new m1 ;
[ "m1a" ] [ f1a ] unit-test
[ "m1x" ] [ f1b ] unit-test
[ "m1x" ] [ f1c ] unit-test

New Annotation

Summary:
Author:
Mode:
Body: