diff --git a/package.yaml b/package.yaml index 9387d37..14e463d 100644 --- a/package.yaml +++ b/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 diff --git a/src/Data.hs b/src/Data.hs index fcb50c1..25b6478 100644 --- a/src/Data.hs +++ b/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 diff --git a/src/Eval.hs b/src/Eval.hs index ba863f7..f341c50 100644 --- a/src/Eval.hs +++ b/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" diff --git a/test/Spec.hs b/test/Spec.hs index ff3e8b9..142d04e 100644 --- a/test/Spec.hs +++ b/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 == "" 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