# Modules
Basic implementation of a module system including tests.
This commit is contained in:
		| @ -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 | ||||
|  | ||||
|  | ||||
| @ -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? | ||||
|  | ||||
| @ -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]  | ||||
|  | ||||
| @ -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)) | ||||
|  | ||||
| @ -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)))" | ||||
|  | ||||
							
								
								
									
										17
									
								
								src/Eval.hs
									
									
									
									
									
								
							
							
						
						
									
										17
									
								
								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 | ||||
|  | ||||
							
								
								
									
										138
									
								
								src/FileEval.hs
									
									
									
									
									
								
							
							
						
						
									
										138
									
								
								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 | ||||
|  | ||||
							
								
								
									
										62
									
								
								src/Lexer.hs
									
									
									
									
									
								
							
							
						
						
									
										62
									
								
								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 | ||||
|  | ||||
| @ -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 | ||||
|  | ||||
| @ -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) | ||||
|  | ||||
| @ -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 | ||||
|  | ||||
| @ -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 | ||||
|  | ||||
							
								
								
									
										66
									
								
								test/Spec.hs
									
									
									
									
									
								
							
							
						
						
									
										66
									
								
								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 \"" | ||||
|   ] | ||||
|  | ||||
							
								
								
									
										5
									
								
								test/cycle-1.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										5
									
								
								test/cycle-1.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,5 @@ | ||||
| !module Cycle | ||||
|  | ||||
| !import "test/cycle-2.tri" Cycle2 | ||||
|  | ||||
| cycle1 = t Cycle2.cycle2 | ||||
							
								
								
									
										5
									
								
								test/cycle-2.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										5
									
								
								test/cycle-2.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,5 @@ | ||||
| !module Cycle2 | ||||
|  | ||||
| !import "test/cycle-1.tri" Cycle1 | ||||
|  | ||||
| cycle2 = t Cycle1.cycle1 | ||||
							
								
								
									
										2
									
								
								test/lambda-A.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										2
									
								
								test/lambda-A.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,2 @@ | ||||
| !module A | ||||
| main = (\x : x) t | ||||
							
								
								
									
										5
									
								
								test/modules-1.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										5
									
								
								test/modules-1.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,5 @@ | ||||
| !module Test | ||||
|  | ||||
| !import "lib/base.tri" Lib | ||||
|  | ||||
| main = Lib.not? t | ||||
							
								
								
									
										1
									
								
								test/modules-2.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										1
									
								
								test/modules-2.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1 @@ | ||||
| n = t t t | ||||
							
								
								
									
										3
									
								
								test/multi-level-A.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										3
									
								
								test/multi-level-A.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,3 @@ | ||||
| !module A | ||||
| !import "./test/multi-level-B.tri" B | ||||
| main = B.main | ||||
							
								
								
									
										3
									
								
								test/multi-level-B.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										3
									
								
								test/multi-level-B.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,3 @@ | ||||
| !module B | ||||
| !import "./test/multi-level-C.tri" C | ||||
| main = C.val | ||||
							
								
								
									
										2
									
								
								test/multi-level-C.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										2
									
								
								test/multi-level-C.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,2 @@ | ||||
| !module C | ||||
| val = t | ||||
							
								
								
									
										3
									
								
								test/namespace-A.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										3
									
								
								test/namespace-A.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,3 @@ | ||||
| !module A | ||||
| !import "./test/namespace-B.tri" B | ||||
| main = B.x | ||||
							
								
								
									
										2
									
								
								test/namespace-B.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										2
									
								
								test/namespace-B.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,2 @@ | ||||
| !module B | ||||
| x = t | ||||
							
								
								
									
										2
									
								
								test/unresolved-A.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										2
									
								
								test/unresolved-A.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,2 @@ | ||||
| !module A | ||||
| main = undefinedVar | ||||
							
								
								
									
										7
									
								
								test/vars-A.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										7
									
								
								test/vars-A.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,7 @@ | ||||
| !module A | ||||
|  | ||||
| !import "./test/vars-B.tri" B | ||||
|  | ||||
| !import "./test/vars-C.tri" C | ||||
|  | ||||
| main = B.y (C.z) | ||||
							
								
								
									
										2
									
								
								test/vars-B.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										2
									
								
								test/vars-B.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,2 @@ | ||||
| !module B | ||||
| y = \x : x | ||||
							
								
								
									
										2
									
								
								test/vars-C.tri
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										2
									
								
								test/vars-C.tri
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,2 @@ | ||||
| !module C | ||||
| z = t | ||||
| @ -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 | ||||
|  | ||||
		Reference in New Issue
	
	Block a user
	 James Eversole
					James Eversole