Rework module system
All checks were successful
Test, Build, and Release / test (push) Successful in 1m37s
Test, Build, and Release / build (push) Successful in 1m14s

Don't require/allow naming a module, instead require that the importer
names it. Allow importing into the local scope with the name !Local.
Simplify namespacing logic. Updates all tests to reflect these changes.
This commit is contained in:
James Eversole 2025-01-30 13:56:09 -06:00
parent 09eedfb609
commit bf1000d174
34 changed files with 218 additions and 239 deletions

View File

@ -1,6 +1,4 @@
!module Equality !import "lib/base.tri" !Local
!import "lib/base.tri" Lib
main = lambdaEqualsTC main = lambdaEqualsTC
@ -28,7 +26,7 @@ not_Lambda? = demo_matchBool demo_false demo_true
-- to different tree representations even if they share extensional behavior. -- to different tree representations even if they share extensional behavior.
-- Let's see if these are the same: -- Let's see if these are the same:
lambdaEqualsTC = Lib.equal? not_TC? not_Lambda? lambdaEqualsTC = equal? not_TC? not_Lambda?
-- Here are some checks to verify their extensional behavior is the same: -- Here are some checks to verify their extensional behavior is the same:
true_TC? = not_TC? demo_false true_TC? = not_TC? demo_false
@ -37,5 +35,5 @@ false_TC? = not_TC? demo_true
true_Lambda? = not_Lambda? demo_false true_Lambda? = not_Lambda? demo_false
false_Lambda? = not_Lambda? demo_true false_Lambda? = not_Lambda? demo_true
bothTrueEqual? = Lib.equal? true_TC? true_Lambda? bothTrueEqual? = equal? true_TC? true_Lambda?
bothFalseEqual? = Lib.equal? false_TC? false_Lambda? bothFalseEqual? = equal? false_TC? false_Lambda?

View File

@ -1,6 +1,4 @@
!module LOT !import "lib/base.tri" !Local
!import "lib/base.tri" Lib
main = exampleTwo main = exampleTwo
-- Level Order Traversal of a labelled binary tree -- Level Order Traversal of a labelled binary tree
@ -19,41 +17,41 @@ main = exampleTwo
-- / / \ -- / / \
-- 4 5 6 -- 4 5 6
label = \node : Lib.head node label = \node : head node
left = (\node : Lib.if (Lib.emptyList? node) left = (\node : if (emptyList? node)
[] []
(Lib.if (Lib.emptyList? (Lib.tail node)) (if (emptyList? (tail node))
[] []
(Lib.head (Lib.tail node)))) (head (tail node))))
right = (\node : Lib.if (Lib.emptyList? node) right = (\node : if (emptyList? node)
[] []
(Lib.if (Lib.emptyList? (Lib.tail node)) (if (emptyList? (tail node))
[] []
(Lib.if (Lib.emptyList? (Lib.tail (Lib.tail node))) (if (emptyList? (tail (tail node)))
[] []
(Lib.head (Lib.tail (Lib.tail node)))))) (head (tail (tail node))))))
processLevel = Lib.y (\self queue : Lib.if (Lib.emptyList? queue) processLevel = y (\self queue : if (emptyList? queue)
[] []
(Lib.pair (Lib.map label queue) (self (Lib.filter (pair (map label queue) (self (filter
(\node : Lib.not? (Lib.emptyList? node)) (\node : not? (emptyList? node))
(Lib.lconcat (Lib.map left queue) (Lib.map right queue)))))) (lconcat (map left queue) (map right queue))))))
levelOrderTraversal_ = \a : processLevel (t a t) levelOrderTraversal_ = \a : processLevel (t a t)
toLineString = Lib.y (\self levels : Lib.if (Lib.emptyList? levels) toLineString = y (\self levels : if (emptyList? levels)
"" ""
(Lib.lconcat (lconcat
(Lib.lconcat (Lib.map (\x : Lib.lconcat x " ") (Lib.head levels)) "") (lconcat (map (\x : lconcat x " ") (head levels)) "")
(Lib.if (Lib.emptyList? (Lib.tail levels)) "" (Lib.lconcat (t (t 10 t) t) (self (Lib.tail levels)))))) (if (emptyList? (tail levels)) "" (lconcat (t (t 10 t) t) (self (tail levels))))))
levelOrderToString = \s : toLineString (levelOrderTraversal_ s) levelOrderToString = \s : toLineString (levelOrderTraversal_ s)
flatten = Lib.foldl (\acc x : Lib.lconcat acc x) "" flatten = foldl (\acc x : lconcat acc x) ""
levelOrderTraversal = \s : Lib.lconcat (t 10 t) (flatten (levelOrderToString s)) levelOrderTraversal = \s : lconcat (t 10 t) (flatten (levelOrderToString s))
exampleOne = levelOrderTraversal [("1") exampleOne = levelOrderTraversal [("1")
[("2") [("4") t t] t] [("2") [("4") t t] t]

View File

@ -1,24 +1,22 @@
!module Size !import "lib/base.tri" !Local
!import "lib/base.tri" Lib
main = size size main = size size
compose = \f g x : f (g x) compose = \f g x : f (g x)
succ = Lib.y (\self : succ = y (\self :
Lib.triage triage
1 1
t t
(Lib.triage (triage
(t (t t)) (t (t t))
(\_ Lib.tail : t t (self Lib.tail)) (\_ tail : t t (self tail))
t)) t))
size = (\x : size = (\x :
(Lib.y (\self x : (y (\self x :
compose succ compose succ
(Lib.triage (triage
(\x : x) (\x : x)
self self
(\x y : compose (self x) (self y)) (\x y : compose (self x) (self y))

View File

@ -1,8 +1,6 @@
!module ToSource !import "lib/base.tri" !Local
!import "lib/base.tri" Lib main = toSource not?
main = toSource Lib.not?
-- Thanks to intensionality, we can inspect the structure of a given value -- 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 -- even if it's a function. This includes lambdas which are eliminated to
-- Tree Calculus (TC) terms during evaluation. -- Tree Calculus (TC) terms during evaluation.
@ -16,29 +14,29 @@ main = toSource Lib.not?
-- triage = (\leaf stem fork : t (t leaf stem) fork) -- triage = (\leaf stem fork : t (t leaf stem) fork)
-- Base case of a single Leaf -- Base case of a single Leaf
sourceLeaf = t (Lib.head "t") sourceLeaf = t (head "t")
-- Stem case -- Stem case
sourceStem = (\convert : (\a rest : sourceStem = (\convert : (\a rest :
t (Lib.head "(") -- Start with a left parenthesis "(". t (head "(") -- Start with a left parenthesis "(".
(t (Lib.head "t") -- Add a "t" (t (head "t") -- Add a "t"
(t (Lib.head " ") -- Add a space. (t (head " ") -- Add a space.
(convert a -- Recursively convert the argument. (convert a -- Recursively convert the argument.
(t (Lib.head ")") rest)))))) -- Close with ")" and append the rest. (t (head ")") rest)))))) -- Close with ")" and append the rest.
-- Fork case -- Fork case
sourceFork = (\convert : (\a b rest : sourceFork = (\convert : (\a b rest :
t (Lib.head "(") -- Start with a left parenthesis "(". t (head "(") -- Start with a left parenthesis "(".
(t (Lib.head "t") -- Add a "t" (t (head "t") -- Add a "t"
(t (Lib.head " ") -- Add a space. (t (head " ") -- Add a space.
(convert a -- Recursively convert the first arg. (convert a -- Recursively convert the first arg.
(t (Lib.head " ") -- Add another space. (t (head " ") -- Add another space.
(convert b -- Recursively convert the second arg. (convert b -- Recursively convert the second arg.
(t (Lib.head ")") rest)))))))) -- Close with ")" and append the rest. (t (head ")") rest)))))))) -- Close with ")" and append the rest.
-- Wrapper around triage -- Wrapper around triage
toSource_ = Lib.y (\self arg : toSource_ = y (\self arg :
Lib.triage triage
sourceLeaf -- `triage` "a" case, Leaf sourceLeaf -- `triage` "a" case, Leaf
(sourceStem self) -- `triage` "b" case, Stem (sourceStem self) -- `triage` "b" case, Stem
(sourceFork self) -- `triage` "c" case, Fork (sourceFork self) -- `triage` "c" case, Fork
@ -47,5 +45,5 @@ toSource_ = Lib.y (\self arg :
-- toSource takes a single TC term and returns a String -- toSource takes a single TC term and returns a String
toSource = \v : toSource_ v "" toSource = \v : toSource_ v ""
exampleOne = toSource Lib.true -- OUT: "(t t)" exampleOne = toSource true -- OUT: "(t t)"
exampleTwo = toSource Lib.not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))" exampleTwo = toSource not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"

View File

@ -70,12 +70,12 @@ elimLambda = go
| body == triageBody = _TRIAGE | body == triageBody = _TRIAGE
where where
triageBody = triageBody =
(SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c)) SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c)
-- Composition optimization -- Composition optimization
go (SLambda [f] (SLambda [g] (SLambda [x] body))) go (SLambda [f] (SLambda [g] (SLambda [x] body)))
| body == composeBody = _COMPOSE | body == SApp (SVar f) (SApp (SVar g) (SVar x)) = _B
where go (SLambda [f] (SLambda [x] (SLambda [y] body)))
composeBody = SApp (SVar f) (SApp (SVar g) (SVar x)) | body == SApp (SApp (SVar f) (SVar y)) (SVar x) = _C
-- General elimination -- General elimination
go (SLambda (v:vs) body) go (SLambda (v:vs) body)
| null vs = toSKI v (elimLambda body) | null vs = toSKI v (elimLambda body)
@ -96,8 +96,9 @@ elimLambda = go
_S = parseSingle "t (t (t t t)) t" _S = parseSingle "t (t (t t t)) t"
_K = parseSingle "t t" _K = parseSingle "t t"
_I = parseSingle "t (t (t t)) t" _I = parseSingle "t (t (t t)) t"
_B = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
_C = parseSingle "t (t (t (t (t t (t (t (t t t)) t))) (t (t (t t (t t))) (t (t (t t t)) t)))) (t t (t t))"
_TRIAGE = parseSingle "t (t (t t (t (t (t t t))))) t" _TRIAGE = parseSingle "t (t (t t (t (t (t t t))))) t"
_COMPOSE = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
isFree :: String -> TricuAST -> Bool isFree :: String -> TricuAST -> Bool
isFree x = Set.member x . freeVars isFree x = Set.member x . freeVars
@ -108,12 +109,12 @@ freeVars (SInt _ ) = Set.empty
freeVars (SStr _ ) = Set.empty freeVars (SStr _ ) = Set.empty
freeVars (SList s ) = foldMap freeVars s freeVars (SList s ) = foldMap freeVars s
freeVars (SApp f a ) = freeVars f <> freeVars a freeVars (SApp f a ) = freeVars f <> freeVars a
freeVars (TLeaf ) = Set.empty freeVars TLeaf = Set.empty
freeVars (SDef _ _ b) = freeVars b freeVars (SDef _ _ b) = freeVars b
freeVars (TStem t ) = freeVars t freeVars (TStem t ) = freeVars t
freeVars (TFork l r ) = freeVars l <> freeVars r freeVars (TFork l r ) = freeVars l <> freeVars r
freeVars (SLambda v b ) = foldr Set.delete (freeVars b) v freeVars (SLambda v b ) = foldr Set.delete (freeVars b) v
freeVars _ = Set.empty freeVars _ = Set.empty
reorderDefs :: Env -> [TricuAST] -> [TricuAST] reorderDefs :: Env -> [TricuAST] -> [TricuAST]
reorderDefs env defs reorderDefs env defs

View File

@ -16,14 +16,11 @@ evaluateFileResult :: FilePath -> IO T
evaluateFileResult filePath = do evaluateFileResult filePath = do
contents <- readFile filePath contents <- readFile filePath
let tokens = lexTricu contents let tokens = lexTricu contents
let moduleName = case parseProgram tokens of
Right ((SModule name) : _) -> name
_ -> ""
case parseProgram tokens of case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError err) Left err -> errorWithoutStackTrace (handleParseError err)
Right _ -> do Right ast -> do
ast <- preprocessFile filePath ast <- preprocessFile filePath
let finalEnv = mainAlias moduleName $ evalTricu Map.empty ast let finalEnv = evalTricu Map.empty ast
case Map.lookup "main" finalEnv of case Map.lookup "main" finalEnv of
Just finalResult -> return finalResult Just finalResult -> return finalResult
Nothing -> errorWithoutStackTrace "No `main` function detected" Nothing -> errorWithoutStackTrace "No `main` function detected"
@ -32,37 +29,24 @@ evaluateFile :: FilePath -> IO Env
evaluateFile filePath = do evaluateFile filePath = do
contents <- readFile filePath contents <- readFile filePath
let tokens = lexTricu contents let tokens = lexTricu contents
let moduleName = case parseProgram tokens of
Right ((SModule name) : _) -> name
_ -> ""
case parseProgram tokens of case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError err) Left err -> errorWithoutStackTrace (handleParseError err)
Right _ -> do Right ast -> do
ast <- preprocessFile filePath ast <- preprocessFile filePath
pure $ mainAlias moduleName $ evalTricu Map.empty ast pure $ evalTricu Map.empty ast
evaluateFileWithContext :: Env -> FilePath -> IO Env evaluateFileWithContext :: Env -> FilePath -> IO Env
evaluateFileWithContext env filePath = do evaluateFileWithContext env filePath = do
contents <- readFile filePath contents <- readFile filePath
let tokens = lexTricu contents let tokens = lexTricu contents
let moduleName = case parseProgram tokens of
Right ((SModule name) : _) -> name
_ -> ""
case parseProgram tokens of case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError err) Left err -> errorWithoutStackTrace (handleParseError err)
Right _ -> do Right ast -> do
ast <- preprocessFile filePath ast <- preprocessFile filePath
pure $ mainAlias moduleName $ evalTricu env ast pure $ 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 -> IO [TricuAST]
preprocessFile filePath = preprocessFile' Set.empty filePath preprocessFile = preprocessFile' Set.empty
preprocessFile' :: Set.Set FilePath -> FilePath -> IO [TricuAST] preprocessFile' :: Set.Set FilePath -> FilePath -> IO [TricuAST]
preprocessFile' inProgress filePath preprocessFile' inProgress filePath
@ -74,77 +58,76 @@ preprocessFile' inProgress filePath
case parseProgram tokens of case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError err) Left err -> errorWithoutStackTrace (handleParseError err)
Right asts -> do Right asts -> do
let (moduleName, restAST) = extractModule asts let (imports, nonImports) = partition isImport asts
let (imports, nonImports) = partition isImport restAST
let newInProgress = Set.insert filePath inProgress let newInProgress = Set.insert filePath inProgress
importedASTs <- concat <$> mapM (processImport newInProgress) imports importedASTs <- concat <$> mapM (processImport newInProgress "") imports
let namespacedAST = namespaceDefinitions moduleName nonImports pure $ importedASTs ++ nonImports
pure $ importedASTs ++ namespacedAST
where where
extractModule :: [TricuAST] -> (String, [TricuAST])
extractModule ((SModule name) : xs) = (name, xs)
extractModule xs = ("", xs)
isImport :: TricuAST -> Bool isImport :: TricuAST -> Bool
isImport (SImport _ _) = True isImport (SImport _ _) = True
isImport _ = False isImport _ = False
processImport :: Set.Set FilePath -> TricuAST -> IO [TricuAST] processImport :: Set.Set FilePath -> String -> TricuAST -> IO [TricuAST]
processImport inProgress (SImport filePath moduleName) = do processImport prog currentModule (SImport path "!Local") = do
importedAST <- preprocessFile' inProgress filePath ast <- preprocessFile' prog path
pure $ namespaceDefinitions moduleName importedAST let defs = filter (not . isImport) ast
processImport _ _ = error "Unexpected non-import in processImport" pure $ map (nsDefinition currentModule) defs
processImport prog _ (SImport path name) = do
ast <- preprocessFile' prog path
let defs = filter (not . isImport) ast
pure $ map (nsDefinition name) defs
processImport _ _ _ = error "Unexpected non-import in processImport"
namespaceDefinitions :: String -> [TricuAST] -> [TricuAST] nsDefinitions :: String -> [TricuAST] -> [TricuAST]
namespaceDefinitions moduleName = map (namespaceDefinition moduleName) nsDefinitions moduleName = map (nsDefinition moduleName)
namespaceDefinition :: String -> TricuAST -> TricuAST nsDefinition :: String -> TricuAST -> TricuAST
namespaceDefinition "" def = def nsDefinition "" def = def
namespaceDefinition moduleName (SDef name args body) nsDefinition moduleName (SDef name args body)
| isPrefixed name = SDef name args (namespaceBody moduleName body) | isPrefixed name = SDef name args (nsBody moduleName body)
| otherwise = SDef (namespaceVariable moduleName name) | otherwise = SDef (nsVariable moduleName name)
args (namespaceBody moduleName body) args (nsBody moduleName body)
namespaceDefinition moduleName other = nsDefinition moduleName other =
namespaceBody moduleName other nsBody moduleName other
namespaceBody :: String -> TricuAST -> TricuAST nsBody :: String -> TricuAST -> TricuAST
namespaceBody moduleName (SVar name) nsBody moduleName (SVar name)
| isPrefixed name = SVar name | isPrefixed name = SVar name
| otherwise = SVar (namespaceVariable moduleName name) | otherwise = SVar (nsVariable moduleName name)
namespaceBody moduleName (SApp func arg) = nsBody moduleName (SApp func arg) =
SApp (namespaceBody moduleName func) (namespaceBody moduleName arg) SApp (nsBody moduleName func) (nsBody moduleName arg)
namespaceBody moduleName (SLambda args body) = nsBody moduleName (SLambda args body) =
SLambda args (namespaceBodyScoped moduleName args body) SLambda args (nsBodyScoped moduleName args body)
namespaceBody moduleName (SList items) = nsBody moduleName (SList items) =
SList (map (namespaceBody moduleName) items) SList (map (nsBody moduleName) items)
namespaceBody moduleName (TFork left right) = nsBody moduleName (TFork left right) =
TFork (namespaceBody moduleName left) (namespaceBody moduleName right) TFork (nsBody moduleName left) (nsBody moduleName right)
namespaceBody moduleName (TStem subtree) = nsBody moduleName (TStem subtree) =
TStem (namespaceBody moduleName subtree) TStem (nsBody moduleName subtree)
namespaceBody moduleName (SDef name args body) nsBody moduleName (SDef name args body)
| isPrefixed name = SDef name args (namespaceBody moduleName body) | isPrefixed name = SDef name args (nsBody moduleName body)
| otherwise = SDef (namespaceVariable moduleName name) | otherwise = SDef (nsVariable moduleName name)
args (namespaceBody moduleName body) args (nsBody moduleName body)
namespaceBody _ other = other nsBody _ other = other
namespaceBodyScoped :: String -> [String] -> TricuAST -> TricuAST nsBodyScoped :: String -> [String] -> TricuAST -> TricuAST
namespaceBodyScoped moduleName args body = case body of nsBodyScoped moduleName args body = case body of
SVar name -> SVar name ->
if name `elem` args if name `elem` args
then SVar name then SVar name
else namespaceBody moduleName (SVar name) else nsBody moduleName (SVar name)
SApp func arg -> SApp (namespaceBodyScoped moduleName args func) (namespaceBodyScoped moduleName args arg) SApp func arg -> SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg)
SLambda innerArgs innerBody -> SLambda innerArgs (namespaceBodyScoped moduleName (args ++ innerArgs) innerBody) SLambda innerArgs innerBody -> SLambda innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
SList items -> SList (map (namespaceBodyScoped moduleName args) items) SList items -> SList (map (nsBodyScoped moduleName args) items)
TFork left right -> TFork (namespaceBodyScoped moduleName args left) (namespaceBodyScoped moduleName args right) TFork left right -> TFork (nsBodyScoped moduleName args left) (nsBodyScoped moduleName args right)
TStem subtree -> TStem (namespaceBodyScoped moduleName args subtree) TStem subtree -> TStem (nsBodyScoped moduleName args subtree)
SDef name innerArgs innerBody -> SDef name innerArgs innerBody ->
SDef (namespaceVariable moduleName name) innerArgs (namespaceBodyScoped moduleName (args ++ innerArgs) innerBody) SDef (nsVariable moduleName name) innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
other -> other other -> other
isPrefixed :: String -> Bool isPrefixed :: String -> Bool
isPrefixed name = '.' `elem` name isPrefixed name = '.' `elem` name
namespaceVariable :: String -> String -> String nsVariable :: String -> String -> String
namespaceVariable "" name = name nsVariable "" name = name
namespaceVariable moduleName name = moduleName ++ "." ++ name nsVariable moduleName name = moduleName ++ "." ++ name

View File

@ -12,39 +12,71 @@ import qualified Data.Set as Set
type Lexer = Parsec Void String type Lexer = Parsec Void String
tricuLexer :: Lexer [LToken]
tricuLexer = do
sc
header <- many $ do
tok <- choice
[ try lImport
, lnewline
]
sc
pure tok
tokens <- many $ do
tok <- choice tricuLexer'
sc
pure tok
sc
eof
pure (header ++ tokens)
where
tricuLexer' =
[ try lnewline
, try namespace
, try dot
, 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
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
Right tokens -> tokens
keywordT :: Lexer LToken keywordT :: Lexer LToken
keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
identifier :: Lexer LToken identifier :: Lexer LToken
identifier = do identifier = do
first <- letterChar <|> char '_' first <- lowerChar <|> char '_'
rest <- many $ letterChar rest <- many $ letterChar
<|> digitChar <|> digitChar <|> char '_' <|> char '-' <|> char '?'
<|> char '_' <|> char '-' <|> char '?' <|> char '.' <|> char '$' <|> char '#' <|> char '@' <|> char '%'
<|> char '$' <|> char '#' <|> char '@' <|> char '%'
let name = first : rest let name = first : rest
if (name == "t" || name == "!result") if (name == "t" || name == "!result")
then fail "Keywords (`t`, `!result`) cannot be used as an identifier" then fail "Keywords (`t`, `!result`) cannot be used as an identifier"
else return (LIdentifier name) else return (LIdentifier name)
integerLiteral :: Lexer LToken namespace :: Lexer LToken
integerLiteral = do namespace = do
num <- some digitChar name <- try (string "!Local") <|> do
return (LIntegerLiteral (read num)) first <- upperChar
rest <- many (letterChar <|> digitChar)
return (first:rest)
return (LNamespace name)
stringLiteral :: Lexer LToken dot :: Lexer LToken
stringLiteral = do dot = char '.' *> pure LDot
char '"'
content <- many (noneOf ['"'])
char '"' --"
return (LStringLiteral content)
lModule :: Lexer LToken
lModule = do
_ <- string "!module"
space1
LIdentifier moduleName <- identifier
return (LModule moduleName)
lImport :: Lexer LToken lImport :: Lexer LToken
lImport = do lImport = do
@ -52,7 +84,7 @@ lImport = do
space1 space1
LStringLiteral path <- stringLiteral LStringLiteral path <- stringLiteral
space1 space1
LIdentifier name <- identifier LNamespace name <- namespace
return (LImport path name) return (LImport path name)
assign :: Lexer LToken assign :: Lexer LToken
@ -85,41 +117,15 @@ sc = space
(skipLineComment "--") (skipLineComment "--")
(skipBlockComment "|-" "-|") (skipBlockComment "|-" "-|")
tricuLexer :: Lexer [LToken] integerLiteral :: Lexer LToken
tricuLexer = do integerLiteral = do
sc num <- some digitChar
header <- many $ do return (LIntegerLiteral (read num))
tok <- choice
[ try lModule stringLiteral :: Lexer LToken
, try lImport stringLiteral = do
, lnewline char '"'
] content <- many (noneOf ['"'])
sc char '"' --"
pure tok return (LStringLiteral content)
tokens <- many $ do
tok <- choice tricuLexer'
sc
pure tok
sc
eof
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
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
Right tokens -> tokens

View File

@ -73,8 +73,6 @@ parseSingle input =
parseProgramM :: ParserM [TricuAST] parseProgramM :: ParserM [TricuAST]
parseProgramM = do parseProgramM = do
skipMany topLevelNewline
moduleNode <- optional parseModuleM
skipMany topLevelNewline skipMany topLevelNewline
importNodes <- many (do importNodes <- many (do
node <- parseImportM node <- parseImportM
@ -83,16 +81,7 @@ parseProgramM = do
skipMany topLevelNewline skipMany topLevelNewline
exprs <- sepEndBy parseOneExpression (some topLevelNewline) exprs <- sepEndBy parseOneExpression (some topLevelNewline)
skipMany topLevelNewline skipMany topLevelNewline
return (maybe [] (: []) moduleNode ++ importNodes ++ exprs) return (importNodes ++ exprs)
parseModuleM :: ParserM TricuAST
parseModuleM = do
LModule moduleName <- satisfyM isModule
pure (SModule moduleName)
where
isModule (LModule _) = True
isModule _ = False
parseImportM :: ParserM TricuAST parseImportM :: ParserM TricuAST
parseImportM = do parseImportM = do
@ -266,12 +255,19 @@ parseSingleItemM = do
parseVarM :: ParserM TricuAST parseVarM :: ParserM TricuAST
parseVarM = do parseVarM = do
satisfyM (\case LIdentifier _ -> True; _ -> False) >>= \case token <- satisfyM (\case
LNamespace _ -> True
LIdentifier _ -> True
_ -> False)
case token of
LNamespace ns -> do
_ <- satisfyM (== LDot)
LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False)
pure $ SVar (ns ++ "." ++ name)
LIdentifier name LIdentifier name
| name == "t" || name == "!result" -> | name == "t" || name == "!result" ->
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.") fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
| otherwise -> | otherwise -> pure (SVar name)
pure (SVar name)
_ -> fail "Unexpected token while parsing variable" _ -> fail "Unexpected token while parsing variable"
parseIntLiteralM :: ParserM TricuAST parseIntLiteralM :: ParserM TricuAST

View File

@ -26,7 +26,6 @@ data TricuAST
| TFork TricuAST TricuAST | TFork TricuAST TricuAST
| SLambda [String] TricuAST | SLambda [String] TricuAST
| SEmpty | SEmpty
| SModule String
| SImport String String | SImport String String
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
@ -34,17 +33,18 @@ data TricuAST
data LToken data LToken
= LKeywordT = LKeywordT
| LIdentifier String | LIdentifier String
| LNamespace String
| LIntegerLiteral Int | LIntegerLiteral Int
| LStringLiteral String | LStringLiteral String
| LAssign | LAssign
| LColon | LColon
| LDot
| LBackslash | LBackslash
| LOpenParen | LOpenParen
| LCloseParen | LCloseParen
| LOpenBracket | LOpenBracket
| LCloseBracket | LCloseBracket
| LNewline | LNewline
| LModule String
| LImport String String | LImport String String
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)

View File

@ -532,6 +532,9 @@ modules = testGroup "Test modules"
, testCase "Lambda expression namespaces" $ do , testCase "Lambda expression namespaces" $ do
res <- liftIO $ evaluateFileResult "./test/lambda-A.tri" res <- liftIO $ evaluateFileResult "./test/lambda-A.tri"
res @?= Leaf res @?= Leaf
, testCase "Local namespace import chain" $ do
res <- liftIO $ evaluateFileResult "./test/local-ns/1.tri"
res @?= Fork (Stem Leaf) (Fork (Stem Leaf) Leaf)
] ]

View File

@ -1 +0,0 @@
t (t (t (t (t t) (t t t)) t) t t) t

View File

@ -1 +0,0 @@
x = t (t t) t

View File

@ -1,4 +1,3 @@
!module Cycle
!import "test/cycle-2.tri" Cycle2 !import "test/cycle-2.tri" Cycle2

View File

@ -1,4 +1,3 @@
!module Cycle2
!import "test/cycle-1.tri" Cycle1 !import "test/cycle-1.tri" Cycle1

View File

@ -1,2 +1 @@
!module A
main = (\x : x) t main = (\x : x) t

4
test/local-ns/1.tri Normal file
View File

@ -0,0 +1,4 @@
!import "test/local-ns/2.tri" Two
main = Two.x

2
test/local-ns/2.tri Normal file
View File

@ -0,0 +1,2 @@
!import "test/local-ns/3.tri" !Local

2
test/local-ns/3.tri Normal file
View File

@ -0,0 +1,2 @@
x = 3

View File

@ -1,5 +0,0 @@
!module Test
!import "lib/base.tri" Lib
main = Lib.not? t

View File

@ -1 +0,0 @@
n = t t t

View File

@ -1,3 +1,2 @@
!module A
!import "./test/multi-level-B.tri" B !import "./test/multi-level-B.tri" B
main = B.main main = B.main

View File

@ -1,3 +1,2 @@
!module B
!import "./test/multi-level-C.tri" C !import "./test/multi-level-C.tri" C
main = C.val main = C.val

View File

@ -1,2 +1 @@
!module C
val = t val = t

7
test/named-imports/1.tri Normal file
View File

@ -0,0 +1,7 @@
!import "lib/base.tri"
!import "test/named-imports/2.tri"
!import "test/named-imports/3.tri" ThreeRenamed
main = equal? (equal? Two.x 2) (equal? ThreeRenamed.x 3)

2
test/named-imports/2.tri Normal file
View File

@ -0,0 +1,2 @@
x = 2

2
test/named-imports/3.tri Normal file
View File

@ -0,0 +1,2 @@
x = 3

View File

@ -1,3 +1,2 @@
!module A
!import "./test/namespace-B.tri" B !import "./test/namespace-B.tri" B
main = B.x main = B.x

View File

@ -1,2 +1 @@
!module B
x = t x = t

View File

@ -1 +0,0 @@
namedTerm = undefinedForTesting

View File

@ -1,2 +1 @@
!module A
main = undefinedVar main = undefinedVar

View File

@ -1,4 +1,3 @@
!module A
!import "./test/vars-B.tri" B !import "./test/vars-B.tri" B

View File

@ -1,2 +1 @@
!module B
y = \x : x y = \x : x

View File

@ -1,2 +1 @@
!module C
z = t z = t

View File

@ -1,7 +1,7 @@
cabal-version: 1.12 cabal-version: 1.12
name: tricu name: tricu
version: 0.12.0 version: 0.13.0
description: A micro-language for exploring Tree Calculus description: A micro-language for exploring Tree Calculus
author: James Eversole author: James Eversole
maintainer: james@eversole.co maintainer: james@eversole.co