commit 56ca6dfa9491a4592cf11920f7f75c4dd2c092c4
parent b0b0fb22b9024ac87ea0a00b47cca4c345bb9ded
Author: James Eversole <james@eversole.co>
Date: Sun, 26 Jan 2025 14:50:15 -0600
Definition dependency analysis
Diffstat:
10 files changed, 174 insertions(+), 86 deletions(-)
diff --git a/demos/levelOrderTraversal.tri b/demos/levelOrderTraversal.tri
@@ -1,11 +1,9 @@
-- Level Order Traversal of a labelled binary tree
-- Objective: Print each "level" of the tree on a separate line
--
--- NOTICE: This demo relies on tricu base library functions
---
--- We model labelled binary trees as sublists where values act as labels. We
--- require explicit not?ation of empty nodes. Empty nodes can be represented
--- with an empty list, `[]`, which is equivalent to a single node `t`.
+-- We model labelled binary trees as nested lists where values act as labels. We
+-- require explicit notation of empty nodes. Empty nodes can be represented
+-- with an empty list, `[]`, which evaluates to a single node `t`.
--
-- Example tree inputs:
-- [("1") [("2") [("4") t t] t] [("3") [("5") t t] [("6") t t]]]]
@@ -15,7 +13,6 @@
-- 2 3
-- / / \
-- 4 5 6
---
label = \node : head node
diff --git a/demos/size.tri b/demos/size.tri
@@ -1,21 +1,21 @@
compose = \f g x : f (g x)
-succ = y (\self :
- triage
- 1
- t
- (triage
- (t (t t))
- (\_ tail : t t (self tail))
+succ = y (\self :
+ triage
+ 1
+ t
+ (triage
+ (t (t t))
+ (\_ tail : t t (self tail))
t))
-size = (\x :
- (y (\self x :
- compose succ
- (triage
- (\x : x)
- self
- (\x y : compose (self x) (self y))
+size = (\x :
+ (y (\self x :
+ compose succ
+ (triage
+ (\x : x)
+ self
+ (\x y : compose (self x) (self y))
x)) x 0))
size size
diff --git a/lib/base.tri b/lib/base.tri
@@ -18,9 +18,9 @@ y = ((\mut wait fun : wait mut (\x : fun (wait mut x)))
triage = \leaf stem fork : t (t leaf stem) fork
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
-matchBool = (\ot of : triage
- of
- (\_ : ot)
+matchBool = (\ot of : triage
+ of
+ (\_ : ot)
(\_ _ : ot)
)
@@ -35,44 +35,44 @@ emptyList? = matchList true (\_ _ : false)
head = matchList t (\head _ : head)
tail = matchList t (\_ tail : tail)
-lconcat = y (\self : matchList
- (\k : k)
+lconcat = y (\self : matchList
+ (\k : k)
(\h r k : pair h (self r k)))
-lAnd = (triage
- (\_ : false)
- (\_ x : x)
+lAnd = (triage
+ (\_ : false)
+ (\_ x : x)
(\_ _ x : x))
-lOr = (triage
- (\x : x)
- (\_ _ : true)
+lOr = (triage
+ (\x : x)
+ (\_ _ : true)
(\_ _ _ : true))
-map_ = y (\self :
- matchList
- (\_ : t)
+map_ = y (\self :
+ matchList
+ (\_ : t)
(\head tail f : pair (f head) (self tail f)))
map = \f l : map_ l f
-equal? = y (\self : triage
- (triage
- true
- (\_ : false)
- (\_ _ : false))
- (\ax :
- triage
- false
- (self ax)
- (\_ _ : false))
- (\ax ay :
- triage
- false
- (\_ : false)
+equal? = y (\self : triage
+ (triage
+ true
+ (\_ : false)
+ (\_ _ : false))
+ (\ax :
+ triage
+ false
+ (self ax)
+ (\_ _ : false))
+ (\ax ay :
+ triage
+ false
+ (\_ : false)
(\bx by : lAnd (self ax bx) (self ay by))))
-filter_ = y (\self : matchList
- (\_ : t)
+filter_ = y (\self : matchList
+ (\_ : t)
(\head tail f : matchBool (t head) i (f head) (self tail f)))
filter = \f l : filter_ l f
diff --git a/src/Eval.hs b/src/Eval.hs
@@ -3,19 +3,19 @@ module Eval where
import Parser
import Research
+import Data.List (partition)
import Data.Map (Map)
-
import qualified Data.Map as Map
import qualified Data.Set as Set
evalSingle :: Env -> TricuAST -> Env
evalSingle env term
- | SFunc name [] body <- term =
+ | SDef name [] body <- term =
if
- | Map.member name env ->
- errorWithoutStackTrace $
+ | Map.member name env ->
+ errorWithoutStackTrace $
"Error: Identifier '" ++ name ++ "' is already defined."
- | otherwise ->
+ | otherwise ->
let res = evalAST env body
in Map.insert "__result" res (Map.insert name res env)
| SApp func arg <- term =
@@ -23,18 +23,23 @@ evalSingle env term
in Map.insert "__result" res env
| SVar name <- term =
case Map.lookup name env of
- Just v -> Map.insert "__result" v env
- Nothing -> errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined"
+ Just v ->
+ 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
evalTricu :: Env -> [TricuAST] -> Env
-evalTricu env [] = env
-evalTricu env [x] =
- let updatedEnv = evalSingle env x
- in Map.insert "__result" (result updatedEnv) updatedEnv
-evalTricu env (x:xs) =
- evalTricu (evalSingle env x) xs
+evalTricu env x = go env (reorderDefs env x)
+ where
+ go env [] = env
+ go env [x] =
+ let updatedEnv = evalSingle env x
+ in Map.insert "__result" (result updatedEnv) updatedEnv
+ go env (x:xs) =
+ evalTricu (evalSingle env x) xs
evalAST :: Env -> TricuAST -> T
evalAST env term
@@ -61,13 +66,13 @@ elimLambda = go
go (SLambda [v] (SApp f (SVar x)))
| v == x && not (isFree v f) = elimLambda f
-- Triage optimization
- go (SLambda [a] (SLambda [b] (SLambda [c] body)))
+ go (SLambda [a] (SLambda [b] (SLambda [c] body)))
| body == triageBody = _TRIAGE
where
triageBody =
(SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c))
-- Composition optimization
- go (SLambda [f] (SLambda [g] (SLambda [x] body)))
+ go (SLambda [f] (SLambda [g] (SLambda [x] body)))
| body == composeBody = _COMPOSE
where
composeBody = SApp (SVar f) (SApp (SVar g) (SVar x))
@@ -93,20 +98,84 @@ elimLambda = go
_I = parseSingle "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 x = Set.member x . freeVars
- freeVars (SVar v ) = Set.singleton v
- 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 (SFunc _ _ 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
+
+isFree :: String -> TricuAST -> Bool
+isFree x = Set.member x . freeVars
+
+freeVars :: TricuAST -> Set.Set String
+freeVars (SVar v ) = Set.singleton v
+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 (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
+
+reorderDefs :: Env -> [TricuAST] -> [TricuAST]
+reorderDefs env defs
+ | not (null missingDeps) =
+ errorWithoutStackTrace $
+ "Missing dependencies detected: " ++ show missingDeps
+ | otherwise = orderedDefs ++ others
+ where
+ (defsOnly, others) = partition isDef defs
+ graph = buildDepGraph defsOnly
+ sortedDefs = sortDeps graph
+ defMap = Map.fromList [(name, def) | def@(SDef name _ _) <- defsOnly]
+ orderedDefs = map (\name -> defMap Map.! name) sortedDefs
+ topDefNames = Set.fromList (Map.keys defMap)
+ envNames = Set.fromList (Map.keys env)
+ freeVarsDefs = foldMap (\(SDef _ _ body) -> freeVars body) defsOnly
+ freeVarsOthers = foldMap freeVars others
+ allFreeVars = freeVarsDefs <> freeVarsOthers
+ validNames = topDefNames `Set.union` envNames
+ missingDeps = Set.toList (allFreeVars `Set.difference` validNames)
+
+ isDef (SDef _ _ _) = True
+ isDef _ = False
+
+buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
+buildDepGraph topDefs
+ | not (null duplicateNames) =
+ errorWithoutStackTrace $
+ "Duplicate definitions detected: " ++ show duplicateNames
+ | otherwise =
+ Map.fromList
+ [ (name, depends topDefs (SDef name [] body))
+ | SDef name _ body <- topDefs]
+ where
+ names = [name | SDef name _ _ <- topDefs]
+ duplicateNames =
+ [ name | (name, count) <- Map.toList (countOccurrences names) , count > 1]
+ countOccurrences = foldr (\x -> Map.insertWith (+) x 1) Map.empty
+
+sortDeps :: Map.Map String (Set.Set String) -> [String]
+sortDeps graph = go [] (Map.keys graph)
+ where
+ go sorted [] = sorted
+ go sorted remaining
+ | null ready =
+ errorWithoutStackTrace
+ "ERROR: Top-level cyclic dependency detected and prohibited\n\
+ \RESOLVE: Use nested lambdas"
+ | otherwise = go (sorted ++ ready) notReady
+ where
+ ready = [ name | name <- remaining
+ , all (`elem` sorted) (Set.toList (graph Map.! name))]
+ notReady =
+ [ name | name <- remaining , name `notElem` ready]
+
+depends :: [TricuAST] -> TricuAST -> Set.Set String
+depends topDefs (SDef _ _ body) =
+ Set.intersection
+ (Set.fromList [n | SDef n _ _ <- topDefs])
+ (freeVars body)
+depends _ _ = Set.empty
result :: Env -> T
result r = case Map.lookup "__result" r of
Just a -> a
- Nothing -> errorWithoutStackTrace "No __result field found in provided environment"
+ Nothing -> errorWithoutStackTrace "No __result field found in provided env"
diff --git a/src/Parser.hs b/src/Parser.hs
@@ -112,7 +112,7 @@ parseFunctionM = do
_ <- satisfyM (== LAssign)
scnParserM
body <- parseExpressionM
- pure (SFunc name (map getIdentifier args) body)
+ pure (SDef name (map getIdentifier args) body)
parseLambdaM :: ParserM TricuAST
parseLambdaM = do
diff --git a/src/Research.hs b/src/Research.hs
@@ -19,7 +19,7 @@ data TricuAST
| SInt Int
| SStr String
| SList [TricuAST]
- | SFunc String [String] TricuAST
+ | SDef String [String] TricuAST
| SApp TricuAST TricuAST
| TLeaf
| TStem TricuAST
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -85,7 +85,7 @@ parser = testGroup "Parser Tests"
, testCase "Parse function definitions" $ do
let input = "x = (\\a b c : a)"
- expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a"))))
+ expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a"))))
parseSingle input @?= expect
, testCase "Parse nested Tree Calculus terms" $ do
@@ -105,7 +105,7 @@ parser = testGroup "Parser Tests"
, testCase "Parse function with applications" $ do
let input = "f = (\\x : t x)"
- expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x")))
+ expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x")))
parseSingle input @?= expect
, testCase "Parse nested lists" $ do
@@ -147,7 +147,7 @@ parser = testGroup "Parser Tests"
, testCase "Parse nested parentheses in function body" $ do
let input = "f = (\\x : t (t (t t)))"
- expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
+ expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
parseSingle input @?= expect
, testCase "Parse lambda abstractions" $ do
@@ -157,12 +157,12 @@ parser = testGroup "Parser Tests"
, testCase "Parse multiple arguments to lambda abstractions" $ do
let input = "x = (\\a b : a)"
- expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
+ expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
parseSingle input @?= expect
, testCase "Grouping T terms with parentheses in function application" $ do
let input = "x = (\\a : a)\nx (t)"
- expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
+ expect = [SDef "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
parseTricu input @?= expect
, testCase "Comments 1" $ do
diff --git a/test/size.tri b/test/size.tri
@@ -0,0 +1,21 @@
+compose = \f g x : f (g x)
+
+succ = y (\self :
+ triage
+ 1
+ t
+ (triage
+ (t (t t))
+ (\_ tail : t t (self tail))
+ t))
+
+size = (\x :
+ (y (\self x :
+ compose succ
+ (triage
+ (\x : x)
+ self
+ (\x y : compose (self x) (self y))
+ x)) x 0))
+
+size size
diff --git a/test/undefined.tri b/test/undefined.tri
@@ -0,0 +1 @@
+namedTerm = undefinedForTesting
diff --git a/tricu.cabal b/tricu.cabal
@@ -1,7 +1,7 @@
cabal-version: 1.12
name: tricu
-version: 0.9.0
+version: 0.10.0
description: A micro-language for exploring Tree Calculus
author: James Eversole
maintainer: james@eversole.co
