Simplify test server machinery

test/Spec.hs

@@ -1,135 +1,148 @@
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Main where
 
 --------------------------------------------------------------------------------
 
-import CofreeBot.Bot (fixBot)
-import CofreeBot.Bot.Behaviors
+import CofreeBot.Bot (Behavior, Bot (..), fixBot)
+import CofreeBot.Bot.Behaviors.Calculator
   ( calculatorBot,
-    helloSimpleBot,
     printCalcOutput,
     simplifyCalculatorBot,
   )
 import CofreeBot.Bot.Behaviors.Calculator.Language (statementP)
+import CofreeBot.Bot.Behaviors.Hello (helloSimpleBot)
 import CofreeBot.Bot.Context (sessionize, simplifySessionBot)
-import Scripts (mkScript)
-import Test.Hspec (Spec, describe, hspec, it, shouldBe)
-import TestServer (runTestScript)
+import Data.Text (Text, pack)
+import Scripts (Script, mkScript)
+import Test.Hspec (Spec, describe, hspec, it, shouldNotBe)
+import TestServer (Completion (..), conformsToScript, conformsToScript')
 
 --------------------------------------------------------------------------------
 
 main :: IO ()
 main = hspec $ do
+  scriptedTestsSpec
   helloBotSpec
   calculatorBotSpec
   sessionizedBotSpec
 
+scriptedTestsSpec :: Spec
+scriptedTestsSpec = describe "Scripted tests" $ do
+  let myBehavior :: forall m. Monad m => Behavior m Text Text
+      myBehavior = flip fixBot True $ Bot $ \s _ -> return (pack $ show s, not s)
+
+  it "can deal with bots that respond correctly" $ do
+    myBehavior
+      `conformsToScript` [mkScript|
+      >>>hello
+      <<<True
+      >>>whatever
+      <<<False
+      |]
+
+  it "can deal with bots that respond incorrectly" $ do
+    let script :: Script
+        script =
+          [mkScript|
+                 >>>hello
+                 <<<True
+                 >>>whatever
+                 <<<True
+                 |]
+    result <- myBehavior `conformsToScript'` script
+    result `shouldNotBe` Passed
+
 helloBotSpec :: Spec
 helloBotSpec =
   describe "Hello Bot" $ do
     let bot = helloSimpleBot
     it "responds to precisely its trigger phrase" $ do
-      let scenario =
-            [mkScript|
-            >>>cofree-bot
-            <<<Are you talking to me, punk?
-            |]
-      result <- runTestScript scenario $ fixBot bot ()
-      result `shouldBe` scenario
+      fixBot bot ()
+        `conformsToScript` [mkScript|
+        >>>cofree-bot
+        <<<Are you talking to me, punk?
+        |]
 
     it "responds to its trigger phrase embedded in a sentence" $ do
-      let scenario =
-            [mkScript|
-            >>>hows it going cofree-bot
-            <<<Are you talking to me, punk?
-            |]
-      result <- runTestScript scenario $ fixBot bot ()
-      result `shouldBe` scenario
+      fixBot bot ()
+        `conformsToScript` [mkScript|
+        >>>hows it going cofree-bot
+        <<<Are you talking to me, punk?
+        |]
 
 calculatorBotSpec :: Spec
 calculatorBotSpec =
   describe "Calculator Bot" $ do
     let bot = simplifyCalculatorBot calculatorBot
     it "performs arithmetic" $ do
-      let scenario =
-            [mkScript|
-            >>>(1 + 2)
-            <<<1 + 2 = 3
-            >>>(2 * 3)
-            <<<2 * 3 = 6
-            >>>((2 * 3) + 1)
-            <<<2 * 3 + 1 = 7
-            |]
-      result <- runTestScript scenario $ fixBot bot mempty
-      result `shouldBe` scenario
+      fixBot bot mempty
+        `conformsToScript` [mkScript|
+        >>>(1 + 2)
+        <<<1 + 2 = 3
+        >>>(2 * 3)
+        <<<2 * 3 = 6
+        >>>((2 * 3) + 1)
+        <<<2 * 3 + 1 = 7
+        |]
 
     it "can store values in state" $ do
-      let scenario =
-            [mkScript|
-            >>>x := (1 + 2)
-            <<<*variable saved*
-            >>>x
-            <<<"x" = 3
-            |]
-      result <- runTestScript scenario $ fixBot bot mempty
-      result `shouldBe` scenario
+      fixBot bot mempty
+        `conformsToScript` [mkScript|
+        >>>x := (1 + 2)
+        <<<*variable saved*
+        >>>x
+        <<<"x" = 3
+        |]
 
 sessionizedBotSpec :: Spec
 sessionizedBotSpec =
   describe "Sessionized Bot" $ do
     let bot = simplifySessionBot printCalcOutput statementP $ sessionize mempty $ calculatorBot
     it "can instantiate a session" $ do
-      let scenario =
-            [mkScript|
-            >>>new
-            <<<Session Started: '0'.
-            |]
-      result <- runTestScript scenario $ fixBot bot mempty
-      result `shouldBe` scenario
+      fixBot bot mempty
+        `conformsToScript` [mkScript|
+        >>>new
+        <<<Session Started: '0'.
+        |]
 
     it "can delete a session" $ do
-      let scenario =
-            [mkScript|
-            >>>new
-            <<<Session Started: '0'.
-            >>>end 0
-            <<<Session Ended: '0'.
-            |]
-      result <- runTestScript scenario $ fixBot bot mempty
-      result `shouldBe` scenario
+      fixBot bot mempty
+        `conformsToScript` [mkScript|
+        >>>new
+        <<<Session Started: '0'.
+        >>>end 0
+        <<<Session Ended: '0'.
+        |]
 
     it "preserves bot behavior" $ do
-      let scenario =
-            [mkScript|
-            >>>new
-            <<<Session Started: '0'.
-            >>>use 0: (1 + 2)  
-            <<<Session '0' Output:
-            1 + 2 = 3
-            |]
-      result <- runTestScript scenario $ fixBot bot mempty
-      result `shouldBe` scenario
+      fixBot bot mempty
+        `conformsToScript` [mkScript|
+        >>>new
+        <<<Session Started: '0'.
+        >>>use 0: (1 + 2)
+        <<<Session '0' Output:
+        1 + 2 = 3
+        |]
 
     it "tracks multiple sessions" $ do
-      let scenario =
-            [mkScript|
-            >>>new
-            <<<Session Started: '0'.
-            >>>new
-            <<<Session Started: '1'.
-            >>>use 0: x := (1 + 2)  
-            <<<Session '0' Output:
-            *variable saved*
-            >>>use 1: x := 42
-            <<<Session '1' Output:
-            *variable saved*
-            >>>use 0: x
-            <<<Session '0' Output:
-            "x" = 3
-            >>>use 1: x
-            <<<Session '1' Output:
-            "x" = 42
-            |]
-      result <- runTestScript scenario $ fixBot bot mempty
-      result `shouldBe` scenario
+      fixBot bot mempty
+        `conformsToScript` [mkScript|
+        >>>new
+        <<<Session Started: '0'.
+        >>>new
+        <<<Session Started: '1'.
+        >>>use 0: x := (1 + 2)
+        <<<Session '0' Output:
+        *variable saved*
+        >>>use 1: x := 42
+        <<<Session '1' Output:
+        *variable saved*
+        >>>use 0: x
+        <<<Session '0' Output:
+        "x" = 3
+        >>>use 1: x
+        <<<Session '1' Output:
+        "x" = 42
+        |]

test/TestServer.hs

@@ -1,13 +1,26 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wno-partial-fields #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
 module TestServer
-  ( runTestScript,
+  ( conformsToScript',
+    conformsToScript,
+    Completion (..),
   )
 where
 
 --------------------------------------------------------------------------------
 
 import CofreeBot.Bot
   ( Behavior (Behavior),
+    Env (..),
     Server (..),
+    annihilate,
+    fixEnv,
+    hoistBehavior,
+    hoistBot,
+    hoistServer,
     liftBehavior,
     loop,
   )
@@ -16,69 +29,70 @@ import Control.Monad.Except
   ( ExceptT,
     MonadError (..),
     MonadTrans (..),
+    liftEither,
     runExceptT,
   )
+import Control.Monad.IO.Class
 import Control.Monad.State
   ( MonadState,
     StateT (..),
     gets,
     modify,
   )
 import Data.Fix (Fix (..))
+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import Data.Text (Text)
+import Data.Void
 import Scripts
+import Test.Hspec (shouldBe)
 
 --------------------------------------------------------------------------------
 
-nextInput :: Monad m => StateT ([i], [Interaction i o]) m (Maybe i)
-nextInput =
-  gets fst >>= \case
-    [] -> pure Nothing
-    (i : xs) -> do
-      modify $ \(_, os) -> (xs, os)
-      pure (Just i)
-
-logResult :: Monad m => i -> [o] -> StateT ([i], [Interaction i o]) m ()
-logResult i os = modify $ \(inputs, results) -> (inputs, (results <> [Interaction i os]))
+data Completion i o
+  = Passed
+  | Failed {problematicInput :: i, expected :: [o], actual :: [o], remainder :: [Interaction i o]}
+  deriving (Show, Eq)
 
--- | A 'Server' which feeds a pre-programed series of inputs into
--- its paired bot.
-testServer :: Monad m => Server (StateT ([i], [Interaction i o]) m) o (Maybe i)
-testServer =
-  Server $ do
-    nextInput >>= \case
-      Nothing -> pure $ (Nothing, const $ Server $ runServer $ testServer)
-      Just input -> do
-        pure $ (Just input,) $ \os -> Server $ do
-          logResult input os
-          runServer $ testServer
+type ReplayServerState i o = Either (Completion i o) (NonEmpty (Interaction i o))
 
-type MaybeT m = ExceptT () m
+initReplayServerState :: Script -> ReplayServerState Text Text
+initReplayServerState (Script interactions) = case interactions of
+  [] -> Left Passed
+  x : xs -> Right $ x :| xs
 
-boundedAnnihilation ::
-  MonadState (([i], [Interaction i o])) m =>
-  Server m o (Maybe i) ->
-  Behavior m i o ->
-  Fix (MaybeT m)
-boundedAnnihilation (Server server) b@(Behavior botBehavior) = Fix $ do
-  lift server >>= \case
-    (Nothing, _nextServer) -> throwError ()
-    (Just i, nextServer) -> do
-      xs <- lift $ fromListT $ botBehavior i
-      let o = fmap fst xs
-          server' = nextServer o
-      pure $ boundedAnnihilation server' $ case xs of
-        [] -> b
-        _ -> snd (last xs)
+replayServer ::
+  (Eq o, MonadError (Completion i o) m) =>
+  ReplayServerState i o ->
+  Server m o i
+replayServer = fixEnv $ Env $ (liftEither .) $ \case
+  Left completion -> Left completion
+  Right (Interaction prompt expectedResponses :| rest) -> Right $ (prompt,) $ \actualResponses ->
+    if actualResponses == expectedResponses
+      then maybe (Left Passed) Right $ nonEmpty rest
+      else
+        Left $
+          Failed
+            { problematicInput = prompt,
+              expected = expectedResponses,
+              actual = actualResponses,
+              remainder = rest
+            }
 
-runTestScript :: Script -> Behavior IO Text Text -> IO Script
-runTestScript (Script script) bot =
-  fmap (Script . snd . snd) $
-    flip runStateT (inputs, []) $
-      runExceptT $
-        loop $
-          boundedAnnihilation
-            testServer
-            (liftBehavior bot)
+conformsToScript' :: Behavior IO Text Text -> Script -> IO (Completion Text Text)
+conformsToScript' behavior script = do
+  let server = replayServer (initReplayServerState script)
+  fmap onlyLeft $ runExceptT $ bindFix $ annihilate server (hoistBehavior lift behavior)
   where
-    inputs = fmap input script
+    -- TODO: move these somewhere else
+    bindFix :: Monad m => Fix m -> m Void
+    bindFix (Fix m) = m >>= bindFix
+
+    onlyLeft :: Either a Void -> a
+    onlyLeft = \case
+      Left x -> x
+      Right v -> absurd v
+
+conformsToScript :: Behavior IO Text Text -> Script -> IO ()
+conformsToScript behavior script = do
+  result <- behavior `conformsToScript'` script
+  result `shouldBe` Passed