commit 967892d64272badd188e1fea69f8240ec3cd3070
parent 8d50a981ad08a8f3755154e3fa8c8f7abd5928ca
Author: James Eversole <james@eversole.co>
Date: Mon, 27 Jan 2025 16:04:04 -0600
Module system implementation
Diffstat:
28 files changed, 373 insertions(+), 105 deletions(-)
diff --git a/README.md b/README.md
@@ -10,12 +10,13 @@ tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)
- Tree Calculus operator: `t`
- Assignments: `x = t t`
+- Immutable definitions
- Lambda abstraction syntax: `id = (\a : a)`
- List, Number, and String literals: `[(2) ("Hello")]`
- Function application: `not (not false)`
- Higher order/first-class functions: `map (\a : lconcat a "!") [("Hello")]`
- Intensionality blurs the distinction between functions and data (see REPL examples)
-- Immutability
+- Simple module system for code organization
## REPL examples
diff --git a/demos/equality.tri b/demos/equality.tri
@@ -1,3 +1,7 @@
+!module Equality
+
+!import "lib/base.tri" Lib
+
main = lambdaEqualsTC
-- We represent `false` with a Leaf and `true` with a Stem Leaf
@@ -24,7 +28,7 @@ not_Lambda? = demo_matchBool demo_false demo_true
-- to different tree representations even if they share extensional behavior.
-- Let's see if these are the same:
-lambdaEqualsTC = equal? not_TC? not_Lambda?
+lambdaEqualsTC = Lib.equal? not_TC? not_Lambda?
-- Here are some checks to verify their extensional behavior is the same:
true_TC? = not_TC? demo_false
@@ -33,5 +37,5 @@ false_TC? = not_TC? demo_true
true_Lambda? = not_Lambda? demo_false
false_Lambda? = not_Lambda? demo_true
-bothTrueEqual? = equal? true_TC? true_Lambda?
-bothFalseEqual? = equal? false_TC? false_Lambda?
+bothTrueEqual? = Lib.equal? true_TC? true_Lambda?
+bothFalseEqual? = Lib.equal? false_TC? false_Lambda?
diff --git a/demos/levelOrderTraversal.tri b/demos/levelOrderTraversal.tri
@@ -1,3 +1,7 @@
+!module LOT
+
+!import "lib/base.tri" Lib
+
main = exampleTwo
-- Level Order Traversal of a labelled binary tree
-- Objective: Print each "level" of the tree on a separate line
@@ -15,41 +19,41 @@ main = exampleTwo
-- / / \
-- 4 5 6
-label = \node : head node
+label = \node : Lib.head node
-left = (\node : if (emptyList? node)
+left = (\node : Lib.if (Lib.emptyList? node)
[]
- (if (emptyList? (tail node))
+ (Lib.if (Lib.emptyList? (Lib.tail node))
[]
- (head (tail node))))
+ (Lib.head (Lib.tail node))))
-right = (\node : if (emptyList? node)
+right = (\node : Lib.if (Lib.emptyList? node)
[]
- (if (emptyList? (tail node))
+ (Lib.if (Lib.emptyList? (Lib.tail node))
[]
- (if (emptyList? (tail (tail node)))
+ (Lib.if (Lib.emptyList? (Lib.tail (Lib.tail node)))
[]
- (head (tail (tail node))))))
+ (Lib.head (Lib.tail (Lib.tail node))))))
-processLevel = y (\self queue : if (emptyList? queue)
+processLevel = Lib.y (\self queue : Lib.if (Lib.emptyList? queue)
[]
- (pair (map label queue) (self (filter
- (\node : not? (emptyList? node))
- (lconcat (map left queue) (map right queue))))))
+ (Lib.pair (Lib.map label queue) (self (Lib.filter
+ (\node : Lib.not? (Lib.emptyList? node))
+ (Lib.lconcat (Lib.map left queue) (Lib.map right queue))))))
levelOrderTraversal_ = \a : processLevel (t a t)
-toLineString = y (\self levels : if (emptyList? levels)
+toLineString = Lib.y (\self levels : Lib.if (Lib.emptyList? levels)
""
- (lconcat
- (lconcat (map (\x : lconcat x " ") (head levels)) "")
- (if (emptyList? (tail levels)) "" (lconcat (t (t 10 t) t) (self (tail levels))))))
+ (Lib.lconcat
+ (Lib.lconcat (Lib.map (\x : Lib.lconcat x " ") (Lib.head levels)) "")
+ (Lib.if (Lib.emptyList? (Lib.tail levels)) "" (Lib.lconcat (t (t 10 t) t) (self (Lib.tail levels))))))
levelOrderToString = \s : toLineString (levelOrderTraversal_ s)
-flatten = foldl (\acc x : lconcat acc x) ""
+flatten = Lib.foldl (\acc x : Lib.lconcat acc x) ""
-levelOrderTraversal = \s : lconcat (t 10 t) (flatten (levelOrderToString s))
+levelOrderTraversal = \s : Lib.lconcat (t 10 t) (flatten (levelOrderToString s))
exampleOne = levelOrderTraversal [("1")
[("2") [("4") t t] t]
diff --git a/demos/size.tri b/demos/size.tri
@@ -1,20 +1,24 @@
+!module Size
+
+!import "lib/base.tri" Lib
+
main = size size
compose = \f g x : f (g x)
-succ = y (\self :
- triage
+succ = Lib.y (\self :
+ Lib.triage
1
t
- (triage
+ (Lib.triage
(t (t t))
- (\_ tail : t t (self tail))
+ (\_ Lib.tail : t t (self Lib.tail))
t))
size = (\x :
- (y (\self x :
+ (Lib.y (\self x :
compose succ
- (triage
+ (Lib.triage
(\x : x)
self
(\x y : compose (self x) (self y))
diff --git a/demos/toSource.tri b/demos/toSource.tri
@@ -1,4 +1,8 @@
-main = toSource not?
+!module ToSource
+
+!import "lib/base.tri" Lib
+
+main = toSource Lib.not?
-- Thanks to intensionality, we can inspect the structure of a given value
-- even if it's a function. This includes lambdas which are eliminated to
-- Tree Calculus (TC) terms during evaluation.
@@ -12,29 +16,29 @@ main = toSource not?
-- triage = (\leaf stem fork : t (t leaf stem) fork)
-- Base case of a single Leaf
-sourceLeaf = t (head "t")
+sourceLeaf = t (Lib.head "t")
-- Stem case
sourceStem = (\convert : (\a rest :
- t (head "(") -- Start with a left parenthesis "(".
- (t (head "t") -- Add a "t"
- (t (head " ") -- Add a space.
- (convert a -- Recursively convert the argument.
- (t (head ")") rest)))))) -- Close with ")" and append the rest.
+ t (Lib.head "(") -- Start with a left parenthesis "(".
+ (t (Lib.head "t") -- Add a "t"
+ (t (Lib.head " ") -- Add a space.
+ (convert a -- Recursively convert the argument.
+ (t (Lib.head ")") rest)))))) -- Close with ")" and append the rest.
-- Fork case
sourceFork = (\convert : (\a b rest :
- t (head "(") -- Start with a left parenthesis "(".
- (t (head "t") -- Add a "t"
- (t (head " ") -- Add a space.
- (convert a -- Recursively convert the first arg.
- (t (head " ") -- Add another space.
- (convert b -- Recursively convert the second arg.
- (t (head ")") rest)))))))) -- Close with ")" and append the rest.
+ t (Lib.head "(") -- Start with a left parenthesis "(".
+ (t (Lib.head "t") -- Add a "t"
+ (t (Lib.head " ") -- Add a space.
+ (convert a -- Recursively convert the first arg.
+ (t (Lib.head " ") -- Add another space.
+ (convert b -- Recursively convert the second arg.
+ (t (Lib.head ")") rest)))))))) -- Close with ")" and append the rest.
-- Wrapper around triage
-toSource_ = y (\self arg :
- triage
+toSource_ = Lib.y (\self arg :
+ Lib.triage
sourceLeaf -- `triage` "a" case, Leaf
(sourceStem self) -- `triage` "b" case, Stem
(sourceFork self) -- `triage` "c" case, Fork
@@ -43,5 +47,5 @@ toSource_ = y (\self arg :
-- toSource takes a single TC term and returns a String
toSource = \v : toSource_ v ""
-exampleOne = toSource true -- OUT: "(t t)"
-exampleTwo = toSource not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"
+exampleOne = toSource Lib.true -- OUT: "(t t)"
+exampleTwo = toSource Lib.not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"
diff --git a/src/Eval.hs b/src/Eval.hs
@@ -17,19 +17,19 @@ evalSingle env term
"Error: Identifier '" ++ name ++ "' is already defined."
| otherwise ->
let res = evalAST env body
- in Map.insert "__result" res (Map.insert name res env)
+ in Map.insert "!result" res (Map.insert name res env)
| SApp func arg <- term =
let res = apply (evalAST env func) (evalAST env arg)
- in Map.insert "__result" res env
+ in Map.insert "!result" res env
| SVar name <- term =
case Map.lookup name env of
Just v ->
- Map.insert "__result" v env
+ Map.insert "!result" v env
Nothing ->
errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined\n\
\This error should never occur here. Please report this as an issue."
| otherwise =
- Map.insert "__result" (evalAST env term) env
+ Map.insert "!result" (evalAST env term) env
evalTricu :: Env -> [TricuAST] -> Env
evalTricu env x = go env (reorderDefs env x)
@@ -37,7 +37,7 @@ evalTricu env x = go env (reorderDefs env x)
go env [] = env
go env [x] =
let updatedEnv = evalSingle env x
- in Map.insert "__result" (result updatedEnv) updatedEnv
+ in Map.insert "!result" (result updatedEnv) updatedEnv
go env (x:xs) =
evalTricu (evalSingle env x) xs
@@ -109,10 +109,11 @@ freeVars (SStr _ ) = Set.empty
freeVars (SList s ) = foldMap freeVars s
freeVars (SApp f a ) = freeVars f <> freeVars a
freeVars (TLeaf ) = Set.empty
-freeVars (SDef _ _ b) = freeVars b
+freeVars (SDef _ _ b) = freeVars b
freeVars (TStem t ) = freeVars t
freeVars (TFork l r ) = freeVars l <> freeVars r
freeVars (SLambda v b ) = foldr Set.delete (freeVars b) v
+freeVars _ = Set.empty
reorderDefs :: Env -> [TricuAST] -> [TricuAST]
reorderDefs env defs
@@ -180,9 +181,9 @@ depends topDefs (SDef _ _ body) =
depends _ _ = Set.empty
result :: Env -> T
-result r = case Map.lookup "__result" r of
+result r = case Map.lookup "!result" r of
Just a -> a
- Nothing -> errorWithoutStackTrace "No __result field found in provided env"
+ Nothing -> errorWithoutStackTrace "No !result field found in provided env"
mainResult :: Env -> T
mainResult r = case Map.lookup "main" r of
diff --git a/src/FileEval.hs b/src/FileEval.hs
@@ -1,30 +1,150 @@
module FileEval where
import Eval
+import Lexer
import Parser
import Research
+import Data.List (partition)
+import Control.Monad (foldM)
import System.IO
import qualified Data.Map as Map
+import qualified Data.Set as Set
evaluateFileResult :: FilePath -> IO T
evaluateFileResult filePath = do
contents <- readFile filePath
- let asts = parseTricu contents
- let finalEnv = evalTricu Map.empty asts
- case Map.lookup "main" finalEnv of
- Just finalResult -> return finalResult
- Nothing -> errorWithoutStackTrace "No `main` function detected"
+ let tokens = lexTricu contents
+ let moduleName = case parseProgram tokens of
+ Right ((SModule name) : _) -> name
+ _ -> ""
+ case parseProgram tokens of
+ Left err -> errorWithoutStackTrace (handleParseError err)
+ Right _ -> do
+ ast <- preprocessFile filePath
+ let finalEnv = mainAlias moduleName $ evalTricu Map.empty ast
+ case Map.lookup "main" finalEnv of
+ Just finalResult -> return finalResult
+ Nothing -> errorWithoutStackTrace "No `main` function detected"
evaluateFile :: FilePath -> IO Env
evaluateFile filePath = do
contents <- readFile filePath
- let asts = parseTricu contents
- pure $ evalTricu Map.empty asts
+ let tokens = lexTricu contents
+ let moduleName = case parseProgram tokens of
+ Right ((SModule name) : _) -> name
+ _ -> ""
+ case parseProgram tokens of
+ Left err -> errorWithoutStackTrace (handleParseError err)
+ Right _ -> do
+ ast <- preprocessFile filePath
+ pure $ mainAlias moduleName $ evalTricu Map.empty ast
evaluateFileWithContext :: Env -> FilePath -> IO Env
evaluateFileWithContext env filePath = do
contents <- readFile filePath
- let asts = parseTricu contents
- pure $ evalTricu env asts
+ let tokens = lexTricu contents
+ let moduleName = case parseProgram tokens of
+ Right ((SModule name) : _) -> name
+ _ -> ""
+ case parseProgram tokens of
+ Left err -> errorWithoutStackTrace (handleParseError err)
+ Right _ -> do
+ ast <- preprocessFile filePath
+ pure $ mainAlias moduleName $ evalTricu env ast
+
+mainAlias :: String -> Env -> Env
+mainAlias "" env = env
+mainAlias moduleName env =
+ case Map.lookup (moduleName ++ ".main") env of
+ Just value -> Map.insert "main" value env
+ Nothing -> env
+
+preprocessFile :: FilePath -> IO [TricuAST]
+preprocessFile filePath = preprocessFile' Set.empty filePath
+
+preprocessFile' :: Set.Set FilePath -> FilePath -> IO [TricuAST]
+preprocessFile' inProgress filePath
+ | filePath `Set.member` inProgress =
+ errorWithoutStackTrace $ "Encountered cyclic import: " ++ filePath
+ | otherwise = do
+ contents <- readFile filePath
+ let tokens = lexTricu contents
+ case parseProgram tokens of
+ Left err -> errorWithoutStackTrace (handleParseError err)
+ Right asts -> do
+ let (moduleName, restAST) = extractModule asts
+ let (imports, nonImports) = partition isImport restAST
+ let newInProgress = Set.insert filePath inProgress
+ importedASTs <- concat <$> mapM (processImport newInProgress) imports
+ let namespacedAST = namespaceDefinitions moduleName nonImports
+ pure $ importedASTs ++ namespacedAST
+ where
+ extractModule :: [TricuAST] -> (String, [TricuAST])
+ extractModule ((SModule name) : xs) = (name, xs)
+ extractModule xs = ("", xs)
+
+ isImport :: TricuAST -> Bool
+ isImport (SImport _ _) = True
+ isImport _ = False
+
+ processImport :: Set.Set FilePath -> TricuAST -> IO [TricuAST]
+ processImport inProgress (SImport filePath moduleName) = do
+ importedAST <- preprocessFile' inProgress filePath
+ pure $ namespaceDefinitions moduleName importedAST
+ processImport _ _ = error "Unexpected non-import in processImport"
+
+namespaceDefinitions :: String -> [TricuAST] -> [TricuAST]
+namespaceDefinitions moduleName = map (namespaceDefinition moduleName)
+
+namespaceDefinition :: String -> TricuAST -> TricuAST
+namespaceDefinition "" def = def
+namespaceDefinition moduleName (SDef name args body)
+ | isPrefixed name = SDef name args (namespaceBody moduleName body)
+ | otherwise = SDef (namespaceVariable moduleName name)
+ args (namespaceBody moduleName body)
+namespaceDefinition moduleName other =
+ namespaceBody moduleName other
+
+namespaceBody :: String -> TricuAST -> TricuAST
+namespaceBody moduleName (SVar name)
+ | isPrefixed name = SVar name
+ | otherwise = SVar (namespaceVariable moduleName name)
+namespaceBody moduleName (SApp func arg) =
+ SApp (namespaceBody moduleName func) (namespaceBody moduleName arg)
+namespaceBody moduleName (SLambda args body) =
+ SLambda args (namespaceBodyScoped moduleName args body)
+namespaceBody moduleName (SList items) =
+ SList (map (namespaceBody moduleName) items)
+namespaceBody moduleName (TFork left right) =
+ TFork (namespaceBody moduleName left) (namespaceBody moduleName right)
+namespaceBody moduleName (TStem subtree) =
+ TStem (namespaceBody moduleName subtree)
+namespaceBody moduleName (SDef name args body)
+ | isPrefixed name = SDef name args (namespaceBody moduleName body)
+ | otherwise = SDef (namespaceVariable moduleName name)
+ args (namespaceBody moduleName body)
+namespaceBody _ other = other
+
+namespaceBodyScoped :: String -> [String] -> TricuAST -> TricuAST
+namespaceBodyScoped moduleName args body = case body of
+ SVar name ->
+ if name `elem` args
+ then SVar name
+ else namespaceBody moduleName (SVar name)
+ SApp func arg -> SApp (namespaceBodyScoped moduleName args func) (namespaceBodyScoped moduleName args arg)
+ SLambda innerArgs innerBody -> SLambda innerArgs (namespaceBodyScoped moduleName (args ++ innerArgs) innerBody)
+ SList items -> SList (map (namespaceBodyScoped moduleName args) items)
+ TFork left right -> TFork (namespaceBodyScoped moduleName args left) (namespaceBodyScoped moduleName args right)
+ TStem subtree -> TStem (namespaceBodyScoped moduleName args subtree)
+ SDef name innerArgs innerBody ->
+ SDef (namespaceVariable moduleName name) innerArgs (namespaceBodyScoped moduleName (args ++ innerArgs) innerBody)
+ other -> other
+
+isPrefixed :: String -> Bool
+isPrefixed name = '.' `elem` name
+
+namespaceVariable :: String -> String -> String
+namespaceVariable "" name = name
+namespaceVariable moduleName name = moduleName ++ "." ++ name
diff --git a/src/Lexer.hs b/src/Lexer.hs
@@ -20,11 +20,11 @@ identifier = do
first <- letterChar <|> char '_'
rest <- many $ letterChar
<|> digitChar
- <|> char '_' <|> char '-' <|> char '?' <|> char '!'
+ <|> char '_' <|> char '-' <|> char '?' <|> char '.'
<|> char '$' <|> char '#' <|> char '@' <|> char '%'
let name = first : rest
- if (name == "t" || name == "__result")
- then fail "Keywords (`t`, `__result`) cannot be used as an identifier"
+ if (name == "t" || name == "!result")
+ then fail "Keywords (`t`, `!result`) cannot be used as an identifier"
else return (LIdentifier name)
integerLiteral :: Lexer LToken
@@ -39,6 +39,22 @@ stringLiteral = do
char '"' --"
return (LStringLiteral content)
+lModule :: Lexer LToken
+lModule = do
+ _ <- string "!module"
+ space1
+ LIdentifier moduleName <- identifier
+ return (LModule moduleName)
+
+lImport :: Lexer LToken
+lImport = do
+ _ <- string "!import"
+ space1
+ LStringLiteral path <- stringLiteral
+ space1
+ LIdentifier name <- identifier
+ return (LImport path name)
+
assign :: Lexer LToken
assign = char '=' *> pure LAssign
@@ -72,28 +88,36 @@ sc = space
tricuLexer :: Lexer [LToken]
tricuLexer = do
sc
+ header <- many $ do
+ tok <- choice
+ [ try lModule
+ , try lImport
+ , lnewline
+ ]
+ sc
+ pure tok
tokens <- many $ do
tok <- choice tricuLexer'
sc
pure tok
sc
eof
- pure tokens
- where
- tricuLexer' =
- [ try lnewline
- , try identifier
- , try keywordT
- , try integerLiteral
- , try stringLiteral
- , assign
- , colon
- , backslash
- , openParen
- , closeParen
- , openBracket
- , closeBracket
- ]
+ pure (header ++ tokens)
+ where
+ tricuLexer' =
+ [ try lnewline
+ , try identifier
+ , try keywordT
+ , try integerLiteral
+ , try stringLiteral
+ , assign
+ , colon
+ , backslash
+ , openParen
+ , closeParen
+ , openBracket
+ , closeBracket
+ ]
lexTricu :: String -> [LToken]
lexTricu input = case runParser tricuLexer "" input of
diff --git a/src/Main.hs b/src/Main.hs
@@ -61,7 +61,7 @@ main = do
putStrLn "Welcome to the tricu REPL"
putStrLn "You can exit with `CTRL+D` or the `:_exit` command.`"
library <- liftIO $ evaluateFile "./lib/base.tri"
- repl $ Map.delete "__result" library
+ repl $ Map.delete "!result" library
Evaluate { file = filePaths, form = form } -> do
result <- case filePaths of
[] -> do
diff --git a/src/Parser.hs b/src/Parser.hs
@@ -74,9 +74,33 @@ parseSingle input =
parseProgramM :: ParserM [TricuAST]
parseProgramM = do
skipMany topLevelNewline
+ moduleNode <- optional parseModuleM
+ skipMany topLevelNewline
+ importNodes <- many (do
+ node <- parseImportM
+ skipMany topLevelNewline
+ return node)
+ skipMany topLevelNewline
exprs <- sepEndBy parseOneExpression (some topLevelNewline)
skipMany topLevelNewline
- return exprs
+ return (maybe [] (: []) moduleNode ++ importNodes ++ exprs)
+
+
+parseModuleM :: ParserM TricuAST
+parseModuleM = do
+ LModule moduleName <- satisfyM isModule
+ pure (SModule moduleName)
+ where
+ isModule (LModule _) = True
+ isModule _ = False
+
+parseImportM :: ParserM TricuAST
+parseImportM = do
+ LImport filePath moduleName <- satisfyM isImport
+ pure (SImport filePath moduleName)
+ where
+ isImport (LImport _ _) = True
+ isImport _ = False
parseOneExpression :: ParserM TricuAST
parseOneExpression = scnParserM *> parseExpressionM
@@ -244,7 +268,7 @@ parseVarM :: ParserM TricuAST
parseVarM = do
satisfyM (\case LIdentifier _ -> True; _ -> False) >>= \case
LIdentifier name
- | name == "t" || name == "__result" ->
+ | name == "t" || name == "!result" ->
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
| otherwise ->
pure (SVar name)
diff --git a/src/REPL.hs b/src/REPL.hs
@@ -26,7 +26,7 @@ repl env = runInputT defaultSettings (loop env)
| Just s <- minput, strip s == "" -> do
outputStrLn ""
loop env
- | Just s <- minput, strip s == "!load" -> do
+ | Just s <- minput, strip s == "!import" -> do
path <- getInputLine "File path to load < "
if
| Nothing <- path -> do
@@ -34,7 +34,7 @@ repl env = runInputT defaultSettings (loop env)
loop env
| Just p <- path -> do
loadedEnv <- liftIO $ evaluateFileWithContext env (strip p) `catch` \e -> errorHandler env e
- loop $ Map.delete "__result" (Map.union loadedEnv env)
+ loop $ Map.delete "!result" (Map.union loadedEnv env)
| Just s <- minput -> do
if
| take 2 s == "--" -> loop env
@@ -47,7 +47,7 @@ repl env = runInputT defaultSettings (loop env)
let asts = parseTricu input
newEnv = evalTricu env asts
if
- | Just r <- Map.lookup "__result" newEnv -> do
+ | Just r <- Map.lookup "!result" newEnv -> do
putStrLn $ "tricu > " ++ decodeResult r
| otherwise -> return ()
return newEnv
diff --git a/src/Research.hs b/src/Research.hs
@@ -26,6 +26,8 @@ data TricuAST
| TFork TricuAST TricuAST
| SLambda [String] TricuAST
| SEmpty
+ | SModule String
+ | SImport String String
deriving (Show, Eq, Ord)
-- Lexer Tokens
@@ -42,6 +44,8 @@ data LToken
| LOpenBracket
| LCloseBracket
| LNewline
+ | LModule String
+ | LImport String String
deriving (Show, Eq, Ord)
-- Output formats
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -7,12 +7,13 @@ import Parser
import REPL
import Research
-import Control.Exception (evaluate, try, SomeException)
+import Control.Exception (evaluate, try, SomeException)
import Control.Monad.IO.Class (liftIO)
+import Data.List (isInfixOf)
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
-import Text.Megaparsec (runParser)
+import Text.Megaparsec (runParser)
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -31,6 +32,7 @@ tests = testGroup "Tricu Tests"
, lambdas
, baseLibrary
, fileEval
+ , modules
, demos
]
@@ -70,9 +72,9 @@ lexer = testGroup "Lexer Tests"
Right i -> i @?= expect
, testCase "Error when using invalid characters in identifiers" $ do
- case (runParser tricuLexer "" "__result = 5") of
+ case (runParser tricuLexer "" "!result = 5") of
Left _ -> return ()
- Right _ -> assertFailure "Expected failure when trying to assign the value of __result"
+ Right _ -> assertFailure "Expected failure when trying to assign the value of !result"
]
parser :: TestTree
@@ -498,22 +500,54 @@ fileEval = testGroup "File evaluation tests"
decodeResult (result res) @?= "\"String test!\""
]
+modules :: TestTree
+modules = testGroup "Test modules"
+ [ testCase "Detect cyclic dependencies" $ do
+ result <- try (liftIO $ evaluateFileResult "./test/cycle-1.tri") :: IO (Either SomeException T)
+ case result of
+ Left e -> do
+ let errorMsg = show e
+ if "Encountered cyclic import" `isInfixOf` errorMsg
+ then return ()
+ else assertFailure $ "Unexpected error: " ++ errorMsg
+ Right _ -> assertFailure "Expected cyclic dependencies"
+ , testCase "Module imports and namespacing" $ do
+ res <- liftIO $ evaluateFileResult "./test/namespace-A.tri"
+ res @?= Leaf
+ , testCase "Multiple imports" $ do
+ res <- liftIO $ evaluateFileResult "./test/vars-A.tri"
+ res @?= Leaf
+ , testCase "Error on unresolved variable" $ do
+ result <- try (liftIO $ evaluateFileResult "./test/unresolved-A.tri") :: IO (Either SomeException T)
+ case result of
+ Left e -> do
+ let errorMsg = show e
+ if "undefinedVar" `isInfixOf` errorMsg
+ then return ()
+ else assertFailure $ "Unexpected error: " ++ errorMsg
+ Right _ -> assertFailure "Expected unresolved variable error"
+ , testCase "Multi-level imports" $ do
+ res <- liftIO $ evaluateFileResult "./test/multi-level-A.tri"
+ res @?= Leaf
+ , testCase "Lambda expression namespaces" $ do
+ res <- liftIO $ evaluateFileResult "./test/lambda-A.tri"
+ res @?= Leaf
+ ]
+
+
+-- All of our demo tests are also module tests
demos :: TestTree
demos = testGroup "Test provided demo functionality"
[ testCase "Structural equality demo" $ do
- library <- liftIO $ evaluateFile "./lib/base.tri"
- res <- liftIO $ evaluateFileWithContext library "./demos/equality.tri"
- decodeResult (result res) @?= "t t"
+ res <- liftIO $ evaluateFileResult "./demos/equality.tri"
+ decodeResult res @?= "t t"
, testCase "Convert values back to source code demo" $ do
- library <- liftIO $ evaluateFile "./lib/base.tri"
- res <- liftIO $ evaluateFileWithContext library "./demos/toSource.tri"
- decodeResult (result res) @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\""
+ res <- liftIO $ evaluateFileResult "./demos/toSource.tri"
+ decodeResult res @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\""
, testCase "Determining the size of functions" $ do
- library <- liftIO $ evaluateFile "./lib/base.tri"
- res <- liftIO $ evaluateFileWithContext library "./demos/size.tri"
- decodeResult (result res) @?= "454"
+ res <- liftIO $ evaluateFileResult "./demos/size.tri"
+ decodeResult res @?= "454"
, testCase "Level Order Traversal demo" $ do
- library <- liftIO $ evaluateFile "./lib/base.tri"
- res <- liftIO $ evaluateFileWithContext library "./demos/levelOrderTraversal.tri"
- decodeResult (result res) @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \""
+ res <- liftIO $ evaluateFileResult "./demos/levelOrderTraversal.tri"
+ decodeResult res @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \""
]
diff --git a/test/cycle-1.tri b/test/cycle-1.tri
@@ -0,0 +1,5 @@
+!module Cycle
+
+!import "test/cycle-2.tri" Cycle2
+
+cycle1 = t Cycle2.cycle2
diff --git a/test/cycle-2.tri b/test/cycle-2.tri
@@ -0,0 +1,5 @@
+!module Cycle2
+
+!import "test/cycle-1.tri" Cycle1
+
+cycle2 = t Cycle1.cycle1
diff --git a/test/lambda-A.tri b/test/lambda-A.tri
@@ -0,0 +1,2 @@
+!module A
+main = (\x : x) t
diff --git a/test/modules-1.tri b/test/modules-1.tri
@@ -0,0 +1,5 @@
+!module Test
+
+!import "lib/base.tri" Lib
+
+main = Lib.not? t
diff --git a/test/modules-2.tri b/test/modules-2.tri
@@ -0,0 +1 @@
+n = t t t
diff --git a/test/multi-level-A.tri b/test/multi-level-A.tri
@@ -0,0 +1,3 @@
+!module A
+!import "./test/multi-level-B.tri" B
+main = B.main
diff --git a/test/multi-level-B.tri b/test/multi-level-B.tri
@@ -0,0 +1,3 @@
+!module B
+!import "./test/multi-level-C.tri" C
+main = C.val
diff --git a/test/multi-level-C.tri b/test/multi-level-C.tri
@@ -0,0 +1,2 @@
+!module C
+val = t
diff --git a/test/namespace-A.tri b/test/namespace-A.tri
@@ -0,0 +1,3 @@
+!module A
+!import "./test/namespace-B.tri" B
+main = B.x
diff --git a/test/namespace-B.tri b/test/namespace-B.tri
@@ -0,0 +1,2 @@
+!module B
+x = t
diff --git a/test/unresolved-A.tri b/test/unresolved-A.tri
@@ -0,0 +1,2 @@
+!module A
+main = undefinedVar
diff --git a/test/vars-A.tri b/test/vars-A.tri
@@ -0,0 +1,7 @@
+!module A
+
+!import "./test/vars-B.tri" B
+
+!import "./test/vars-C.tri" C
+
+main = B.y (C.z)
diff --git a/test/vars-B.tri b/test/vars-B.tri
@@ -0,0 +1,2 @@
+!module B
+y = \x : x
diff --git a/test/vars-C.tri b/test/vars-C.tri
@@ -0,0 +1,2 @@
+!module C
+z = t
diff --git a/tricu.cabal b/tricu.cabal
@@ -1,7 +1,7 @@
cabal-version: 1.12
name: tricu
-version: 0.11.0
+version: 0.12.0
description: A micro-language for exploring Tree Calculus
author: James Eversole
maintainer: james@eversole.co
