Rework module system
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:
parent
09eedfb609
commit
bf1000d174
@ -1,6 +1,4 @@
|
||||
!module Equality
|
||||
|
||||
!import "lib/base.tri" Lib
|
||||
!import "lib/base.tri" !Local
|
||||
|
||||
main = lambdaEqualsTC
|
||||
|
||||
@ -28,7 +26,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 = Lib.equal? not_TC? not_Lambda?
|
||||
lambdaEqualsTC = equal? not_TC? not_Lambda?
|
||||
|
||||
-- Here are some checks to verify their extensional behavior is the same:
|
||||
true_TC? = not_TC? demo_false
|
||||
@ -37,5 +35,5 @@ false_TC? = not_TC? demo_true
|
||||
true_Lambda? = not_Lambda? demo_false
|
||||
false_Lambda? = not_Lambda? demo_true
|
||||
|
||||
bothTrueEqual? = Lib.equal? true_TC? true_Lambda?
|
||||
bothFalseEqual? = Lib.equal? false_TC? false_Lambda?
|
||||
bothTrueEqual? = equal? true_TC? true_Lambda?
|
||||
bothFalseEqual? = equal? false_TC? false_Lambda?
|
||||
|
@ -1,6 +1,4 @@
|
||||
!module LOT
|
||||
|
||||
!import "lib/base.tri" Lib
|
||||
!import "lib/base.tri" !Local
|
||||
|
||||
main = exampleTwo
|
||||
-- Level Order Traversal of a labelled binary tree
|
||||
@ -19,41 +17,41 @@ main = exampleTwo
|
||||
-- / / \
|
||||
-- 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
|
||||
(\node : Lib.not? (Lib.emptyList? node))
|
||||
(Lib.lconcat (Lib.map left queue) (Lib.map right queue))))))
|
||||
(pair (map label queue) (self (filter
|
||||
(\node : not? (emptyList? node))
|
||||
(lconcat (map left queue) (map right queue))))))
|
||||
|
||||
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
|
||||
(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))))))
|
||||
(lconcat
|
||||
(lconcat (map (\x : lconcat x " ") (head levels)) "")
|
||||
(if (emptyList? (tail levels)) "" (lconcat (t (t 10 t) t) (self (tail levels))))))
|
||||
|
||||
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")
|
||||
[("2") [("4") t t] t]
|
||||
|
@ -1,24 +1,22 @@
|
||||
!module Size
|
||||
|
||||
!import "lib/base.tri" Lib
|
||||
!import "lib/base.tri" !Local
|
||||
|
||||
main = size size
|
||||
|
||||
compose = \f g x : f (g x)
|
||||
|
||||
succ = Lib.y (\self :
|
||||
Lib.triage
|
||||
succ = y (\self :
|
||||
triage
|
||||
1
|
||||
t
|
||||
(Lib.triage
|
||||
(triage
|
||||
(t (t t))
|
||||
(\_ Lib.tail : t t (self Lib.tail))
|
||||
(\_ tail : t t (self tail))
|
||||
t))
|
||||
|
||||
size = (\x :
|
||||
(Lib.y (\self x :
|
||||
(y (\self x :
|
||||
compose succ
|
||||
(Lib.triage
|
||||
(triage
|
||||
(\x : x)
|
||||
self
|
||||
(\x y : compose (self x) (self y))
|
||||
|
@ -1,8 +1,6 @@
|
||||
!module ToSource
|
||||
!import "lib/base.tri" !Local
|
||||
|
||||
!import "lib/base.tri" Lib
|
||||
|
||||
main = toSource Lib.not?
|
||||
main = toSource 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.
|
||||
@ -16,29 +14,29 @@ main = toSource Lib.not?
|
||||
-- triage = (\leaf stem fork : t (t leaf stem) fork)
|
||||
|
||||
-- Base case of a single Leaf
|
||||
sourceLeaf = t (Lib.head "t")
|
||||
sourceLeaf = t (head "t")
|
||||
|
||||
-- Stem case
|
||||
sourceStem = (\convert : (\a rest :
|
||||
t (Lib.head "(") -- Start with a left parenthesis "(".
|
||||
(t (Lib.head "t") -- Add a "t"
|
||||
(t (Lib.head " ") -- Add a space.
|
||||
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 (Lib.head ")") rest)))))) -- Close with ")" and append the rest.
|
||||
(t (head ")") rest)))))) -- Close with ")" and append the rest.
|
||||
|
||||
-- Fork case
|
||||
sourceFork = (\convert : (\a b rest :
|
||||
t (Lib.head "(") -- Start with a left parenthesis "(".
|
||||
(t (Lib.head "t") -- Add a "t"
|
||||
(t (Lib.head " ") -- Add a space.
|
||||
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 (Lib.head " ") -- Add another space.
|
||||
(t (head " ") -- Add another space.
|
||||
(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
|
||||
toSource_ = Lib.y (\self arg :
|
||||
Lib.triage
|
||||
toSource_ = y (\self arg :
|
||||
triage
|
||||
sourceLeaf -- `triage` "a" case, Leaf
|
||||
(sourceStem self) -- `triage` "b" case, Stem
|
||||
(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 = \v : toSource_ v ""
|
||||
|
||||
exampleOne = toSource Lib.true -- OUT: "(t t)"
|
||||
exampleTwo = toSource Lib.not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"
|
||||
exampleOne = toSource true -- OUT: "(t t)"
|
||||
exampleTwo = toSource not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"
|
||||
|
13
src/Eval.hs
13
src/Eval.hs
@ -70,12 +70,12 @@ elimLambda = go
|
||||
| body == triageBody = _TRIAGE
|
||||
where
|
||||
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
|
||||
go (SLambda [f] (SLambda [g] (SLambda [x] body)))
|
||||
| body == composeBody = _COMPOSE
|
||||
where
|
||||
composeBody = SApp (SVar f) (SApp (SVar g) (SVar x))
|
||||
| body == SApp (SVar f) (SApp (SVar g) (SVar x)) = _B
|
||||
go (SLambda [f] (SLambda [x] (SLambda [y] body)))
|
||||
| body == SApp (SApp (SVar f) (SVar y)) (SVar x) = _C
|
||||
-- General elimination
|
||||
go (SLambda (v:vs) body)
|
||||
| null vs = toSKI v (elimLambda body)
|
||||
@ -96,8 +96,9 @@ elimLambda = go
|
||||
_S = parseSingle "t (t (t t t)) t"
|
||||
_K = parseSingle "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"
|
||||
_COMPOSE = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
|
||||
|
||||
isFree :: String -> TricuAST -> Bool
|
||||
isFree x = Set.member x . freeVars
|
||||
@ -108,7 +109,7 @@ freeVars (SInt _ ) = Set.empty
|
||||
freeVars (SStr _ ) = Set.empty
|
||||
freeVars (SList s ) = foldMap freeVars s
|
||||
freeVars (SApp f a ) = freeVars f <> freeVars a
|
||||
freeVars (TLeaf ) = Set.empty
|
||||
freeVars TLeaf = Set.empty
|
||||
freeVars (SDef _ _ b) = freeVars b
|
||||
freeVars (TStem t ) = freeVars t
|
||||
freeVars (TFork l r ) = freeVars l <> freeVars r
|
||||
|
137
src/FileEval.hs
137
src/FileEval.hs
@ -16,14 +16,11 @@ evaluateFileResult :: FilePath -> IO T
|
||||
evaluateFileResult filePath = do
|
||||
contents <- readFile filePath
|
||||
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
|
||||
Right ast -> do
|
||||
ast <- preprocessFile filePath
|
||||
let finalEnv = mainAlias moduleName $ evalTricu Map.empty ast
|
||||
let finalEnv = evalTricu Map.empty ast
|
||||
case Map.lookup "main" finalEnv of
|
||||
Just finalResult -> return finalResult
|
||||
Nothing -> errorWithoutStackTrace "No `main` function detected"
|
||||
@ -32,37 +29,24 @@ evaluateFile :: FilePath -> IO Env
|
||||
evaluateFile filePath = do
|
||||
contents <- readFile filePath
|
||||
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
|
||||
Right ast -> do
|
||||
ast <- preprocessFile filePath
|
||||
pure $ mainAlias moduleName $ evalTricu Map.empty ast
|
||||
pure $ evalTricu Map.empty ast
|
||||
|
||||
evaluateFileWithContext :: Env -> FilePath -> IO Env
|
||||
evaluateFileWithContext env filePath = do
|
||||
contents <- readFile filePath
|
||||
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
|
||||
Right ast -> 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
|
||||
pure $ evalTricu env ast
|
||||
|
||||
preprocessFile :: FilePath -> IO [TricuAST]
|
||||
preprocessFile filePath = preprocessFile' Set.empty filePath
|
||||
preprocessFile = preprocessFile' Set.empty
|
||||
|
||||
preprocessFile' :: Set.Set FilePath -> FilePath -> IO [TricuAST]
|
||||
preprocessFile' inProgress filePath
|
||||
@ -74,77 +58,76 @@ preprocessFile' inProgress filePath
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError err)
|
||||
Right asts -> do
|
||||
let (moduleName, restAST) = extractModule asts
|
||||
let (imports, nonImports) = partition isImport restAST
|
||||
let (imports, nonImports) = partition isImport asts
|
||||
let newInProgress = Set.insert filePath inProgress
|
||||
importedASTs <- concat <$> mapM (processImport newInProgress) imports
|
||||
let namespacedAST = namespaceDefinitions moduleName nonImports
|
||||
pure $ importedASTs ++ namespacedAST
|
||||
importedASTs <- concat <$> mapM (processImport newInProgress "") imports
|
||||
pure $ importedASTs ++ nonImports
|
||||
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"
|
||||
processImport :: Set.Set FilePath -> String -> TricuAST -> IO [TricuAST]
|
||||
processImport prog currentModule (SImport path "!Local") = do
|
||||
ast <- preprocessFile' prog path
|
||||
let defs = filter (not . isImport) ast
|
||||
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]
|
||||
namespaceDefinitions moduleName = map (namespaceDefinition moduleName)
|
||||
nsDefinitions :: String -> [TricuAST] -> [TricuAST]
|
||||
nsDefinitions moduleName = map (nsDefinition 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
|
||||
nsDefinition :: String -> TricuAST -> TricuAST
|
||||
nsDefinition "" def = def
|
||||
nsDefinition moduleName (SDef name args body)
|
||||
| isPrefixed name = SDef name args (nsBody moduleName body)
|
||||
| otherwise = SDef (nsVariable moduleName name)
|
||||
args (nsBody moduleName body)
|
||||
nsDefinition moduleName other =
|
||||
nsBody moduleName other
|
||||
|
||||
namespaceBody :: String -> TricuAST -> TricuAST
|
||||
namespaceBody moduleName (SVar name)
|
||||
nsBody :: String -> TricuAST -> TricuAST
|
||||
nsBody 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
|
||||
| otherwise = SVar (nsVariable moduleName name)
|
||||
nsBody moduleName (SApp func arg) =
|
||||
SApp (nsBody moduleName func) (nsBody moduleName arg)
|
||||
nsBody moduleName (SLambda args body) =
|
||||
SLambda args (nsBodyScoped moduleName args body)
|
||||
nsBody moduleName (SList items) =
|
||||
SList (map (nsBody moduleName) items)
|
||||
nsBody moduleName (TFork left right) =
|
||||
TFork (nsBody moduleName left) (nsBody moduleName right)
|
||||
nsBody moduleName (TStem subtree) =
|
||||
TStem (nsBody moduleName subtree)
|
||||
nsBody moduleName (SDef name args body)
|
||||
| isPrefixed name = SDef name args (nsBody moduleName body)
|
||||
| otherwise = SDef (nsVariable moduleName name)
|
||||
args (nsBody moduleName body)
|
||||
nsBody _ other = other
|
||||
|
||||
namespaceBodyScoped :: String -> [String] -> TricuAST -> TricuAST
|
||||
namespaceBodyScoped moduleName args body = case body of
|
||||
nsBodyScoped :: String -> [String] -> TricuAST -> TricuAST
|
||||
nsBodyScoped 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)
|
||||
else nsBody moduleName (SVar name)
|
||||
SApp func arg -> SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg)
|
||||
SLambda innerArgs innerBody -> SLambda innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
|
||||
SList items -> SList (map (nsBodyScoped moduleName args) items)
|
||||
TFork left right -> TFork (nsBodyScoped moduleName args left) (nsBodyScoped moduleName args right)
|
||||
TStem subtree -> TStem (nsBodyScoped moduleName args subtree)
|
||||
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
|
||||
|
||||
isPrefixed :: String -> Bool
|
||||
isPrefixed name = '.' `elem` name
|
||||
|
||||
namespaceVariable :: String -> String -> String
|
||||
namespaceVariable "" name = name
|
||||
namespaceVariable moduleName name = moduleName ++ "." ++ name
|
||||
nsVariable :: String -> String -> String
|
||||
nsVariable "" name = name
|
||||
nsVariable moduleName name = moduleName ++ "." ++ name
|
||||
|
122
src/Lexer.hs
122
src/Lexer.hs
@ -12,39 +12,71 @@ import qualified Data.Set as Set
|
||||
|
||||
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 = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
|
||||
|
||||
identifier :: Lexer LToken
|
||||
identifier = do
|
||||
first <- letterChar <|> char '_'
|
||||
first <- lowerChar <|> char '_'
|
||||
rest <- many $ letterChar
|
||||
<|> digitChar
|
||||
<|> char '_' <|> char '-' <|> char '?' <|> char '.'
|
||||
<|> digitChar <|> 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"
|
||||
else return (LIdentifier name)
|
||||
|
||||
integerLiteral :: Lexer LToken
|
||||
integerLiteral = do
|
||||
num <- some digitChar
|
||||
return (LIntegerLiteral (read num))
|
||||
namespace :: Lexer LToken
|
||||
namespace = do
|
||||
name <- try (string "!Local") <|> do
|
||||
first <- upperChar
|
||||
rest <- many (letterChar <|> digitChar)
|
||||
return (first:rest)
|
||||
return (LNamespace name)
|
||||
|
||||
stringLiteral :: Lexer LToken
|
||||
stringLiteral = do
|
||||
char '"'
|
||||
content <- many (noneOf ['"'])
|
||||
char '"' --"
|
||||
return (LStringLiteral content)
|
||||
|
||||
lModule :: Lexer LToken
|
||||
lModule = do
|
||||
_ <- string "!module"
|
||||
space1
|
||||
LIdentifier moduleName <- identifier
|
||||
return (LModule moduleName)
|
||||
dot :: Lexer LToken
|
||||
dot = char '.' *> pure LDot
|
||||
|
||||
lImport :: Lexer LToken
|
||||
lImport = do
|
||||
@ -52,7 +84,7 @@ lImport = do
|
||||
space1
|
||||
LStringLiteral path <- stringLiteral
|
||||
space1
|
||||
LIdentifier name <- identifier
|
||||
LNamespace name <- namespace
|
||||
return (LImport path name)
|
||||
|
||||
assign :: Lexer LToken
|
||||
@ -85,41 +117,15 @@ sc = space
|
||||
(skipLineComment "--")
|
||||
(skipBlockComment "|-" "-|")
|
||||
|
||||
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 (header ++ tokens)
|
||||
where
|
||||
tricuLexer' =
|
||||
[ try lnewline
|
||||
, try identifier
|
||||
, try keywordT
|
||||
, try integerLiteral
|
||||
, try stringLiteral
|
||||
, assign
|
||||
, colon
|
||||
, backslash
|
||||
, openParen
|
||||
, closeParen
|
||||
, openBracket
|
||||
, closeBracket
|
||||
]
|
||||
integerLiteral :: Lexer LToken
|
||||
integerLiteral = do
|
||||
num <- some digitChar
|
||||
return (LIntegerLiteral (read num))
|
||||
|
||||
stringLiteral :: Lexer LToken
|
||||
stringLiteral = do
|
||||
char '"'
|
||||
content <- many (noneOf ['"'])
|
||||
char '"' --"
|
||||
return (LStringLiteral content)
|
||||
|
||||
lexTricu :: String -> [LToken]
|
||||
lexTricu input = case runParser tricuLexer "" input of
|
||||
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
|
||||
Right tokens -> tokens
|
||||
|
@ -73,8 +73,6 @@ parseSingle input =
|
||||
|
||||
parseProgramM :: ParserM [TricuAST]
|
||||
parseProgramM = do
|
||||
skipMany topLevelNewline
|
||||
moduleNode <- optional parseModuleM
|
||||
skipMany topLevelNewline
|
||||
importNodes <- many (do
|
||||
node <- parseImportM
|
||||
@ -83,16 +81,7 @@ parseProgramM = do
|
||||
skipMany topLevelNewline
|
||||
exprs <- sepEndBy parseOneExpression (some topLevelNewline)
|
||||
skipMany topLevelNewline
|
||||
return (maybe [] (: []) moduleNode ++ importNodes ++ exprs)
|
||||
|
||||
|
||||
parseModuleM :: ParserM TricuAST
|
||||
parseModuleM = do
|
||||
LModule moduleName <- satisfyM isModule
|
||||
pure (SModule moduleName)
|
||||
where
|
||||
isModule (LModule _) = True
|
||||
isModule _ = False
|
||||
return (importNodes ++ exprs)
|
||||
|
||||
parseImportM :: ParserM TricuAST
|
||||
parseImportM = do
|
||||
@ -266,12 +255,19 @@ parseSingleItemM = do
|
||||
|
||||
parseVarM :: ParserM TricuAST
|
||||
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
|
||||
| name == "t" || name == "!result" ->
|
||||
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
||||
| otherwise ->
|
||||
pure (SVar name)
|
||||
| otherwise -> pure (SVar name)
|
||||
_ -> fail "Unexpected token while parsing variable"
|
||||
|
||||
parseIntLiteralM :: ParserM TricuAST
|
||||
|
@ -26,7 +26,6 @@ data TricuAST
|
||||
| TFork TricuAST TricuAST
|
||||
| SLambda [String] TricuAST
|
||||
| SEmpty
|
||||
| SModule String
|
||||
| SImport String String
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
@ -34,17 +33,18 @@ data TricuAST
|
||||
data LToken
|
||||
= LKeywordT
|
||||
| LIdentifier String
|
||||
| LNamespace String
|
||||
| LIntegerLiteral Int
|
||||
| LStringLiteral String
|
||||
| LAssign
|
||||
| LColon
|
||||
| LDot
|
||||
| LBackslash
|
||||
| LOpenParen
|
||||
| LCloseParen
|
||||
| LOpenBracket
|
||||
| LCloseBracket
|
||||
| LNewline
|
||||
| LModule String
|
||||
| LImport String String
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
|
@ -532,6 +532,9 @@ modules = testGroup "Test modules"
|
||||
, testCase "Lambda expression namespaces" $ do
|
||||
res <- liftIO $ evaluateFileResult "./test/lambda-A.tri"
|
||||
res @?= Leaf
|
||||
, testCase "Local namespace import chain" $ do
|
||||
res <- liftIO $ evaluateFileResult "./test/local-ns/1.tri"
|
||||
res @?= Fork (Stem Leaf) (Fork (Stem Leaf) Leaf)
|
||||
]
|
||||
|
||||
|
||||
|
@ -1 +0,0 @@
|
||||
t (t (t (t (t t) (t t t)) t) t t) t
|
@ -1 +0,0 @@
|
||||
x = t (t t) t
|
@ -1,4 +1,3 @@
|
||||
!module Cycle
|
||||
|
||||
!import "test/cycle-2.tri" Cycle2
|
||||
|
||||
|
@ -1,4 +1,3 @@
|
||||
!module Cycle2
|
||||
|
||||
!import "test/cycle-1.tri" Cycle1
|
||||
|
||||
|
@ -1,2 +1 @@
|
||||
!module A
|
||||
main = (\x : x) t
|
||||
|
4
test/local-ns/1.tri
Normal file
4
test/local-ns/1.tri
Normal file
@ -0,0 +1,4 @@
|
||||
|
||||
!import "test/local-ns/2.tri" Two
|
||||
|
||||
main = Two.x
|
2
test/local-ns/2.tri
Normal file
2
test/local-ns/2.tri
Normal file
@ -0,0 +1,2 @@
|
||||
|
||||
!import "test/local-ns/3.tri" !Local
|
2
test/local-ns/3.tri
Normal file
2
test/local-ns/3.tri
Normal file
@ -0,0 +1,2 @@
|
||||
|
||||
x = 3
|
@ -1,5 +0,0 @@
|
||||
!module Test
|
||||
|
||||
!import "lib/base.tri" Lib
|
||||
|
||||
main = Lib.not? t
|
@ -1 +0,0 @@
|
||||
n = t t t
|
@ -1,3 +1,2 @@
|
||||
!module A
|
||||
!import "./test/multi-level-B.tri" B
|
||||
main = B.main
|
||||
|
@ -1,3 +1,2 @@
|
||||
!module B
|
||||
!import "./test/multi-level-C.tri" C
|
||||
main = C.val
|
||||
|
@ -1,2 +1 @@
|
||||
!module C
|
||||
val = t
|
||||
|
7
test/named-imports/1.tri
Normal file
7
test/named-imports/1.tri
Normal 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
2
test/named-imports/2.tri
Normal file
@ -0,0 +1,2 @@
|
||||
|
||||
x = 2
|
2
test/named-imports/3.tri
Normal file
2
test/named-imports/3.tri
Normal file
@ -0,0 +1,2 @@
|
||||
|
||||
x = 3
|
@ -1,3 +1,2 @@
|
||||
!module A
|
||||
!import "./test/namespace-B.tri" B
|
||||
main = B.x
|
||||
|
@ -1,2 +1 @@
|
||||
!module B
|
||||
x = t
|
||||
|
@ -1 +0,0 @@
|
||||
namedTerm = undefinedForTesting
|
@ -1,2 +1 @@
|
||||
!module A
|
||||
main = undefinedVar
|
||||
|
@ -1,4 +1,3 @@
|
||||
!module A
|
||||
|
||||
!import "./test/vars-B.tri" B
|
||||
|
||||
|
@ -1,2 +1 @@
|
||||
!module B
|
||||
y = \x : x
|
||||
|
@ -1,2 +1 @@
|
||||
!module C
|
||||
z = t
|
||||
|
@ -1,7 +1,7 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
name: tricu
|
||||
version: 0.12.0
|
||||
version: 0.13.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