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" !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?
|
||||||
|
@ -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]
|
||||||
|
@ -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))
|
||||||
|
@ -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)))"
|
||||||
|
15
src/Eval.hs
15
src/Eval.hs
@ -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
|
||||||
|
137
src/FileEval.hs
137
src/FileEval.hs
@ -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
|
||||||
|
124
src/Lexer.hs
124
src/Lexer.hs
@ -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
|
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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)
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
|
@ -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
|
!import "test/cycle-2.tri" Cycle2
|
||||||
|
|
||||||
|
@ -1,4 +1,3 @@
|
|||||||
!module Cycle2
|
|
||||||
|
|
||||||
!import "test/cycle-1.tri" Cycle1
|
!import "test/cycle-1.tri" Cycle1
|
||||||
|
|
||||||
|
@ -1,2 +1 @@
|
|||||||
!module A
|
|
||||||
main = (\x : x) t
|
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
|
!import "./test/multi-level-B.tri" B
|
||||||
main = B.main
|
main = B.main
|
||||||
|
@ -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
|
||||||
|
@ -1,2 +1 @@
|
|||||||
!module C
|
|
||||||
val = t
|
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
|
!import "./test/namespace-B.tri" B
|
||||||
main = B.x
|
main = B.x
|
||||||
|
@ -1,2 +1 @@
|
|||||||
!module B
|
|
||||||
x = t
|
x = t
|
||||||
|
@ -1 +0,0 @@
|
|||||||
namedTerm = undefinedForTesting
|
|
@ -1,2 +1 @@
|
|||||||
!module A
|
|
||||||
main = undefinedVar
|
main = undefinedVar
|
||||||
|
@ -1,4 +1,3 @@
|
|||||||
!module A
|
|
||||||
|
|
||||||
!import "./test/vars-B.tri" B
|
!import "./test/vars-B.tri" B
|
||||||
|
|
||||||
|
@ -1,2 +1 @@
|
|||||||
!module B
|
|
||||||
y = \x : x
|
y = \x : x
|
||||||
|
@ -1,2 +1 @@
|
|||||||
!module C
|
|
||||||
z = t
|
z = t
|
||||||
|
@ -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
|
||||||
|
Loading…
x
Reference in New Issue
Block a user