From 87aed72ab2ef74125331c3ae8eec78c9484a8604 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Mon, 27 Jan 2025 16:04:04 -0600 Subject: [PATCH] # Modules Basic implementation of a module system including tests. --- README.md | 3 +- demos/equality.tri | 10 ++- demos/levelOrderTraversal.tri | 40 +++++----- demos/size.tri | 16 ++-- demos/toSource.tri | 40 +++++----- src/Eval.hs | 17 +++-- src/FileEval.hs | 138 +++++++++++++++++++++++++++++++--- src/Lexer.hs | 62 ++++++++++----- src/Main.hs | 2 +- src/Parser.hs | 28 ++++++- src/REPL.hs | 6 +- src/Research.hs | 4 + test/Spec.hs | 66 ++++++++++++---- test/cycle-1.tri | 5 ++ test/cycle-2.tri | 5 ++ test/lambda-A.tri | 2 + test/modules-1.tri | 5 ++ test/modules-2.tri | 1 + test/multi-level-A.tri | 3 + test/multi-level-B.tri | 3 + test/multi-level-C.tri | 2 + test/namespace-A.tri | 3 + test/namespace-B.tri | 2 + test/unresolved-A.tri | 2 + test/vars-A.tri | 7 ++ test/vars-B.tri | 2 + test/vars-C.tri | 2 + tricu.cabal | 2 +- 28 files changed, 373 insertions(+), 105 deletions(-) create mode 100644 test/cycle-1.tri create mode 100644 test/cycle-2.tri create mode 100644 test/lambda-A.tri create mode 100644 test/modules-1.tri create mode 100644 test/modules-2.tri create mode 100644 test/multi-level-A.tri create mode 100644 test/multi-level-B.tri create mode 100644 test/multi-level-C.tri create mode 100644 test/namespace-A.tri create mode 100644 test/namespace-B.tri create mode 100644 test/unresolved-A.tri create mode 100644 test/vars-A.tri create mode 100644 test/vars-B.tri create mode 100644 test/vars-C.tri diff --git a/README.md b/README.md index 720326f..2bc3594 100644 --- 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` +- Immutabile 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 index f450afd..196b0bc 100644 --- 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 index 57c9c75..d3f8282 100644 --- 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 index 74476cb..77b9625 100644 --- 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 index f8419ea..5a0ad43 100644 --- 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 index a04695b..bdb022a 100644 --- 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 index 40a14c4..7580499 100644 --- 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 index 284c100..e435569 100644 --- 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 index 52016da..a7b4a66 100644 --- 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 index 181c0e0..dd8dd85 100644 --- 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 index b725209..1eba732 100644 --- 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 index c29f494..6a4234a 100644 --- 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 index eb04e6f..7c8f102 100644 --- 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 new file mode 100644 index 0000000..2821bfe --- /dev/null +++ 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 new file mode 100644 index 0000000..e218ee4 --- /dev/null +++ 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 new file mode 100644 index 0000000..844f615 --- /dev/null +++ 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 new file mode 100644 index 0000000..b23784b --- /dev/null +++ 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 new file mode 100644 index 0000000..1469c24 --- /dev/null +++ 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 new file mode 100644 index 0000000..34a85f2 --- /dev/null +++ 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 new file mode 100644 index 0000000..0d92637 --- /dev/null +++ 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 new file mode 100644 index 0000000..a4005fb --- /dev/null +++ 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 new file mode 100644 index 0000000..6185d67 --- /dev/null +++ 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 new file mode 100644 index 0000000..2cda9a7 --- /dev/null +++ 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 new file mode 100644 index 0000000..ca19217 --- /dev/null +++ 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 new file mode 100644 index 0000000..962def7 --- /dev/null +++ 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 new file mode 100644 index 0000000..b72ee50 --- /dev/null +++ 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 new file mode 100644 index 0000000..78d36ce --- /dev/null +++ b/test/vars-C.tri @@ -0,0 +1,2 @@ +!module C +z = t diff --git a/tricu.cabal b/tricu.cabal index 878e117..8846f37 100644 --- 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