Encodings use singletons; descriptive error updates

core/alien/strings/strings.factor

@@ -85,10 +85,10 @@ M: string-type c-type-getter
 M: string-type c-type-setter
     drop [ set-alien-cell ] ;
 
-TUPLE: utf16n ;
-
 ! Native-order UTF-16
 
+SINGLETON: utf16n
+
 : utf16n ( -- descriptor )
     little-endian? utf16le utf16be ? ; foldable
 

core/io/encodings/binary/binary.factor

@@ -3,6 +3,6 @@
 USING: io.encodings kernel ;
 IN: io.encodings.binary
 
-TUPLE: binary ;
+SINGLETON: binary
 M: binary <encoder> drop ;
 M: binary <decoder> drop ;

core/io/encodings/encodings-tests.factor

@@ -1,5 +1,6 @@
-USING: io.files io.streams.string io
+USING: io.files io.streams.string io io.streams.byte-array
-tools.test kernel io.encodings.ascii ;
+tools.test kernel io.encodings.ascii io.encodings.utf8
+namespaces accessors io.encodings ;
 IN: io.streams.encodings.tests
 
 [ { } ]
@@ -56,3 +57,19 @@ unit-test
      dup stream-readln drop
      stream-read1
 ] unit-test
+
+[ utf8 ascii ] [
+    "foo" utf8 [
+        input-stream get code>>
+        ascii decode-input
+        input-stream get code>>
+    ] with-byte-reader
+] unit-test
+
+[ utf8 ascii ] [
+    utf8 [
+        output-stream get code>>
+        ascii encode-output
+        output-stream get code>>
+    ] with-byte-writer drop
+] unit-test

core/io/encodings/encodings.factor

@@ -30,8 +30,7 @@ ERROR: encode-error ;
 
 <PRIVATE
 
-M: tuple-class <decoder> new <decoder> ;
+M: object <decoder> f decoder boa ;
-M: tuple <decoder> f decoder boa ;
 
 : >decoder< ( decoder -- stream encoding )
     [ stream>> ] [ code>> ] bi ;
@@ -104,8 +103,7 @@ M: decoder stream-readln ( stream -- str )
 M: decoder dispose decoder-stream dispose ;
 
 ! Encoding
-M: tuple-class <encoder> new <encoder> ;
+M: object <encoder> encoder boa ;
-M: tuple <encoder> encoder boa ;
 
 : >encoder< ( encoder -- stream encoding )
     [ stream>> ] [ code>> ] bi ;
@@ -121,13 +119,16 @@ M: encoder dispose encoder-stream dispose ;
 M: encoder stream-flush encoder-stream stream-flush ;
 
 INSTANCE: encoder plain-writer
+PRIVATE>
 
-! Rebinding duplex streams which have not read anything yet
+: re-encode ( stream encoding -- newstream )
-
-: reencode ( stream encoding -- newstream )
     over encoder? [ >r encoder-stream r> ] when <encoder> ;
 
-: redecode ( stream encoding -- newstream )
+: encode-output ( encoding -- )
+    output-stream [ swap re-encode ] change ;
+
+: re-decode ( stream encoding -- newstream )
     over decoder? [ >r decoder-stream r> ] when <decoder> ;
 
-PRIVATE>
+: decode-input ( encoding -- )
+    input-stream [ swap re-decode ] change ;

core/io/encodings/utf16/utf16-tests.factor

@@ -24,7 +24,7 @@ IN: io.encodings.utf16.tests
 [ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test
 
 : correct-endian
-    code>> class little-endian? [ utf16le = ] [ utf16be = ] if ;
+    code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
 
 [ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
 [ t ] [ utf16n <byte-writer> correct-endian ] unit-test

core/io/encodings/utf16/utf16.factor

@@ -4,11 +4,11 @@ USING: math kernel sequences sbufs vectors namespaces io.binary
 io.encodings combinators splitting io byte-arrays inspector ;
 IN: io.encodings.utf16
 
-TUPLE: utf16be ;
+SINGLETON: utf16be
 
-TUPLE: utf16le ;
+SINGLETON: utf16le
 
-TUPLE: utf16 ;
+SINGLETON: utf16
 
 <PRIVATE
 

core/io/encodings/utf8/utf8.factor

@@ -6,7 +6,7 @@ IN: io.encodings.utf8
 
 ! Decoding UTF-8
 
-TUPLE: utf8 ;
+SINGLETON: utf8
 
 <PRIVATE 
 

core/io/streams/string/string.factor

@@ -49,7 +49,7 @@ M: growable stream-read
 M: growable stream-read-partial
     stream-read ;
 
-TUPLE: null ;
+SINGLETON: null
 M: null decode-char drop stream-read1 ;
 
 : <string-reader> ( str -- stream )

extra/descriptive/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

extra/descriptive/descriptive-docs.factor

@@ -0,0 +1,22 @@
+USING: help.syntax help.markup ;
+IN: descriptive
+
+HELP: DESCRIPTIVE:
+{ $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" }
+{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
+
+HELP: DESCRIPTIVE::
+{ $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" }
+{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
+
+HELP: descriptive
+{ $class-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;
+
+ARTICLE: "descriptive" "Descriptive errors"
+"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in a special descriptor declaring that an error was thrown from inside that word, and including the arguments given to that word. The error is of the following class:"
+{ $subsection descriptive }
+"To define words which throw descriptive errors, use the following words:"
+{ $subsection POSTPONE: DESCRIPTIVE: }
+{ $subsection POSTPONE: DESCRIPTIVE:: } ;
+
+ABOUT: "descriptive"

extra/descriptive/descriptive-tests.factor

@@ -4,13 +4,13 @@ IN: descriptive.tests
 DESCRIPTIVE: divide ( num denom -- fraction ) / ;
 
 [ 3 ] [ 9 3 divide ] unit-test
-[ T{ known f H{ { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test
+[ T{ descriptive f { { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test
 
 [ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] [ \ divide [ see ] with-string-writer ] unit-test
 
 DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;
 
 [ 3 ] [ 9 3 divide* ] unit-test
-[ T{ known f H{ { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test
+[ T{ descriptive f { { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test
 
 [ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test

extra/descriptive/descriptive.factor

@@ -1,22 +1,23 @@
 USING: words kernel sequences combinators.lib locals
 locals.private accessors parser namespaces continuations
-inspector definitions ;
+inspector definitions arrays.lib arrays ;
 IN: descriptive
 
-ERROR: known args underlying word ;
+ERROR: descriptive args underlying word ;
 
-M: known summary
+M: descriptive summary
     word>> "The " swap word-name " word encountered an error."
     3append ;
 
+<PRIVATE
 : rethrower ( word inputs -- quot )
-    reverse [ [ set ] curry ] map concat [ ] like
+    [ length ] keep [ >r narray r> swap 2array flip ] 2curry
-    [ H{ } make-assoc ] curry
+    [ 2 ndip descriptive ] 2curry ;
-    [ 2 ndip known ] 2curry ;
 
 : [descriptive] ( word def -- newdef )
     swap dup "declared-effect" word-prop in>> rethrower
     [ recover ] 2curry ;
+PRIVATE>
 
 : define-descriptive ( word def -- )
     [ "descriptive-definition" set-word-prop ]
@@ -25,12 +26,12 @@ M: known summary
 : DESCRIPTIVE:
     (:) define-descriptive ; parsing
 
-PREDICATE: descriptive-word < word
+PREDICATE: descriptive-def < word
     "descriptive-definition" word-prop ;
 
-M: descriptive-word definer drop \ DESCRIPTIVE: \ ; ;
+M: descriptive-def definer drop \ DESCRIPTIVE: \ ; ;
 
-M: descriptive-word definition
+M: descriptive-def definition
     "descriptive-definition" word-prop ;
 
 : DESCRIPTIVE::

extra/descriptive/summary.txt

@@ -0,0 +1 @@
+Descriptive errors generated automatically for specially defined words

extra/io/encodings/ascii/ascii.factor

@@ -13,7 +13,7 @@ IN: io.encodings.ascii
     [ drop f ] if* ;
 PRIVATE>
 
-TUPLE: ascii ;
+SINGLETON: ascii
 
 M: ascii encode-char
     128 encode-if< ;

extra/io/streams/duplex/duplex.factor

@@ -47,7 +47,7 @@ M: duplex-stream dispose
     ] unless drop ;
 
 : <encoder-duplex> ( stream-in stream-out encoding -- duplex )
-    tuck reencode >r redecode r> <duplex-stream> ;
+    tuck re-encode >r re-decode r> <duplex-stream> ;
 
 : with-stream* ( stream quot -- )
     >r [ in>> ] [ out>> ] bi r> with-streams* ; inline