diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Eval.hs | 39 | ||||
| -rw-r--r-- | src/Helper.hs | 2 | ||||
| -rw-r--r-- | src/Parser.hs | 20 | ||||
| -rw-r--r-- | src/Reducer.hs | 4 |
4 files changed, 58 insertions, 7 deletions
diff --git a/src/Eval.hs b/src/Eval.hs index 47ca4ca..c65bf0e 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -47,6 +47,14 @@ evalDefine name exp = Right f -> modify ((name, f) :) >> pure (Right f) ) +evalTest :: Expression -> Expression -> Program (Failable Instruction) +evalTest exp1 exp2 = + evalExp exp1 + >>= (\case + Left exp1 -> pure $ Left exp1 + Right exp1 -> fmap (Test exp1) <$> evalExp exp2 + ) + eval :: [String] -> Environment -> IO Environment eval [] env = pure env eval (line : ls) env = case parse parseLine "FILE" line of @@ -56,7 +64,21 @@ eval (line : ls) env = case parse parseLine "FILE" line of let (res, env') = evalDefine name exp `runState` env in case res of Left err -> print err >> eval ls env' - Right _ -> (putStrLn $ name <> " = " <> show exp) >> eval ls env' + Right _ -> eval ls env' + Test exp1 exp2 -> + let (res, _) = evalTest exp1 exp2 `runState` env + in case res of + Left err -> putStrLn (show err) >> pure env + Right (Test exp1' exp2') -> + when + (reduce exp1' /= reduce exp2') + ( putStrLn + $ "ERROR: test failed: " + <> (show exp1) + <> " != " + <> (show exp2) + ) + >> eval ls env _ -> eval ls env evalFunc :: String -> Environment -> IO Environment @@ -65,6 +87,7 @@ evalFunc func env = case lookup func env of Just exp -> (print $ reduce exp) >> pure env -- TODO: Less duplicate code (liftIO?) +-- TODO: Generally improve eval code evalRepl :: String -> Environment -> InputT IO Environment evalRepl line env = case parse parseReplLine "REPL" line of Left err -> outputStrLn (show err) >> pure env @@ -97,6 +120,20 @@ evalRepl line env = case parse parseReplLine "REPL" line of Left exception -> print (exception :: IOError) >> pure env Right file -> eval (filter (not . null) $ lines file) [] >>= pure ) + Test exp1 exp2 -> + let (res, _) = evalTest exp1 exp2 `runState` env + in case res of + Left err -> outputStrLn (show err) >> pure env + Right (Test exp1' exp2') -> + when + (reduce exp1' /= reduce exp2') + ( outputStrLn + $ "ERROR: test failed: " + <> (show exp1) + <> " != " + <> (show exp2) + ) + >> pure env _ -> pure env evalFile :: String -> IO () diff --git a/src/Helper.hs b/src/Helper.hs index 5e02a94..57fb9f4 100644 --- a/src/Helper.hs +++ b/src/Helper.hs @@ -14,7 +14,7 @@ type Failable = Either Error data Expression = Bruijn Int | Variable String | Abstraction Expression | Application Expression Expression deriving (Ord, Eq) -data Instruction = Define String Expression | Evaluate Expression | Comment String | Load String +data Instruction = Define String Expression | Evaluate Expression | Comment String | Load String | Test Expression Expression deriving (Show) instance Show Expression where show (Bruijn x ) = show x diff --git a/src/Parser.hs b/src/Parser.hs index 6fbeca4..33b3c44 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -6,7 +6,7 @@ module Parser import Control.Monad ( ap ) import Data.Functor.Identity import Helper -import Text.Parsec +import Text.Parsec hiding ( parseTest ) import Text.Parsec.Language import qualified Text.Parsec.Token as Token @@ -107,9 +107,23 @@ parseComment = string "#" >> Comment <$> almostAnything parseLoad :: Parser Instruction parseLoad = string ":load " >> Load <$> almostAnything +parseTest :: Parser Instruction +parseTest = do + string ":test " + exp1 <- parseExpression + spaces + reservedOp "=" + spaces + exp2 <- parseExpression + pure $ Test exp1 exp2 + parseLine :: Parser Instruction -parseLine = try parseDefine <|> parseComment +parseLine = try parseDefine <|> try parseComment <|> try parseTest parseReplLine :: Parser Instruction parseReplLine = - try parseReplDefine <|> parseComment <|> parseEvaluate <|> parseLoad + try parseReplDefine + <|> try parseComment + <|> try parseEvaluate + <|> try parseLoad + <|> try parseTest diff --git a/src/Reducer.hs b/src/Reducer.hs index 809687b..a7c544a 100644 --- a/src/Reducer.hs +++ b/src/Reducer.hs @@ -20,11 +20,11 @@ bind :: Expression -> Expression -> Int -> Expression bind exp (Bruijn x) n = if x == n then exp else Bruijn x bind exp (Application exp1 exp2) n = Application (bind exp exp1 n) (bind exp exp2 n) -bind exp (Abstraction exp') n = Abstraction (bind (exp <-> 0) exp' (succ n)) +bind exp (Abstraction exp') n = Abstraction (bind (exp <-> (-1)) exp' (succ n)) step :: Expression -> Expression step (Bruijn exp ) = Bruijn exp -step (Application (Abstraction exp) app ) = (bind (app <-> 0) exp 0) <+> 0 +step (Application (Abstraction exp) app ) = (bind (app <-> (-1)) exp 0) <+> 0 step (Application exp1 exp2) = Application (step exp1) (step exp2) step (Abstraction exp ) = Abstraction (step exp) |