diff options
Diffstat (limited to 'lambda-calcul/haskell/test')
5 files changed, 82 insertions, 75 deletions
diff --git a/lambda-calcul/haskell/test/Minilang/IntegrationSpec.hs b/lambda-calcul/haskell/test/Minilang/IntegrationSpec.hs index ef05e20..d0265ac 100644 --- a/lambda-calcul/haskell/test/Minilang/IntegrationSpec.hs +++ b/lambda-calcul/haskell/test/Minilang/IntegrationSpec.hs @@ -6,8 +6,12 @@ import Control.Exception (bracket) import Data.Aeson (eitherDecodeFileStrict) import Data.Proxy (Proxy (..)) import Data.Text (Text) +import qualified Data.Text as Text import Minilang.API -import Minilang.REPL.Types (Evaluator (..)) +import Minilang.Lambda.Parser (pretty) +import Minilang.REPL (withInput, withInputs) +import Minilang.REPL.Purer (PurerEnv (..)) +import Minilang.REPL.Types (Command (Load), Content (..), Evaluator (..), In (Com), Out (..), initialREPL) import Minilang.Server (Server (..), startServer, stopServer) import Network.HTTP.Client (defaultManagerSettings, newManager) import Servant.API ((:<|>) (..)) @@ -89,12 +93,19 @@ spec = -- | Fetch the current challenge for the token, post the known answer, and -- assert the server accepted it (200 OK / no exception). solveChallenge :: ClientEnv -> Token -> Challenge -> IO () -solveChallenge env token Challenge{level, answer} = do +solveChallenge env token Challenge{level, expr} = do -- Confirm the server gives us the challenge we expect at this grade Challenge{level = serverLevel} <- runC env $ challengeClient (Just token) serverLevel `shouldBe` level -- Post the correct answer - runC env $ answerClient (Just token) answer + let PurerEnv{outputs} = withInputs initialREPL [Com (Load (Data expr))] + case outputs of + -- NOTE: Outputs are in reverse order, so the first output is the last one produced by the REPL. + (Bye : Evaluated ast _ _ : _) -> do + runC env $ answerClient (Just token) (pretty ast) + [Bye] -> + runC env $ answerClient (Just token) "" + answer -> fail $ "Unexpected answer format: " <> show answer -- --------------------------------------------------------------------------- -- Server lifecycle diff --git a/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs b/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs index 40866bb..0050973 100644 --- a/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs +++ b/lambda-calcul/haskell/test/Minilang/Lambda/ParserSpec.hs @@ -8,10 +8,9 @@ import Data.Either (isLeft, isRight) import Data.Function ((&)) import Data.Text (Text, pack) import qualified Data.Text as Text -import Minilang.Lambda.Eval (Term (Lam)) +import Minilang.Lambda.Eval (Term (Lam), normalise) import qualified Minilang.Lambda.Eval as Eval -import Minilang.Lambda.Parser (AST (..), desugar, initialChars, parse, parseProgram, pretty, restChars, escapeString) -import Minilang.Lambda.Eval (normalise) +import Minilang.Lambda.Parser (AST (..), desugar, escapeString, initialChars, parse, parseProgram, pretty, restChars) import Test.Hspec (Spec, describe, it, parallel, shouldBe, shouldSatisfy) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck ( @@ -91,13 +90,13 @@ spec = parallel $ do <> Text.concat ( map ( \(Identifier v, t) -> - "(" <> v <> " " <> pretty t <> ")" + "(" <> v <> " " <> pretty t <> ")\n" ) bound ) - <> ") " + <> ")\n " <> pretty body - <> ")" + <> ")\n" ) `shouldSatisfy` isRight @@ -370,8 +369,8 @@ genAst depth = -- logic is tested separately. genStrLit :: Gen AST genStrLit = StrLit . pack <$> listOf (elements safeChars) - where - safeChars = filter (\c -> c /= '"' && c /= '\\') [' '..'~'] + where + safeChars = filter (\c -> c /= '"' && c /= '\\') [' ' .. '~'] genDef :: Int -> Gen AST genDef n = Def . unIdent <$> arbitrary <*> genAst n diff --git a/lambda-calcul/haskell/test/Minilang/REPL/NetSpec.hs b/lambda-calcul/haskell/test/Minilang/REPL/NetSpec.hs index 6a2b1ab..2f8880a 100644 --- a/lambda-calcul/haskell/test/Minilang/REPL/NetSpec.hs +++ b/lambda-calcul/haskell/test/Minilang/REPL/NetSpec.hs @@ -1,6 +1,5 @@ module Minilang.REPL.NetSpec where --- import Control.Concurrent (threadDelay) import Control.Concurrent.Async import Control.Concurrent.STM.TVar import Control.Exception (bracket) @@ -46,48 +45,48 @@ withServer = runTestClient :: Int -> String -> [In] -> IO [Either String Out] runTestClient port envId inputs = runClient "127.0.0.1" port ("/repl/" <> envId) client - where - client cnx = do - outs <- forM inputs $ \inp -> do - WS.sendBinaryData cnx (encode inp) - eitherDecode <$> WS.receiveData cnx - WS.sendBinaryData cnx (encode EOF) - WS.sendClose cnx (encode ("" :: String)) - pure outs + where + client cnx = do + outs <- forM inputs $ \inp -> do + WS.sendBinaryData cnx (encode inp) + eitherDecode <$> WS.receiveData cnx + WS.sendBinaryData cnx (encode EOF) + WS.sendClose cnx (encode ("" :: String)) + pure outs temporaryFile :: (FilePath -> IO c) -> IO c temporaryFile = bracket newTempFile removeFile - where - newTempFile = do - dir <- getTemporaryDirectory - (f, h) <- mkstemp (dir </> "repl.test") - hClose h - pure f + where + newTempFile = do + dir <- getTemporaryDirectory + (f, h) <- mkstemp (dir </> "repl.test") + hClose h + pure f spec :: Spec spec = around withServer $ describe "MiniLang Network REPL" $ do - it "evaluates expression and returns evaluation result" $ \Server {serverPort} -> do + it "evaluates expression and returns evaluation result" $ \Server{serverPort} -> do let inp = [Com (Set (SelectLanguage Typed)), In "((lam (x) x) y)"] expectedOutput = - [ Right (Msg "Language set to Typed"), - Right $ Evaluated (AST.Sym "y") (Var "y") (TyVar "a") + [ Right (Msg "Language set to Typed") + , Right $ Evaluated (AST.Sym "y") (Var "y") (Just $ TyVar "a") ] res <- runTestClient serverPort ".newenv1" inp res `shouldBe` expectedOutput - it "allows retrieving empty initial env" $ \Server {serverPort} -> do + it "allows retrieving empty initial env" $ \Server{serverPort} -> do let inp = [Com (Set (SelectLanguage Typed)), Com DumpEnv] expectedOutput = - [ Right (Msg "Language set to Typed"), - Right $ CurrentEnv newEnv newContext Typed + [ Right (Msg "Language set to Typed") + , Right $ CurrentEnv newEnv newContext Typed ] res <- runTestClient serverPort ".newenv2" inp res `shouldBe` expectedOutput - it "can reconnect to existing environment" $ \Server {serverPort} -> do + it "can reconnect to existing environment" $ \Server{serverPort} -> do let inp = [In "Unit : U = Sum(tt)"] _ <- runTestClient serverPort ".newenv3" inp res <- runTestClient serverPort ".newenv3" [In "Unit"] @@ -95,5 +94,5 @@ spec = around withServer $ res `shouldSatisfy` isEvaluated isEvaluated :: [Either a Out] -> Bool -isEvaluated [Right (Evaluated _ _ _)] = True +isEvaluated [Right Evaluated{}] = True isEvaluated _ = False diff --git a/lambda-calcul/haskell/test/Minilang/REPLSpec.hs b/lambda-calcul/haskell/test/Minilang/REPLSpec.hs index e382df4..1754cdb 100644 --- a/lambda-calcul/haskell/test/Minilang/REPLSpec.hs +++ b/lambda-calcul/haskell/test/Minilang/REPLSpec.hs @@ -1,11 +1,9 @@ module Minilang.REPLSpec where import Control.Exception (bracket) -import Data.Either (isRight) import Data.Text.IO import Minilang.Lambda.Eval (Term (Lam, Var)) import Minilang.Lambda.Parser (AST (..)) -import Minilang.Lambda.Unify (Type (TyVar)) import Minilang.REPL import Minilang.REPL.Purer (PurerEnv (..)) import Minilang.REPL.Run (loadProgramInEnv) @@ -26,8 +24,8 @@ spec = parallel $ ["((lam (x) x) y)"] out - `shouldBe` [ "Bye!", - "y : <?>" + `shouldBe` [ "Bye!" + , "y" ] it "evaluates untyped MiniLang terms with definitions" $ do @@ -36,24 +34,24 @@ spec = parallel $ ["(def id (lam (x) x))", "(id y)"] out - `shouldBe` [ "Bye!", - "y : <?>", - "id : <?>" + `shouldBe` [ "Bye!" + , "y" + , "id" ] it "evaluates typed MiniLang terms with definitions" $ do let out = withInput - [ ":lang Typed", - "(def id (lam (x) x))", - "(id y)" + [ ":lang Typed" + , "(def id (lam (x) x))" + , "(id y)" ] out - `shouldBe` [ "Bye!", - "y : a", - "id : a -> a", - "Language set to Typed" + `shouldBe` [ "Bye!" + , "y : a" + , "id : a -> a" + , "Language set to Typed" ] it "defaults untyped terms" $ do @@ -65,58 +63,58 @@ spec = parallel $ ] out - `shouldBe` [ "Bye!", - "(lam (z s) (s (lam (z s) (s (lam (z s) z))))) : <?>" + `shouldBe` [ "Bye!" + , "(lam (z s) (s (lam (z s) (s (lam (z s) z)))))" ] it "do typecheck term when language is set to 'Typed'" $ do let out = withInput - [ ":lang Typed", - "(let ((Succ (lam (n z s) (s n))) \ + [ ":lang Typed" + , "(let ((Succ (lam (n z s) (s n))) \ \ (Zero (lam (z s) z))) \ \ (Succ (Succ Zero)))" ] out - `shouldBe` [ "Bye!", - "(lam (z s) (s (lam (z s) (s (lam (z s) z))))) : a -> ((c -> ((e -> f -> e) -> g) -> g) -> h) -> h", - "Language set to Typed" + `shouldBe` [ "Bye!" + , "(lam (z s) (s (lam (z s) (s (lam (z s) z))))) : a -> ((c -> ((e -> f -> e) -> g) -> g) -> h) -> h" + , "Language set to Typed" ] it "shows error when trying to load a non-existent file" $ do withInput [":load foo"] - `shouldBe` [ "Bye!", - "REPLError \"cannot load file foo in Pure interpreter\"" + `shouldBe` [ "Bye!" + , "REPLError \"cannot load file foo in Pure interpreter\"" ] it "can load 'bool-prog.lisp'" $ do boolProg <- readFile "bool-prog.lisp" - let PurerEnv {outputs} = runProgram (loadProgramInEnv boolProg) + let PurerEnv{outputs} = runProgram (loadProgramInEnv boolProg) outputs - `shouldBe` [ Evaluated (Abs ["f", "t"] (Sym "t")) (Lam "f" (Lam "t" (Var "t"))) (TyVar "<?>"), - Evaluated (Abs ["f", "t"] (Sym "f")) (Lam "f" (Lam "t" (Var "f"))) (TyVar "<?>"), - Evaluated (Abs ["f", "t"] (Sym "f")) (Lam "f" (Lam "t" (Var "f"))) (TyVar "<?>") + `shouldBe` [ Evaluated (Abs ["f", "t"] (Sym "t")) (Lam "f" (Lam "t" (Var "t"))) Nothing + , Evaluated (Abs ["f", "t"] (Sym "f")) (Lam "f" (Lam "t" (Var "f"))) Nothing + , Evaluated (Abs ["f", "t"] (Sym "f")) (Lam "f" (Lam "t" (Var "f"))) Nothing ] it "can load 'bool.lisp'" $ do boolProg <- readFile "bool.lisp" - let PurerEnv {outputs} = runProgram (loadProgramInEnv boolProg) + let PurerEnv{outputs} = runProgram (loadProgramInEnv boolProg) outputs `shouldBe` [ Evaluated (Abs ["f", "t"] (Sym "f")) (Lam "f" (Lam "t" (Var "f"))) - (TyVar "<?>") + Nothing ] it "can load 'fac.lisp'" $ do boolProg <- readFile "fac.lisp" - let PurerEnv {outputs} = runProgram (loadProgramInEnv boolProg) + let PurerEnv{outputs} = runProgram (loadProgramInEnv boolProg) outputs `shouldBe` [ Evaluated (Abs ["f", "t"] (Sym "t")) (Lam "f" (Lam "t" (Var "t"))) - (TyVar "<?>") + Nothing ] around withTempFile $ @@ -136,11 +134,11 @@ spec = parallel $ out <- readFile outputFileName out - `shouldBe` "\955\928> (lam (z s) (s (lam (z s) z))) : <?>\n\955\928> Bye!\n" + `shouldBe` "\955\928> (lam (z s) (s (lam (z s) z)))\n\955\928> Bye!\n" withTempFile :: (String -> IO ()) -> IO () withTempFile = bracket mkTempFile rmTempFile - where - mkTempFile = getTemporaryDirectory >>= \dir -> mkstemp (dir </> "test-repl") >>= \(fp, h) -> hClose h >> pure fp - rmTempFile fn = removeFile fn >> removeFile (fn <.> "out") + where + mkTempFile = getTemporaryDirectory >>= \dir -> mkstemp (dir </> "test-repl") >>= \(fp, h) -> hClose h >> pure fp + rmTempFile fn = removeFile fn >> removeFile (fn <.> "out") diff --git a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs index 2860c40..8d0b182 100644 --- a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs +++ b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs @@ -51,7 +51,7 @@ spec = with (app testSeed) $ do it "GET /api/leaderboard returns empty list of scores at start" $ do get "/api/leaderboard" - `shouldRespondWith` 200 {matchBody = arrayOfLengthOf (Proxy @Score) 0} + `shouldRespondWith` 200{matchBody = arrayOfLengthOf (Proxy @Score) 0} it "POST /api/register returns registration token given user is not registered" $ do postJSON "/api/register" alice @@ -66,7 +66,7 @@ spec = with (app testSeed) $ do it "GET /api/leaderboard returns list of one element after user registers" $ do void $ postJSON "/api/register" alice get "/api/leaderboard" - `shouldRespondWith` 200 {matchBody = arrayOfLengthOf (Proxy @Score) 1} + `shouldRespondWith` 200{matchBody = arrayOfLengthOf (Proxy @Score) 1} it "POST /api/register returns 400 given user is already registered" $ do void $ postJSON "/api/register" alice @@ -84,7 +84,7 @@ spec = with (app testSeed) $ do `shouldRespondWith` 404 it "GET /api/challenge returns next challenge given user is registered" $ do - let expected = LT.unpack $ decodeUtf8 $ encode $ Challenge {level = 0, expr = "x", description = "A lone free variable. What does x reduce to?", answer = "x"} + let expected = LT.unpack $ decodeUtf8 $ encode $ Challenge{level = 0, expr = "x", description = "A lone free variable. What does x reduce to?"} postJSON "/api/register" alice `shouldRespondWith` 201 @@ -123,7 +123,7 @@ spec = with (app testSeed) $ do `shouldRespondWith` 400 it "GET /api/challenge returns next level challenge after successful POST" $ do - let expected = LT.unpack $ decodeUtf8 $ encode $ Challenge {level = 1, expr = "y", description = "Another free variable. What does y reduce to?", answer = "y"} + let expected = LT.unpack $ decodeUtf8 $ encode $ Challenge{level = 1, expr = "y", description = "Another free variable. What does y reduce to?"} void $ postJSON "/api/register" alice void $ postJSON ("/api/challenge?token=" <> LBS.toStrict token) "\"x\"" @@ -147,7 +147,7 @@ spec = with (app testSeed) $ do { matchBody = MatchBody $ \_ actual -> case eitherDecode actual of Right (score :: Score) -> - if score == Score {user = User "alice", grade = 0, lastTest = Nothing, lastResult = Nothing} + if score == Score{user = User "alice", grade = 0, lastTest = Nothing, lastResult = Nothing} then Nothing else Just $ "Expected score with grade 0, but got " ++ show score Left err -> Just $ "Failed to decode JSON: " ++ err @@ -190,7 +190,7 @@ spec = with (app testSeed) $ do postJSON :: BS.ByteString -> ByteString -> WaiSession () SResponse postJSON url = request "POST" url [("Content-Type", "application/json")] -arrayOfLengthOf :: forall elem proxy. (FromJSON elem) => proxy elem -> Int -> MatchBody +arrayOfLengthOf :: forall elem proxy. FromJSON elem => proxy elem -> Int -> MatchBody arrayOfLengthOf _ len = MatchBody $ \_ actual -> case eitherDecode actual of Right (scores :: [elem]) -> |