# Modules
Basic implementation of a module system including tests.
This commit is contained in:
parent
f71f88dce3
commit
87aed72ab2
@ -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.
|
||||
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 (head ")") rest)))))) -- Close with ")" and append the rest.
|
||||
(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.
|
||||
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 (head " ") -- Add another space.
|
||||
(t (Lib.head " ") -- Add another space.
|
||||
(convert b -- Recursively convert the second arg.
|
||||
(t (head ")") rest)))))))) -- Close with ")" and append the rest.
|
||||
(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)))"
|
||||
|
15
src/Eval.hs
15
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
|
||||
|
||||
@ -113,6 +113,7 @@ 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
|
||||
|
132
src/FileEval.hs
132
src/FileEval.hs
@ -1,18 +1,29 @@
|
||||
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
|
||||
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"
|
||||
@ -20,11 +31,120 @@ evaluateFileResult filePath = do
|
||||
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
|
||||
|
32
src/Lexer.hs
32
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,13 +88,21 @@ 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
|
||||
pure (header ++ tokens)
|
||||
where
|
||||
tricuLexer' =
|
||||
[ try lnewline
|
||||
|
@ -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
|
||||
|
62
test/Spec.hs
62
test/Spec.hs
@ -9,6 +9,7 @@ import Research
|
||||
|
||||
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
|
||||
@ -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
|
||||
|
Loading…
x
Reference in New Issue
Block a user