From 4d1560ed7ae047b75107aa78684a4cf829087ec5 Mon Sep 17 00:00:00 2001 From: Asad Saeeduddin Date: Sat, 7 Jan 2023 14:55:35 -0500 Subject: [PATCH] Simplify test server machinery --- test/Spec.hs | 187 ++++++++++++++++++++++++--------------------- test/TestServer.hs | 110 ++++++++++++++------------ 2 files changed, 162 insertions(+), 135 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 35da4bc..eaf950b 100644 --- a/test/Spec.hs +++ b/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 + <<>>whatever + <<>>hello + <<>>whatever + <<>>cofree-bot - <<>>cofree-bot + <<>>hows it going cofree-bot - <<>>hows it going cofree-bot + <<>>(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 - <<>>new + <<>>new - <<>>end 0 - <<>>new + <<>>end 0 + <<>>new - <<>>use 0: (1 + 2) - <<>>new + <<>>use 0: (1 + 2) + <<>>new - <<>>new - <<>>use 0: x := (1 + 2) - <<>>use 1: x := 42 - <<>>use 0: x - <<>>use 1: x - <<>>new + <<>>new + <<>>use 0: x := (1 + 2) + <<>>use 1: x := 42 + <<>>use 0: x + <<>>use 1: x + << 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