Improve error messages for mirrors

core/debugger/debugger.factor

@@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
 classes.tuple continuations continuations.private combinators
 generic.math io.streams.duplex classes.builtin classes
 compiler.units generic.standard vocabs threads threads.private
-init kernel.private libc io.encodings accessors ;
+init kernel.private libc io.encodings mirrors accessors ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -289,6 +289,10 @@ M: encode-error summary drop "Character encoding error" ;
 
 M: decode-error summary drop "Character decoding error" ;
 
+M: no-such-slot summary drop "No such slot" ;
+
+M: immutable-slot summary drop "Slot is immutable" ;
+
 <PRIVATE
 
 : init-debugger ( -- )

core/mirrors/mirrors-docs.factor

@@ -37,10 +37,6 @@ HELP: <mirror>
     }
 } ;
 
-HELP: >mirror<
-{ $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Pushes the object being viewed in the mirror together with its slots." } ;
-
 HELP: make-mirror
 { $values { "obj" object } { "assoc" assoc } }
 { $description "Creates an assoc which reflects the internal structure of the object." } ;

core/mirrors/mirrors-tests.factor

@@ -1,4 +1,4 @@
-USING: mirrors tools.test assocs kernel arrays ;
+USING: mirrors tools.test assocs kernel arrays accessors ;
 IN: mirrors.tests
 
 TUPLE: foo bar baz ;
@@ -14,3 +14,15 @@ C: <foo> foo
 [ 3 ] [
     3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
 ] unit-test
+
+[ 3 "hi" 1 2 <foo> <mirror> set-at ] [
+    [ no-such-slot? ]
+    [ name>> "hi" = ]
+    [ object>> foo? ] tri and and
+] must-fail-with
+
+[ 3 "numerator" 1/2 <mirror> set-at ] [
+    [ immutable-slot? ]
+    [ name>> "numerator" = ]
+    [ object>> 1/2 = ] tri and and
+] must-fail-with

core/mirrors/mirrors.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs hashtables kernel sequences generic words
 arrays classes slots slots.private classes.tuple math vectors
-quotations sorting prettyprint ;
+quotations sorting prettyprint accessors ;
 IN: mirrors
 
 : all-slots ( class -- slots )
@@ -16,33 +16,32 @@ TUPLE: mirror object slots ;
 : <mirror> ( object -- mirror )
     dup object-slots mirror boa ;
 
-: >mirror< ( mirror -- obj slots )
-    dup mirror-object swap mirror-slots ;
+ERROR: no-such-slot object name ;
 
-: mirror@ ( slot-name mirror -- obj slot-spec )
-    >mirror< swapd slot-named ;
+ERROR: immutable-slot object name ;
 
 M: mirror at*
-    mirror@ dup [ slot-spec-offset slot t ] [ 2drop f f ] if ;
+    [ nip object>> ] [ slots>> slot-named ] 2bi
+    dup [ offset>> slot t ] [ 2drop f f ] if ;
 
 M: mirror set-at ( val key mirror -- )
-    mirror@ dup [
-        dup slot-spec-writer [
-            slot-spec-offset set-slot
+    [ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [
+        dup writer>> [
+            nip offset>> set-slot
         ] [
-            "Immutable slot" throw
+            drop immutable-slot
         ] if
     ] [
-        "No such slot" throw
+        drop no-such-slot
     ] if ;
 
 M: mirror delete-at ( key mirror -- )
     f -rot set-at ;
 
 M: mirror >alist ( mirror -- alist )
-    >mirror<
-    [ [ slot-spec-offset slot ] with map ] keep
-    [ slot-spec-name ] map swap zip ;
+    [ slots>> [ name>> ] map ]
+    [ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi
+    zip ;
 
 M: mirror assoc-size mirror-slots length ;
 
@@ -50,7 +49,7 @@ INSTANCE: mirror assoc
 
 : sort-assoc ( assoc -- alist )
     >alist
-    [ dup first unparse-short swap ] { } map>assoc
+    [ [ first unparse-short ] keep ] { } map>assoc
     sort-keys values ;
 
 GENERIC: make-mirror ( obj -- assoc )