Implement and document stream-peek

basis/alien/data/data.factor

@@ -62,11 +62,13 @@ M: pointer <c-direct-array>
 : malloc-string ( string encoding -- alien )
     string>alien malloc-byte-array ;
 
-M: memory-stream stream-read
+M: memory-stream stream-peek
-    [
     [ index>> ] [ alien>> ] bi <displaced-alien>
-        swap memory>byte-array
+    swap memory>byte-array ;
-    ] [ [ + ] change-index drop ] 2bi ;
+
+M: memory-stream stream-read
+    [ stream-peek ]
+    [ [ + ] change-index drop ] 2bi ;
 
 M: value-type c-type-rep drop int-rep ;
 

basis/delegate/protocols/protocols.factor

@@ -13,7 +13,8 @@ at* assoc-size >alist set-at assoc-clone-like
 delete-at clear-assoc new-assoc assoc-like ;
 
 PROTOCOL: input-stream-protocol
-stream-read1 stream-read stream-read-partial stream-readln
+stream-peek1 stream-peek stream-read1 stream-read
+stream-read-partial stream-readln
 stream-read-until ;
 
 PROTOCOL: output-stream-protocol

basis/io/ports/ports-tests.factor

@@ -23,3 +23,8 @@ IN: io.ports.tests
 ] unit-test
 
 [ ] [ "test.txt" temp-file delete-file ] unit-test
+
+[ t ]
+[
+    "resource:license.txt" binary [ 10 peek 10 peek ] with-file-reader =
+] unit-test

basis/io/ports/ports.factor

@@ -84,6 +84,8 @@ M: input-port stream-read
         ] [ 2nip ] if
     ] [ 2nip ] if ;
 
+M: input-port stream-peek [ stream-read ] with-input-rewind ;
+
 : read-until-step ( separators port -- string/f separator/f )
     dup wait-to-read [ 2drop f f ] [ buffer>> buffer-until ] if ;
 

basis/io/streams/null/null.factor

@@ -14,6 +14,8 @@ M: null-reader stream-readln drop f ;
 M: null-reader stream-read1 drop f ;
 M: null-reader stream-read-until 2drop f f ;
 M: null-reader stream-read 2drop f ;
+M: null-reader stream-peek1 drop f ;
+M: null-reader stream-peek 2drop f ;
 
 M: null-writer stream-element-type drop +byte+ ;
 M: null-writer stream-write1 2drop ;

basis/io/streams/string/string.factor

@@ -13,6 +13,8 @@ M: string-reader stream-element-type drop +character+ ;
 M: string-reader stream-read-partial stream-read ;
 M: string-reader stream-read sequence-read ;
 M: string-reader stream-read1 sequence-read1 ;
+M: string-reader stream-peek sequence-peek ;
+M: string-reader stream-peek1 sequence-peek1 ;
 M: string-reader stream-read-until sequence-read-until ;
 M: string-reader stream-tell i>> ;
 M: string-reader stream-seek (stream-seek) ;

basis/io/streams/throwing/throwing.factor

@@ -20,10 +20,18 @@ M:: throws-on-eof-stream stream-read1 ( stream -- obj )
     stream stream>> stream-read1
     [ 1 stream \ read1 stream-exhausted ] unless* ;
 
+M:: throws-on-eof-stream stream-peek1 ( stream -- obj )
+    stream stream>> stream-peek1
+    [ 1 stream \ peek1 stream-exhausted ] unless* ;
+
 M:: throws-on-eof-stream stream-read ( n stream -- seq )
     n stream stream>> stream-read
     dup length n = [ n stream \ read stream-exhausted ] unless ;
 
+M:: throws-on-eof-stream stream-peek ( n stream -- seq )
+    n stream stream>> stream-peek
+    dup length n = [ n stream \ peek stream-exhausted ] unless ;
+
 M:: throws-on-eof-stream stream-read-partial ( n stream -- seq )
     n stream stream>> stream-read-partial
     [ n stream \ read-partial stream-exhausted ] unless* ;

core/io/encodings/encodings-tests.factor

@@ -73,3 +73,13 @@ unit-test
         output-stream get code>>
     ] with-byte-writer drop
 ] unit-test
+
+[ t ] [
+    "vocab:io/test/mac-os-eol.txt"
+    ascii [ 10 peek 10 peek = ] with-file-reader
+] unit-test
+
+[ t ] [
+    "vocab:io/test/mac-os-eol.txt"
+    ascii [ peek1 peek1 = ] with-file-reader
+] unit-test

core/io/encodings/encodings.factor

@@ -61,6 +61,9 @@ M: decoder stream-seek stream>> stream-seek ;
 M: decoder stream-read1
     dup >decoder< decode-char fix-read1 ;
 
+M: decoder stream-peek1 [ stream-read1 ] with-input-rewind ;
+M: decoder stream-peek [ stream-read ] with-input-rewind ;
+
 : fix-read ( stream string -- string )
     over cr>> [
         over cr-

core/io/io-docs.factor

@@ -262,6 +262,61 @@ HELP: contents
 { $description "Reads all elements in the " { $link input-stream } " until the stream is exhausted. The type of the sequence depends on the stream's element type." }
 $io-error ;
 
+HELP: peek
+{ $values
+    { "n" integer }
+    { "seq/f" "a sequence or f" }
+}
+{ $description "Reads the next " { $snippet "n" } " elements from the stream and seeks the stream to before the read." } ;
+
+HELP: peek1
+{ $values
+        { "elt" "an element or f" }
+}
+{ $description "Reads the next object from a stream and seeks the stream to before the read." } ;
+
+HELP: stream-peek
+{ $values
+    { "n" integer } { "stream" "an input stream" }
+    { "seq/f" "a sequence or f" }
+}
+{ $contract "Peeks " { $snippet "n" } " elements from the stream. Outputs " { $link f } " on stream exhaustion." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link peek } "; see " { $link "stdio" } "." }
+$io-error ;
+
+HELP: stream-peek1
+{ $values
+    { "stream" "an input stream" }
+    { "elt/f" "an element or f" }
+}
+{ $contract "Peeks an element from the stream. Outputs " { $link f } " on stream exhaustion." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link peek1 } "; see " { $link "stdio" } "." }
+$io-error ;
+
+HELP: tell-input
+{ $values
+        { "n" integer }
+}
+{ $description "Returns the index of the stream stored in " { $link input-stream } "." } ;
+
+HELP: tell-output
+{ $values
+        { "n" integer }
+}
+{ $description "Returns the index of the stream stored in " { $link output-stream } "." } ;
+
+HELP: with-input-rewind
+{ $values
+    { "quot" quotation }    
+}
+{ $description "Records the current seek position of the stream and calls the quotation. The position is then reset after the call." } ;
+
+HELP: with-input-seek
+{ $values
+    { "n" integer } { "seek-type" "a seek singleton" } { "quot" quotation }    
+}
+{ $description "Seeks the stream to a location, calls " { $snippet "quot" } ", and resets the input stream to where it was before the quotation was called." } ;
+
 ARTICLE: "stream-protocol" "Stream protocol"
 "The stream protocol consists of a large number of generic words, many of which are optional."
 $nl
@@ -271,6 +326,8 @@ $nl
 { $subsections "stream-types" }
 "These words are required for binary and string input streams:"
 { $subsections
+    stream-peek1
+    stream-peek
     stream-read1
     stream-read
     stream-read-until
@@ -290,6 +347,8 @@ $nl
 { $subsections
     stream-tell
     stream-seek
+    tell-input
+    tell-output
 }
 { $see-also "io.timeouts" } ;
 
@@ -338,6 +397,8 @@ ARTICLE: "stdio" "Default input and output streams"
 $nl
 "Words reading from the default input stream:"
 { $subsections
+    peek1
+    peek
     read1
     read
     read-until
@@ -376,6 +437,11 @@ $nl
     seek-relative
     seek-end
 }
+"Seeking combinators:"
+{ $subsections
+    with-input-seek
+    with-input-rewind
+}
 "A pair of combinators for rebinding the " { $link output-stream } " variable:"
 { $subsections
     with-output-stream

core/io/io.factor

@@ -8,7 +8,8 @@ SYMBOLS: +byte+ +character+ ;
 
 GENERIC: stream-element-type ( stream -- type )
 
-GENERIC: stream-peek1 ( stream -- byte/f )
+GENERIC: stream-peek1 ( stream -- elt/f )
+GENERIC: stream-peek ( n stream -- seq/f )
 GENERIC: stream-read1 ( stream -- elt )
 GENERIC: stream-read ( n stream -- seq )
 GENERIC: stream-read-until ( seps stream -- seq sep/f )
@@ -34,7 +35,8 @@ SYMBOL: input-stream
 SYMBOL: output-stream
 SYMBOL: error-stream
 
-: peek1 ( -- byte ) input-stream get stream-peek1 ;
+: peek1 ( -- elt ) input-stream get stream-peek1 ;
+: peek ( n -- seq/f ) input-stream get stream-peek ;
 : readln ( -- str/f ) input-stream get stream-readln ;
 : read1 ( -- elt ) input-stream get stream-read1 ;
 : read ( n -- seq ) input-stream get stream-read ;
@@ -72,6 +74,14 @@ SYMBOL: error-stream
     #! buffer before closing the FD.
     swapd [ with-output-stream ] curry with-input-stream ; inline
 
+: with-input-seek ( n seek-type quot -- )
+    tell-input [
+        [ seek-input ] dip call
+    ] dip seek-absolute seek-input ; inline
+
+: with-input-rewind ( quot -- )
+    [ 0 seek-absolute ] dip with-input-seek ; inline
+
 : print ( str -- ) output-stream get stream-print ;
 
 : bl ( -- ) " " write ;

core/io/streams/byte-array/byte-array-tests.factor

@@ -8,6 +8,7 @@ IN: io.streams.byte-array.tests
 [ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
 [ B{ 1 2 3 4 5 6 } ] [ binary [ B{ 1 2 3 } write B{ 4 5 6 } write ] with-byte-writer ] unit-test
 [ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
+[ B{ 1 2 } ] [ B{ 1 2 3 4 } binary [ 2 peek ] with-byte-reader ] unit-test
 
 [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
 [ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test

core/io/streams/byte-array/byte-array.factor

@@ -19,6 +19,7 @@ TUPLE: byte-reader { underlying byte-array read-only } { i array-capacity } ;
 M: byte-reader stream-element-type drop +byte+ ;
 
 M: byte-reader stream-peek1 sequence-peek1 ;
+M: byte-reader stream-peek sequence-peek ;
 M: byte-reader stream-read-partial stream-read ;
 M: byte-reader stream-read sequence-read ;
 M: byte-reader stream-read1 sequence-read1 ;

core/io/streams/c/c-tests.factor

@@ -34,6 +34,18 @@ IN: io.streams.c.tests
     int-array-cast
 ] unit-test
 
+[ t ] [
+    "test.txt" temp-file "rb" fopen <c-reader> [
+        3 4 * [ peek ] [ peek ] bi =
+    ] with-input-stream
+] unit-test
+
+[ t ] [
+    "test.txt" temp-file "rb" fopen <c-reader> [
+        peek1 peek1 =
+    ] with-input-stream
+] unit-test
+
 ! Writing strings to binary streams should fail
 [
     "test.txt" temp-file "wb" fopen <c-writer> [

core/io/streams/c/c.factor

@@ -47,10 +47,14 @@ M: c-reader stream-element-type drop +byte+ ;
 
 M: c-reader stream-read dup check-disposed handle>> fread ;
 
+M: c-reader stream-peek [ stream-read ] with-input-rewind ;
+
 M: c-reader stream-read-partial stream-read ;
 
 M: c-reader stream-read1 dup check-disposed handle>> fgetc ;
 
+M: c-reader stream-peek1 [ stream-read1 ] with-input-rewind ;
+
 : read-until-loop ( stream delim -- ch )
     over stream-read1 dup [
         dup pick member-eq? [ 2nip ] [ , read-until-loop ] if

core/io/streams/memory/memory.factor

@@ -10,6 +10,9 @@ TUPLE: memory-stream alien index ;
 
 M: memory-stream stream-element-type drop +byte+ ;
 
+M: memory-stream stream-peek1
+    [ alien>> ] [ index>> ] bi alien-unsigned-1 ;
+
 M: memory-stream stream-read1
-    [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
+    [ stream-peek1 ]
     [ [ 1 + ] change-index drop ] bi ;

extra/dns/dns.factor

@@ -11,11 +11,6 @@ nested-comments random sequences slots.syntax splitting strings
 system unicode.categories vectors vocabs.loader unicode.case ;
 IN: dns
 
-: with-temporary-input-seek ( n seek-type quot -- )
-    tell-input [
-        [ seek-input ] dip call
-    ] dip seek-absolute seek-input ; inline
-
 ENUM: dns-type
 { A 1 } { NS 2 } { MD 3 } { MF 4 }
 { CNAME 5 } { SOA 6 } { MB 7 } { MG 8 }
@@ -176,7 +171,7 @@ CONSTANT: ipv6-arpa-suffix ".ip6.arpa"
     ] [
         HEX: C0 mask? [
             2 read be> HEX: 3fff bitand
-            seek-absolute [ parse-length-bytes , (parse-name) ] with-temporary-input-seek
+            seek-absolute [ parse-length-bytes , (parse-name) ] with-input-seek
         ] [
             parse-length-bytes , (parse-name)
         ] if