From 63504ba93968829af85ea2688ddf751141907cfb Mon Sep 17 00:00:00 2001 From: James Eversole Date: Mon, 27 Jan 2025 12:22:06 -0600 Subject: [PATCH] Rough draft of modules This includes a naive implementation of a module system where imported files have their imports recursively handled, strips the module/import AST nodes, and then evals everything into a flat environment using namespace prefixes like "Module.function". --- demos/equality.tri | 10 ++- demos/levelOrderTraversal.tri | 40 ++++++----- demos/size.tri | 16 +++-- demos/toSource.tri | 40 ++++++----- src/Eval.hs | 3 +- src/FileEval.hs | 131 +++++++++++++++++++++++++++++++--- src/Lexer.hs | 58 ++++++++++----- src/Parser.hs | 22 +++++- src/REPL.hs | 2 +- src/Research.hs | 4 ++ test/Spec.hs | 20 +++--- test/modules-1.tri | 5 ++ test/modules-2.tri | 1 + tricu.cabal | 2 +- 14 files changed, 267 insertions(+), 87 deletions(-) create mode 100644 test/modules-1.tri create mode 100644 test/modules-2.tri 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 dc3b337..bdb022a 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -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 diff --git a/src/FileEval.hs b/src/FileEval.hs index 40a14c4..56f113b 100644 --- a/src/FileEval.hs +++ b/src/FileEval.hs @@ -1,9 +1,12 @@ 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 @@ -11,20 +14,130 @@ import qualified Data.Map as Map 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 = 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 + importedASTs <- concat <$> mapM (processImport moduleName) imports + let namespacedAST = namespaceDefinitions moduleName nonImports + let fullyNamespacedImports = map (namespaceBody moduleName) importedASTs + pure $ fullyNamespacedImports ++ namespacedAST + where + extractModule :: [TricuAST] -> (String, [TricuAST]) + extractModule ((SModule name) : xs) = (name, xs) + extractModule xs = ("", xs) + + isImport :: TricuAST -> Bool + isImport (SImport _ _) = True + isImport _ = False + + processImport :: String -> TricuAST -> IO [TricuAST] + processImport _ (SImport filePath moduleName) = do + importedAST <- preprocessFile filePath + pure $ namespaceDefinitions moduleName importedAST + processImport _ _ = error "Unexpected non-import AST node 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 8064099..e435569 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -20,7 +20,7 @@ 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") @@ -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/Parser.hs b/src/Parser.hs index a8c63f7..ca68488 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -73,10 +73,30 @@ parseSingle input = parseProgramM :: ParserM [TricuAST] parseProgramM = do + skipMany topLevelNewline + moduleNode <- optional parseModuleM + skipMany topLevelNewline + importNodes <- many parseImportM 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 diff --git a/src/REPL.hs b/src/REPL.hs index caa89fc..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 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 1d22b51..d062b1c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -501,19 +501,15 @@ fileEval = testGroup "File evaluation 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/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/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