pprint structs with tuple syntax

diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor
index 103a5a72ec4f1d83245ccd0b2e47d8341d7318d6..cd759efb516977f826041d8064a11a076a8ccfdd 100644 (file)
--- a/basis/prettyprint/backend/backend.factor
+++ b/basis/prettyprint/backend/backend.factor
@@ -125,7 +125,7 @@ M: pathname pprint*
     ] if ; inline
 
 : tuple>assoc ( tuple -- assoc )
-    [ class all-slots ] [ tuple-slots ] bi zip
+    [ class class-slots ] [ object-slots ] bi zip
     [ [ initial>> ] dip = not ] assoc-filter
     [ [ name>> ] dip ] assoc-map ;
 
@@ -182,10 +182,12 @@ M: hashtable >pprint-sequence >alist ;
 M: wrapper >pprint-sequence wrapped>> 1array ;
 M: callstack >pprint-sequence callstack>array ;
 
-M: tuple >pprint-sequence
-    [ class ] [ tuple-slots ] bi
+: class-slot-sequence ( class slots -- sequence )
     [ 1array ] [ [ f 2array ] dip append ] if-empty ;
 
+M: tuple >pprint-sequence
+    [ class ] [ object-slots ] bi class-slot-sequence ;
+
 M: object pprint-narrow? drop f ;
 M: byte-vector pprint-narrow? drop f ;
 M: array pprint-narrow? drop t ;

diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 8e49e2f5f44990db37bfba9a42cf61dd95690111..9964df03c0ad6e034b4b06dbf5a4aa780db47ff1 100755 (executable)
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -18,6 +18,11 @@ ERROR: not-a-tuple object ;
 : all-slots ( class -- slots )
     superclasses [ "slots" word-prop ] map concat ;
 
+GENERIC: class-slots ( class -- slots )
+
+M: tuple-class class-slots
+    all-slots ;
+
 PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
     all-slots [ read-only>> ] all? ;
 
@@ -64,6 +69,10 @@ PRIVATE>
 : tuple-slots ( tuple -- seq )
     prepare-tuple>array drop copy-tuple-slots ;
 
+GENERIC: object-slots ( object -- seq )
+M: tuple object-slots
+    tuple-slots ;
+
 GENERIC: slots>tuple ( seq class -- tuple )
 
 M: tuple-class slots>tuple ( seq class -- tuple )

diff --git a/extra/classes/struct/prettyprint/prettyprint.factor b/extra/classes/struct/prettyprint/prettyprint.factor
index c0db8530c0be2b1fb6c08df648e2b929a68a82b0..22d48a0942359b4d5d69bd6de2aae7de8bdca962 100644 (file)
--- a/extra/classes/struct/prettyprint/prettyprint.factor
+++ b/extra/classes/struct/prettyprint/prettyprint.factor
@@ -8,4 +8,3 @@ M: struct-class see-class*
     <block "struct-slots" word-prop [ pprint-slot ] each
     block> pprint-; block> ;
 
-

diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor
index 9f99a6eb2219a2249dc7853c072e470befa8a424..8ae72625eb40522dc7ae6b6643b3e01d7e6a2469 100644 (file)
--- a/extra/classes/struct/struct.factor
+++ b/extra/classes/struct/struct.factor
@@ -2,9 +2,9 @@
 USING: accessors alien alien.c-types byte-arrays classes
 classes.c-types classes.parser classes.tuple
 classes.tuple.parser classes.tuple.private combinators
-combinators.smart fry generalizations kernel kernel.private
-libc macros make math math.order quotations sequences slots
-slots.private words ;
+combinators.smart fry generalizations generic.parser kernel
+kernel.private libc macros make math math.order quotations
+sequences slots slots.private words ;
 IN: classes.struct
 
 ! struct class
@@ -61,6 +61,19 @@ M: struct-class reader-quot
 M: struct-class writer-quot
     nip (writer-quot) ;
 
+M: struct-class class-slots
+    "struct-slots" word-prop ;
+
+: object-slots-quot ( class -- quot )
+    "struct-slots" word-prop
+    [ name>> reader-word 1quotation ] map
+    \ cleave [ ] 2sequence
+    \ output>array [ ] 2sequence ;
+
+: (define-object-slots-method) ( class -- )
+    [ \ object-slots create-method-in ]
+    [ object-slots-quot ] bi define ;
+
 ! Struct as c-type
 
 : align-offset ( offset class -- offset' )
@@ -124,7 +137,11 @@ M: struct-class heap-size
         make-slots dup
         [ check-struct-slots ] [ struct-offsets ] [ struct-align [ align ] keep ] tri
         (define-struct-class)
-    ] [ drop dup struct-prototype "prototype" set-word-prop ] 2tri ;
+    ] [
+        drop
+        [ dup struct-prototype "prototype" set-word-prop ]
+        [ (define-object-slots-method) ] bi
+    ] 2tri ;
 
 : parse-struct-definition ( -- class slots )
     CREATE-CLASS [ parse-tuple-slots ] { } make ;