capture stdout in tests

This lets me uncomment a batch of tests that were previously commented
out.

Printing is still quite slow, so all of these tests are behind the
`slow` guard, but they do pass.

There is one strange exception:

    > (let x '(a b c)
        (while (pop x)
          (pr x)))
    (b c)(c)nilnil

Which instead outputs:

    (b c)(c)nil

I don't understand what's happening here yet, so that test stays
commented out for now.

package.yaml

@@ -20,6 +20,7 @@ default-extensions:
 - EmptyCase
 - FlexibleContexts
 - FlexibleInstances
+- GADTs
 - InstanceSigs
 - LambdaCase
 - MultiParamTypeClasses
@@ -85,8 +86,10 @@ tests:
     - -with-rtsopts=-N
     dependencies:
     - chime
+    - bytestring
     - hspec
     - HUnit
     - template-haskell
+    - text
     - time
     - transformers

src/Data.hs

@@ -8,6 +8,9 @@ import Control.Monad.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.State
 import Data.Bitraversable
+import qualified Data.ByteString as B
+import Data.Text (pack)
+import Data.Text.Encoding
 import System.IO
 
 import Common
@@ -28,12 +31,31 @@ data Pair r
 
 data Direction = In | Out deriving Eq
 
-data Stream = MkStream
-  { streamHandle :: Handle
-  , streamDirection :: Direction
-  , streamBuf :: Word8
-  , streamPlace :: Int
-  }
+class StreamBackend x where
+  hGet :: x -> Int -> IO B.ByteString
+  hPut :: x -> B.ByteString -> IO ()
+  hClose :: x -> IO ()
+
+instance StreamBackend Handle where
+  hGet = B.hGet
+  hPut = B.hPut
+  hClose = System.IO.hClose
+
+hPutStr :: StreamBackend x => x -> String -> IO ()
+hPutStr h = hPut h . encodeUtf8 . pack
+
+instance StreamBackend (IORef B.ByteString) where
+  hGet h n = readIORef h >>= \s -> writeIORef h (B.drop n s) $> B.take n s
+  hPut h s = modifyIORef h (`B.append` s)
+  hClose _ = pure ()
+
+data Stream where
+  MkStream :: StreamBackend x =>
+    { streamHandle :: x
+    , streamDirection :: Direction
+    , streamBuf :: Word8
+    , streamPlace :: Int
+    } -> Stream
 
 data OptimizedFunction r = MkOptimizedFunction
   { fnBody :: [Object IORef] -> EvalMonad (Maybe (Object IORef))
@@ -68,7 +90,7 @@ data EvalState = EvalState
 $(makeLenses ''EvalState)
 $(makePrisms ''Object)
 
-newStream :: (MonadRef m, Ref m ~ IORef) => Direction -> Handle -> m (IORef Stream)
+newStream :: (MonadRef m, Ref m ~ IORef, StreamBackend x) => Direction -> x -> m (IORef Stream)
 newStream d h = newRef (MkStream h d 0 7)
 
 emptyState :: (MonadRef m, Ref m ~ IORef) => m EvalState

src/Eval.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 module Eval where
 
-import BasePrelude as P hiding (evaluate, getEnv, head, tail, mask)
+import BasePrelude as P hiding (evaluate, getEnv, head, tail, mask, hClose)
 import Control.Lens.Combinators hiding (op)
 import Control.Lens.Operators hiding ((<|))
 import Control.Monad.Cont hiding (cont)
@@ -22,7 +22,7 @@ import Data.Time.Clock
 import System.Console.Haskeline
 import System.Directory
 import System.FilePath
-import System.IO
+import System.IO hiding (hPutStr, hClose)
 import qualified Text.Megaparsec as M
 import Text.Megaparsec.Error
 
@@ -145,7 +145,7 @@ nativeFns = fmap (second \f -> f { fnBody = traverse evaluate >=> fnBody f })
       nextByte :: Stream -> EvalMonad (Either (Object IORef) Word8)
       nextByte (MkStream h _ _ idx) =
         if idx == 7
-        then liftIO (B.unpack <$> B.hGet h 1) <&> \case
+        then liftIO (B.unpack <$> hGet h 1) <&> \case
           [] -> Left $ Sym 'e' "of"
           [x] -> Right x
           _ -> interpreterBug
@@ -604,7 +604,7 @@ primitives = (\p -> (primName p, p)) <$>
           in Symbol Nil <$
             if newIdx == 7
             then do
-              liftIO $ B.hPut h (B.singleton newBuf)
+              liftIO $ hPut h (B.singleton newBuf)
               writeRef ref $ MkStream h d 0 newIdx
             else
               writeRef ref $ MkStream h d newBuf newIdx
@@ -618,7 +618,7 @@ primitives = (\p -> (primName p, p)) <$>
              -- @incomplete: this blocks, and rdb should not block
              -- Fixing this will be difficult because the underlying Haskell interface
              -- does not support a non-blocking read that also reports EOF.
-             b <- liftIO $ B.hGet h 1
+             b <- liftIO $ hGet h 1
              case B.unpack b of
                [] -> pure $ Sym 'e' "of"
                -- [] -> pure $ Symbol Nil
@@ -648,7 +648,7 @@ primitives = (\p -> (primName p, p)) <$>
         if m == 7 || d == In
         then pure ()
         -- flush any bits left in the buffer
-        else B.hPut h (B.singleton b)
+        else hPut h (B.singleton b)
         hClose h
         pure $ Symbol Nil
       _ -> throwError "invalid argument to cls"

test/Spec.hs

@@ -2,6 +2,9 @@ module Main where
 
 import BasePrelude hiding ((>), (>>), (>>>))
 import Control.Monad.Trans.Maybe
+import qualified Data.ByteString as B
+import Data.Text (unpack)
+import Data.Text.Encoding
 import Data.Time.Clock
 import RawStringsQQ
 import Test.HUnit.Base
@@ -634,13 +637,11 @@ spec = do
       "(cons 'a 5)" `is` "(a . 5)"
       "(let x '(a b c) (cons x x))" `is` "(#1=(a b c) . #1)"
       "(append '(a b c) 5)" `is` "(a b c . 5)"
-
-      -- @incomplete: uncomment when tests capture stdout
-      -- "(with (x \"foo\" y 'bar) (prn 'x x 'y y))"
-        -- `is` "x \"foo\" y bar\nbar"
-      -- "(let user 'Dave (pr \"I'm sorry, \" user \". I'm afraid I can't do that.\"))"
-        -- `is` "I'm sorry, Dave. I'm afraid I can't do that."
-
+      "(with (x \"foo\" y 'bar) (prn 'x x 'y y))" `is` "x \"foo\" y bar \nbar"
+      slow {- 0.5 seconds -} $
+        -- slight deviation from the example in the spec to avoid double-printing
+        "(let user 'Dave (pr \"I'm sorry, \" user \". I'm afraid I can't do that\") \\!)"
+          `is` "I'm sorry, Dave. I'm afraid I can't do that\\!"
       slow {- 0.25 seconds -} $ "(drop 2 '(a b c d e))" `is` "(c d e)"
       "(nth 2 '(a b c d e))" `is` "b"
       "(2 '(a b c))" `is` "b"
@@ -665,23 +666,24 @@ spec = do
       "(map (upon 3.5) (list floor ceil))" `is` "(3 4)"
       "(mod 17 3)" `is` "2"
 
-      -- @incomplete: uncomment these when tests capture stdout
-      -- [r|
-      -- (let x '(a b c)
-      --   (whilet y (pop x)
-      --     (pr y))
-      --   x)
-      -- |] `is` "abcnil"
-      -- "(loop x 1 (+ x 1) (< x 5) (pr x))" `is` "1234nil"
+      slow {- 0.1 second -} $
+        [r|
+        (let x '(a b c)
+          (whilet y (pop x)
+            (pr y))
+          x)
+        |] `is` "abcnil"
+      slow {- 0.1 second -} $ "(loop x 1 (+ x 1) (< x 5) (pr x))" `is` "1234nil"
       -- "(let x '(a b c) (while (pop x) (pr x)))" `is` "(b c)(c)nilnil"
-      -- [r|
-      -- (let x '(a b c d e)
-      --   (til y (pop x) (= y 'c)
-      --     (pr y))
-      --   x)
-      -- |] `is` "ab(d e)"
-      -- "(for x 1 10 (pr x))" `is` "12345678910nil"
-      -- "(repeat 3 (pr 'bang))" `is` "bangbangbangnil"
+      slow {- 0.1 second -} $
+        [r|
+        (let x '(a b c d e)
+          (til y (pop x) (= y 'c)
+            (pr y))
+          x)
+        |] `is` "ab(d e)"
+      slow {- 0.2 seconds -} $ "(for x 1 10 (pr x))" `is` "12345678910nil"
+      slow {- 0.1 seconds -} $ "(repeat 3 (pr 'bang))" `is` "bangbangbangnil"
       [r|
       (let x '(a b c d e)
         (poll (pop x) is!c)
@@ -958,13 +960,17 @@ evalIn s state =
        pure
        x
 
+captureStdout :: EvalState -> IO (EvalState, IORef B.ByteString)
+captureStdout s = newIORef B.empty >>= \ref -> newStream Out ref <&>
+  \stream -> (s {_outs = stream}, ref)
+
 evalInShouldBe :: EvalState -> String -> String -> Expectation
-evalInShouldBe state a b =
-  readThenRunEval "test case" a state >>= \(x, postState) ->
+evalInShouldBe rawState a b = captureStdout rawState >>= \(state, stdout) ->
+  (,) <$> readThenRunEval "test case" a state <*> readRef stdout >>= \((x, postState), out) ->
     either
       (\e -> if b == "<error>" then pure () else
          failure $ a <> ": " <> e <> clear ("\n\nTrace:\n" <> stackTrace postState))
-      (repr >=> assertEqual ("> " <> a) b)
+      (repr >=> assertEqual ("> " <> a) b . (unpack (decodeUtf8 out) <>))
       x
 
 debugEvalInShouldBe :: EvalState -> String -> String -> Expectation