0.2.0
Includes better error handling, additional tests, parsing and lexing fixes to match the desired behavior defined by the new tests, and a very basic REPL implementation.
This commit is contained in:
parent
a61627f333
commit
c16c48b22c
@ -1,7 +1,7 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
name: sapling
|
||||
version: 0.1.0
|
||||
version: 0.2.0
|
||||
description: Tree Calculus experiment repository
|
||||
author: James Eversole
|
||||
maintainer: james@eversole.co
|
||||
@ -34,6 +34,7 @@ executable sapling
|
||||
Eval
|
||||
Lexer
|
||||
Parser
|
||||
REPL
|
||||
Research
|
||||
default-language: Haskell2010
|
||||
|
||||
@ -54,4 +55,5 @@ test-suite sapling-tests
|
||||
Eval
|
||||
Lexer
|
||||
Parser
|
||||
REPL
|
||||
Research
|
||||
|
30
src/Eval.hs
30
src/Eval.hs
@ -6,31 +6,31 @@ import Research
|
||||
import qualified Data.Map as Map
|
||||
import Data.Map (Map)
|
||||
|
||||
evalSapling :: Map String T -> SaplingAST -> Map String T
|
||||
evalSapling env TLeaf = Map.insert "__result" Leaf env
|
||||
evalSapling env (TStem t) =
|
||||
evalSingle :: Map String T -> SaplingAST -> Map String T
|
||||
evalSingle env TLeaf = Map.insert "__result" Leaf env
|
||||
evalSingle env (TStem t) =
|
||||
let result = Stem (evalTreeCalculus env t)
|
||||
in Map.insert "__result" result env
|
||||
evalSapling env (TFork t1 t2) =
|
||||
evalSingle env (TFork t1 t2) =
|
||||
let result = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2)
|
||||
in Map.insert "__result" result env
|
||||
evalSapling env (SFunc name [] body) =
|
||||
evalSingle env (SFunc name [] body) =
|
||||
let value = evalTreeCalculus env body
|
||||
in Map.insert name value env
|
||||
evalSapling env (SVar name) =
|
||||
evalSingle env (SVar name) =
|
||||
case Map.lookup name env of
|
||||
Just value -> Map.insert "__result" value env
|
||||
Nothing -> error $ "Variable " ++ name ++ " not defined"
|
||||
evalSapling env ast = Map.insert "__result" (evalTreeCalculus env ast) env
|
||||
evalSingle env ast = Map.insert "__result" (evalTreeCalculus env ast) env
|
||||
|
||||
evalMulti :: Map String T -> [SaplingAST] -> Map String T
|
||||
evalMulti env [] = env
|
||||
evalMulti env [lastLine] =
|
||||
let updatedEnv = evalSapling env lastLine
|
||||
evalSapling :: Map String T -> [SaplingAST] -> Map String T
|
||||
evalSapling env [] = env
|
||||
evalSapling env [lastLine] =
|
||||
let updatedEnv = evalSingle env lastLine
|
||||
in Map.insert "__result" (result updatedEnv) updatedEnv
|
||||
evalMulti env (line:rest) =
|
||||
let updatedEnv = evalSapling env line
|
||||
in evalMulti updatedEnv rest
|
||||
evalSapling env (line:rest) =
|
||||
let updatedEnv = evalSingle env line
|
||||
in evalSapling updatedEnv rest
|
||||
|
||||
evalTreeCalculus :: Map.Map String T -> SaplingAST -> T
|
||||
evalTreeCalculus _ TLeaf = Leaf
|
||||
@ -51,7 +51,7 @@ evalTreeCalculus _ (SList elems) = toList (map (evalTreeCalculus Map.empty) elem
|
||||
evalTreeCalculus _ (SFunc name args body) =
|
||||
error $ "Unexpected function definition " ++ name ++ " in \
|
||||
\ evalTreeCalculus; functions should be evaluated to Tree Calculus \
|
||||
\ terms by evalSapling."
|
||||
\ terms by evalSingle."
|
||||
|
||||
result :: Map String T -> T
|
||||
result r = case (Map.lookup "__result" r) of
|
||||
|
22
src/Lexer.hs
22
src/Lexer.hs
@ -4,7 +4,9 @@ import Research
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import Data.Void
|
||||
import qualified Data.Set as Set
|
||||
|
||||
-- Lexer type and tokens
|
||||
type Lexer = Parsec Void String
|
||||
data LToken
|
||||
= LKeywordT
|
||||
@ -19,6 +21,7 @@ data LToken
|
||||
| LNewline
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- Lexical rules
|
||||
keywordT :: Lexer LToken
|
||||
keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
|
||||
|
||||
@ -38,8 +41,11 @@ stringLiteral :: Lexer LToken
|
||||
stringLiteral = do
|
||||
char '"'
|
||||
content <- many (noneOf ['"'])
|
||||
char '"' --"
|
||||
return (LStringLiteral content)
|
||||
if null content
|
||||
then fail "Empty string literals are not allowed"
|
||||
else do
|
||||
char '"' -- "
|
||||
return (LStringLiteral content)
|
||||
|
||||
assign :: Lexer LToken
|
||||
assign = char '=' *> pure LAssign
|
||||
@ -59,13 +65,15 @@ closeBracket = char ']' *> pure LCloseBracket
|
||||
lnewline :: Lexer LToken
|
||||
lnewline = char '\n' *> pure LNewline
|
||||
|
||||
-- Whitespace consumer
|
||||
sc :: Lexer ()
|
||||
sc = skipMany (char ' ' <|> char '\t')
|
||||
|
||||
-- Lexer definition
|
||||
saplingLexer :: Lexer [LToken]
|
||||
saplingLexer = many (sc *> choice
|
||||
[ try keywordT
|
||||
, try identifier
|
||||
[ try identifier
|
||||
, try keywordT
|
||||
, try integerLiteral
|
||||
, try stringLiteral
|
||||
, assign
|
||||
@ -74,8 +82,10 @@ saplingLexer = many (sc *> choice
|
||||
, openBracket
|
||||
, closeBracket
|
||||
, lnewline
|
||||
]) <* eof
|
||||
] <* sc) <* eof
|
||||
|
||||
-- Lexing function with enhanced error handling
|
||||
lexSapling :: String -> [LToken]
|
||||
lexSapling input = case runParser saplingLexer "" input of
|
||||
Left err -> error "Failed to lex input"
|
||||
Left err -> error $ "Lexical error:\n" ++ errorBundlePretty err
|
||||
Right tokens -> tokens
|
||||
|
@ -3,14 +3,11 @@ module Main where
|
||||
import Eval
|
||||
import Lexer
|
||||
import Parser
|
||||
import REPL (repl)
|
||||
import Research
|
||||
|
||||
import Data.Map as Map
|
||||
import Text.Megaparsec (runParser)
|
||||
|
||||
main :: IO ()
|
||||
main = putStr
|
||||
$ show
|
||||
$ result
|
||||
$ evalMulti Map.empty (parseMulti
|
||||
"false = t\nnot = t (t (t t) (t t t)) t\ntrue = not false\ntrue")
|
||||
main = repl Map.empty --(Map.fromList [("__result", Leaf)])
|
||||
|
@ -1,10 +1,15 @@
|
||||
module Parser where
|
||||
|
||||
import Lexer
|
||||
import Research
|
||||
import Research hiding (toList)
|
||||
|
||||
import Control.Exception (throw)
|
||||
import Data.List.NonEmpty (toList)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Void
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import Data.Void
|
||||
import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle)
|
||||
|
||||
type Parser = Parsec Void [LToken]
|
||||
data SaplingAST
|
||||
@ -19,10 +24,15 @@ data SaplingAST
|
||||
| TFork SaplingAST SaplingAST
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
parseSapling :: String -> SaplingAST
|
||||
parseSapling "" = error "Empty input provided to parseSapling"
|
||||
parseSapling input = case runParser parseExpression "" (lexSapling input) of
|
||||
Left err -> error "Failed to parse input"
|
||||
parseSapling :: String -> [SaplingAST]
|
||||
parseSapling input =
|
||||
let nonEmptyLines = filter (not . null) (lines input)
|
||||
in map parseSingle nonEmptyLines
|
||||
|
||||
parseSingle :: String -> SaplingAST
|
||||
parseSingle "" = error "Empty input provided to parseSingle"
|
||||
parseSingle input = case runParser parseExpression "" (lexSapling input) of
|
||||
Left err -> error $ handleParseError err
|
||||
Right ast -> ast
|
||||
|
||||
scnParser :: Parser ()
|
||||
@ -48,7 +58,7 @@ parseFunction = do
|
||||
parseApplication :: Parser SaplingAST
|
||||
parseApplication = do
|
||||
func <- parseAtomicBase
|
||||
args <- many parseAtomic
|
||||
args <- many parseAtomicApplication
|
||||
case func of
|
||||
TLeaf | not (null args) && all isTreeTerm args -> fail "Defer to Tree Calculus"
|
||||
_ -> return (SApp func args)
|
||||
@ -66,7 +76,7 @@ parseAtomicBase = choice
|
||||
]
|
||||
|
||||
parseTreeLeaf :: Parser SaplingAST
|
||||
parseTreeLeaf = satisfy isKeywordT *> pure TLeaf
|
||||
parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf
|
||||
|
||||
getIdentifier :: LToken -> String
|
||||
getIdentifier (LIdentifier name) = name
|
||||
@ -86,7 +96,7 @@ parseTreeTerm = do
|
||||
parseTreeLeafOrParenthesized :: Parser SaplingAST
|
||||
parseTreeLeafOrParenthesized = choice
|
||||
[ between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseTreeTerm
|
||||
, satisfy isKeywordT *> pure TLeaf
|
||||
, parseTreeLeaf
|
||||
]
|
||||
|
||||
foldTree :: [SaplingAST] -> SaplingAST
|
||||
@ -103,6 +113,22 @@ parseAtomic = choice
|
||||
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
|
||||
]
|
||||
|
||||
parseAtomicApplication :: Parser SaplingAST
|
||||
parseAtomicApplication = do
|
||||
token <- anySingle
|
||||
case token of
|
||||
LAssign -> fail
|
||||
"Unexpected `=` character in application context. \
|
||||
\ This is usually caused by an incomplete definition such as: \
|
||||
\ `function a b =`"
|
||||
LIdentifier name -> return (SVar name)
|
||||
LKeywordT -> return TLeaf
|
||||
LIntegerLiteral value -> return (SInt value)
|
||||
LStringLiteral value -> return (SStr value)
|
||||
LOpenBracket -> parseListLiteral
|
||||
LOpenParen -> between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
|
||||
_ -> fail "Invalid token while parsing attempted function application"
|
||||
|
||||
parseLiteral :: Parser SaplingAST
|
||||
parseLiteral = choice
|
||||
[ parseIntLiteral
|
||||
@ -125,21 +151,21 @@ parseListLiteral = do
|
||||
|
||||
parseListItem :: Parser SaplingAST
|
||||
parseListItem = choice
|
||||
[ parseGroupedItem -- Handle expressions inside parentheses
|
||||
, parseListLiteral -- Allow nested lists
|
||||
, parseSingleItem -- Handle single tokens like `t` or identifiers
|
||||
[ parseGroupedItem
|
||||
, parseListLiteral
|
||||
, parseSingleItem
|
||||
]
|
||||
|
||||
parseGroupedItem :: Parser SaplingAST
|
||||
parseGroupedItem = do
|
||||
satisfy (== LOpenParen)
|
||||
satisfy (== LOpenParen)
|
||||
inner <- parseExpression
|
||||
satisfy (== LCloseParen)
|
||||
return inner
|
||||
|
||||
parseSingleItem :: Parser SaplingAST
|
||||
parseSingleItem = do
|
||||
token <- satisfy isListItem
|
||||
token <- satisfy isListItem
|
||||
case token of
|
||||
LIdentifier name -> return (SVar name)
|
||||
LKeywordT -> return TLeaf
|
||||
@ -151,9 +177,11 @@ isListItem LKeywordT = True
|
||||
isListItem _ = False
|
||||
|
||||
parseVar :: Parser SaplingAST
|
||||
parseVar = do
|
||||
parseVar = do
|
||||
LIdentifier name <- satisfy isIdentifier
|
||||
return (SVar name)
|
||||
if (name == "t" || name == "__result")
|
||||
then fail $ "Reserved keyword: " ++ name ++ " cannot be assigned."
|
||||
else return (SVar name)
|
||||
|
||||
parseIntLiteral :: Parser SaplingAST
|
||||
parseIntLiteral = do
|
||||
@ -165,11 +193,6 @@ parseStrLiteral = do
|
||||
LStringLiteral value <- satisfy isStringLiteral
|
||||
return (SStr value)
|
||||
|
||||
parseMulti :: String -> [SaplingAST]
|
||||
parseMulti input =
|
||||
let nonEmptyLines = filter (not . null) (lines input)
|
||||
in map parseSapling nonEmptyLines
|
||||
|
||||
-- Boolean Helpers
|
||||
isKeywordT (LKeywordT) = True
|
||||
isKeywordT _ = False
|
||||
@ -183,5 +206,27 @@ isIntegerLiteral _ = False
|
||||
isStringLiteral (LStringLiteral _) = True
|
||||
isStringLiteral _ = False
|
||||
|
||||
isNewline (LNewline) = True
|
||||
isLiteral (LIntegerLiteral _) = True
|
||||
isLiteral (LStringLiteral _) = True
|
||||
isLiteral _ = False
|
||||
|
||||
esNewline (LNewline) = True
|
||||
isNewline _ = False
|
||||
|
||||
-- Error Handling
|
||||
handleParseError :: ParseErrorBundle [LToken] Void -> String
|
||||
handleParseError bundle =
|
||||
let errors = bundleErrors bundle
|
||||
errorList = toList errors
|
||||
formattedErrors = map showError errorList
|
||||
in unlines ("Parse error(s) encountered:" : formattedErrors)
|
||||
|
||||
showError :: ParseError [LToken] Void -> String
|
||||
showError (TrivialError offset (Just (Tokens tokenStream)) expected) =
|
||||
"Parse error at offset " ++ show offset ++ ": unexpected token "
|
||||
++ show tokenStream ++ ", expected one of " ++ show (Set.toList expected)
|
||||
showError (FancyError offset fancy) =
|
||||
"Parse error at offset " ++ show offset ++ ":\n " ++ unlines (map show (Set.toList fancy))
|
||||
showError (TrivialError offset Nothing expected) =
|
||||
"Parse error at offset " ++ show offset ++ ": expected one of "
|
||||
++ show (Set.toList expected)
|
||||
|
25
src/REPL.hs
Normal file
25
src/REPL.hs
Normal file
@ -0,0 +1,25 @@
|
||||
module REPL where
|
||||
|
||||
import Eval
|
||||
import Lexer
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
import Control.Monad (void)
|
||||
import qualified Data.Map as Map
|
||||
import System.IO (hFlush, stdout)
|
||||
|
||||
repl :: Map.Map String T -> IO ()
|
||||
repl env = do
|
||||
putStr "sapling > "
|
||||
hFlush stdout
|
||||
input <- getLine
|
||||
if input == "_:exit"
|
||||
then putStrLn "Goodbye!"
|
||||
else do
|
||||
let clearEnv = Map.delete "__result" env
|
||||
let newEnv = evalSingle clearEnv (parseSingle input)
|
||||
case Map.lookup "__result" newEnv of
|
||||
Just r -> putStrLn $ "sapling < " ++ show r
|
||||
Nothing -> pure ()
|
||||
repl newEnv
|
@ -24,8 +24,8 @@ reduce expr =
|
||||
|
||||
step :: T -> T
|
||||
step (Fork left right) = reduce (apply (reduce left) (reduce right))
|
||||
step (Stem inner) = Stem (reduce inner)
|
||||
step t = t
|
||||
step (Stem inner) = Stem (reduce inner)
|
||||
step t = t
|
||||
|
||||
-- SKI Combinators
|
||||
_S :: T
|
||||
@ -54,20 +54,20 @@ toString str = toList (map toNumber (map fromEnum str))
|
||||
ofString :: T -> String
|
||||
ofString tc = map (toEnum . ofNumber) (ofList tc)
|
||||
|
||||
toNumber :: Int -> T
|
||||
toNumber :: Int -> T
|
||||
toNumber 0 = Leaf
|
||||
toNumber n =
|
||||
Fork
|
||||
(if odd n then Stem Leaf else Leaf)
|
||||
(toNumber (n `div` 2))
|
||||
(toNumber (n `div` 2))
|
||||
|
||||
ofNumber :: T -> Int
|
||||
ofNumber Leaf = 0
|
||||
ofNumber (Fork Leaf rest) = 2 * ofNumber rest
|
||||
ofNumber (Fork (Stem Leaf) rest) = 1 + 2 * ofNumber rest
|
||||
ofNumber _ = error "Invalid Tree Calculus number"
|
||||
ofNumber _ = error "Invalid Tree Calculus number"
|
||||
|
||||
toList :: [T] -> T
|
||||
toList :: [T] -> T
|
||||
toList [] = Leaf
|
||||
toList (x:xs) = Fork x (toList xs)
|
||||
|
||||
@ -92,13 +92,13 @@ toAscii tree = go tree "" True
|
||||
++ go right (prefix ++ (if isLast then " " else "| ")) True
|
||||
|
||||
rules :: IO ()
|
||||
rules = putStr $ header
|
||||
++ (unlines $ tcRules)
|
||||
rules = putStr $ header
|
||||
++ (unlines $ tcRules)
|
||||
++ (unlines $ haskellRules)
|
||||
++ footer
|
||||
where
|
||||
tcRules :: [String]
|
||||
tcRules =
|
||||
tcRules =
|
||||
[ "| |"
|
||||
, "| ┌--------- | Tree Calculus | ---------┐ |"
|
||||
, "| | 1. t t a b -> a | |"
|
||||
|
175
test/Spec.hs
175
test/Spec.hs
@ -28,195 +28,215 @@ lexerTests :: TestTree
|
||||
lexerTests = testGroup "Lexer Tests"
|
||||
[ testCase "Lex simple identifiers" $ do
|
||||
let input = "x a b = a"
|
||||
let expected = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
|
||||
runParser saplingLexer "" input @?= expected
|
||||
let expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
|
||||
runParser saplingLexer "" input @?= expect
|
||||
|
||||
, testCase "Lex Tree Calculus terms" $ do
|
||||
let input = "t t t"
|
||||
let expected = Right [LKeywordT, LKeywordT, LKeywordT]
|
||||
runParser saplingLexer "" input @?= expected
|
||||
|
||||
, testCase "Handle invalid input" $ do
|
||||
let input = "x = "
|
||||
case runParser saplingLexer "" input of
|
||||
Left _ -> return ()
|
||||
Right _ -> assertFailure "Expected failure on invalid input"
|
||||
let expect = Right [LKeywordT, LKeywordT, LKeywordT]
|
||||
runParser saplingLexer "" input @?= expect
|
||||
|
||||
, testCase "Lex escaped characters in strings" $ do
|
||||
let input = "\"hello\\nworld\""
|
||||
let expected = Right [LStringLiteral "hello\\nworld"]
|
||||
runParser saplingLexer "" input @?= expected
|
||||
let expect = Right [LStringLiteral "hello\\nworld"]
|
||||
runParser saplingLexer "" input @?= expect
|
||||
|
||||
, testCase "Lex mixed literals" $ do
|
||||
let input = "t \"string\" 42"
|
||||
let expected = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
|
||||
runParser saplingLexer "" input @?= expected
|
||||
let expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
|
||||
runParser saplingLexer "" input @?= expect
|
||||
|
||||
, testCase "Lex invalid token" $ do
|
||||
let input = "$invalid"
|
||||
case runParser saplingLexer "" input of
|
||||
Left _ -> return ()
|
||||
Right _ -> assertFailure "Expected lexer to fail on invalid token"
|
||||
|
||||
, testCase "Drop trailing whitespace in definitions" $ do
|
||||
let input = "x = 5 "
|
||||
let expect = [LIdentifier "x",LAssign,LIntegerLiteral 5]
|
||||
case (runParser saplingLexer "" input) of
|
||||
Left _ -> assertFailure "Failed to lex input"
|
||||
Right i -> i @?= expect
|
||||
|
||||
, testCase "Error when using invalid characters in identifiers" $ do
|
||||
case (runParser saplingLexer "" "__result = 5") of
|
||||
Left _ -> return ()
|
||||
Right _ -> assertFailure "Expected failure when trying to assign the value of __result"
|
||||
]
|
||||
|
||||
parserTests :: TestTree
|
||||
parserTests = testGroup "Parser Tests"
|
||||
[ testCase "Parse function definitions" $ do
|
||||
[ testCase "Error when parsing incomplete definitions" $ do
|
||||
let input = lexSapling "x = "
|
||||
case (runParser parseExpression "" input) of
|
||||
Left _ -> return ()
|
||||
Right _ -> assertFailure "Expected failure on invalid input"
|
||||
|
||||
, testCase "Error when assigning a value to T" $ do
|
||||
let input = lexSapling "t = x"
|
||||
case (runParser parseExpression "" input) of
|
||||
Left _ -> return ()
|
||||
Right _ -> assertFailure "Expected failure when trying to assign the value of T"
|
||||
|
||||
, testCase "Error when parsing bodyless definitions with arguments" $ do
|
||||
let input = lexSapling "x a b = "
|
||||
case (runParser parseExpression "" input) of
|
||||
Left _ -> return ()
|
||||
Right _ -> assertFailure "Expected failure on invalid input"
|
||||
|
||||
, testCase "Parse function definitions" $ do
|
||||
let input = "x a b = a"
|
||||
let expected = SFunc "x" ["a", "b"] (SApp (SVar "a") [])
|
||||
parseSapling input @?= expected
|
||||
let expect = SFunc "x" ["a", "b"] (SApp (SVar "a") [])
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse nested Tree Calculus terms" $ do
|
||||
let input = "t (t t) t"
|
||||
let expected = TFork (TStem TLeaf) TLeaf
|
||||
parseSapling input @?= expected
|
||||
let expect = TFork (TStem TLeaf) TLeaf
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse sequential Tree Calculus terms" $ do
|
||||
let input = "t t t"
|
||||
let expected = TFork TLeaf TLeaf
|
||||
parseSapling input @?= expected
|
||||
let expect = TFork TLeaf TLeaf
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse mixed list literals" $ do
|
||||
-- You must put non-list literals in parentheses
|
||||
let input = "[t (\"hello\") t]"
|
||||
let expected = SList [TLeaf, SStr "hello", TLeaf]
|
||||
parseSapling input @?= expected
|
||||
let expect = SList [TLeaf, SStr "hello", TLeaf]
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse function with applications" $ do
|
||||
let input = "f x = t x"
|
||||
let expected = SFunc "f" ["x"] (SApp TLeaf [SVar "x"])
|
||||
parseSapling input @?= expected
|
||||
let expect = SFunc "f" ["x"] (SApp TLeaf [SVar "x"])
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse nested lists" $ do
|
||||
let input = "[t [(t t)]]"
|
||||
let expected = SList [TLeaf, SList [TStem TLeaf]]
|
||||
parseSapling input @?= expected
|
||||
let expect = SList [TLeaf, SList [TStem TLeaf]]
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse complex parentheses" $ do
|
||||
let input = "t (t t (t t))"
|
||||
let expected = TStem (TFork TLeaf (TStem TLeaf))
|
||||
parseSapling input @?= expected
|
||||
let expect = TStem (TFork TLeaf (TStem TLeaf))
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse empty list" $ do
|
||||
let input = "[]"
|
||||
let expected = SList []
|
||||
parseSapling input @?= expected
|
||||
let expect = SList []
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse multiple nested lists" $ do
|
||||
let input = "[[t t] [t (t t)]]"
|
||||
let expected = SList [SList [TLeaf, TLeaf], SList [TLeaf, TStem TLeaf]]
|
||||
parseSapling input @?= expected
|
||||
let expect = SList [SList [TLeaf, TLeaf], SList [TLeaf, TStem TLeaf]]
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse whitespace variance" $ do
|
||||
let input1 = "[t t]"
|
||||
let input2 = "[ t t ]"
|
||||
let expected = SList [TLeaf, TLeaf]
|
||||
parseSapling input1 @?= expected
|
||||
parseSapling input2 @?= expected
|
||||
let expect = SList [TLeaf, TLeaf]
|
||||
parseSingle input1 @?= expect
|
||||
parseSingle input2 @?= expect
|
||||
|
||||
, testCase "Parse string in list" $ do
|
||||
let input = "[(\"hello\")]"
|
||||
let expected = SList [SStr "hello"]
|
||||
parseSapling input @?= expected
|
||||
let expect = SList [SStr "hello"]
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse parentheses inside list" $ do
|
||||
let input = "[t (t t)]"
|
||||
let expected = SList [TLeaf, TStem TLeaf]
|
||||
parseSapling input @?= expected
|
||||
|
||||
-- Do I want to allow multi-line indentation-sensitive syntax?
|
||||
-- Probably not.
|
||||
--, testCase "Parse multi-line function definition" $ do
|
||||
-- let input = "f x y =\n t t"
|
||||
-- let expected = SFunc "f" ["x", "y"] (TStem TLeaf)
|
||||
-- parseSapling input @?= expected
|
||||
let expect = SList [TLeaf, TStem TLeaf]
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse nested parentheses in function body" $ do
|
||||
let input = "f = t (t (t t))"
|
||||
let expected = SFunc "f" [] (TStem (TStem (TStem TLeaf)))
|
||||
parseSapling input @?= expected
|
||||
let expect = SFunc "f" [] (TStem (TStem (TStem TLeaf)))
|
||||
parseSingle input @?= expect
|
||||
]
|
||||
|
||||
integrationTests :: TestTree
|
||||
integrationTests = testGroup "Integration Tests"
|
||||
[ testCase "Combine lexer and parser" $ do
|
||||
let input = "x = t t t"
|
||||
let expected = SFunc "x" [] (TFork TLeaf TLeaf)
|
||||
parseSapling input @?= expected
|
||||
let expect = SFunc "x" [] (TFork TLeaf TLeaf)
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Complex Tree Calculus expression" $ do
|
||||
let input = "t (t t t) t"
|
||||
let expected = TFork (TFork TLeaf TLeaf) TLeaf
|
||||
parseSapling input @?= expected
|
||||
let expect = TFork (TFork TLeaf TLeaf) TLeaf
|
||||
parseSingle input @?= expect
|
||||
]
|
||||
|
||||
evaluationTests :: TestTree
|
||||
evaluationTests = testGroup "Evaluation Tests"
|
||||
[ testCase "Evaluate single Leaf" $ do
|
||||
let input = "t"
|
||||
let ast = parseSapling input
|
||||
(result $ evalSapling Map.empty ast) @?= Leaf
|
||||
let ast = parseSingle input
|
||||
(result $ evalSingle Map.empty ast) @?= Leaf
|
||||
|
||||
, testCase "Evaluate single Stem" $ do
|
||||
let input = "t t"
|
||||
let ast = parseSapling input
|
||||
(result $ evalSapling Map.empty ast) @?= Stem Leaf
|
||||
let ast = parseSingle input
|
||||
(result $ evalSingle Map.empty ast) @?= Stem Leaf
|
||||
|
||||
, testCase "Evaluate single Fork" $ do
|
||||
let input = "t t t"
|
||||
let ast = parseSapling input
|
||||
(result $ evalSapling Map.empty ast) @?= Fork Leaf Leaf
|
||||
let ast = parseSingle input
|
||||
(result $ evalSingle Map.empty ast) @?= Fork Leaf Leaf
|
||||
|
||||
, testCase "Evaluate nested Fork and Stem" $ do
|
||||
let input = "t (t t) t"
|
||||
let ast = parseSapling input
|
||||
(result $ evalSapling Map.empty ast) @?= Fork (Stem Leaf) Leaf
|
||||
let ast = parseSingle input
|
||||
(result $ evalSingle Map.empty ast) @?= Fork (Stem Leaf) Leaf
|
||||
|
||||
, testCase "Evaluate `not` function" $ do
|
||||
let input = "t (t (t t) (t t t)) t)"
|
||||
let ast = parseSapling input
|
||||
(result $ evalSapling Map.empty ast) @?=
|
||||
let ast = parseSingle input
|
||||
(result $ evalSingle Map.empty ast) @?=
|
||||
Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
|
||||
|
||||
, testCase "Environment updates with definitions" $ do
|
||||
let input = "x = t\ny = x"
|
||||
let env = evalMulti Map.empty (parseMulti input)
|
||||
let env = evalSapling Map.empty (parseSapling input)
|
||||
Map.lookup "x" env @?= Just Leaf
|
||||
Map.lookup "y" env @?= Just Leaf
|
||||
|
||||
, testCase "Variable substitution" $ do
|
||||
let input = "x = t t\ny = t x\ny"
|
||||
let env = evalMulti Map.empty (parseMulti input)
|
||||
let env = evalSapling Map.empty (parseSapling input)
|
||||
(result env) @?= Stem (Stem Leaf)
|
||||
|
||||
, testCase "Multiline input evaluation" $ do
|
||||
let input = "x = t\ny = t t\nx"
|
||||
let env = evalMulti Map.empty (parseMulti input)
|
||||
let env = evalSapling Map.empty (parseSapling input)
|
||||
(result env) @?= Leaf
|
||||
|
||||
, testCase "Evaluate string literal" $ do
|
||||
let input = "\"hello\""
|
||||
let ast = parseSapling input
|
||||
(result $ evalSapling Map.empty ast) @?= toString "hello"
|
||||
let ast = parseSingle input
|
||||
(result $ evalSingle Map.empty ast) @?= toString "hello"
|
||||
|
||||
, testCase "Evaluate list literal" $ do
|
||||
let input = "[t (t t)]"
|
||||
let ast = parseSapling input
|
||||
(result $ evalSapling Map.empty ast) @?= toList [Leaf, Stem Leaf]
|
||||
let ast = parseSingle input
|
||||
(result $ evalSingle Map.empty ast) @?= toList [Leaf, Stem Leaf]
|
||||
|
||||
, testCase "Evaluate empty list" $ do
|
||||
let input = "[]"
|
||||
let ast = parseSapling input
|
||||
(result $ evalSapling Map.empty ast) @?= toList []
|
||||
let ast = parseSingle input
|
||||
(result $ evalSingle Map.empty ast) @?= toList []
|
||||
|
||||
, testCase "Evaluate variable dependency chain" $ do
|
||||
let input = "x = t\ny = t x\nz = t y\nz"
|
||||
let env = evalMulti Map.empty (parseMulti input)
|
||||
let input = "x = t\n \
|
||||
\ y = t x\n \
|
||||
\ z = t y\n \
|
||||
\ variablewithamuchlongername = z\n \
|
||||
\ variablewithamuchlongername"
|
||||
let env = evalSapling Map.empty (parseSapling input)
|
||||
(result env) @?= (Stem (Stem Leaf))
|
||||
|
||||
, testCase "Evaluate redefinition of variables" $ do
|
||||
let input = "x = t t\nx = t\nx"
|
||||
let env = evalMulti Map.empty (parseMulti input)
|
||||
let env = evalSapling Map.empty (parseSapling input)
|
||||
(result env) @?= Leaf
|
||||
]
|
||||
|
||||
@ -227,6 +247,5 @@ propertyTests = testGroup "Property Tests"
|
||||
Left _ -> property True
|
||||
Right tokens -> case runParser parseExpression "" tokens of
|
||||
Left _ -> property True
|
||||
Right ast -> parseSapling input === ast
|
||||
Right ast -> parseSingle input === ast
|
||||
]
|
||||
|
||||
|
Loading…
x
Reference in New Issue
Block a user