From a64b3f08297b9efa5f1255148919f57e20764e77 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Sun, 26 Jan 2025 14:50:15 -0600 Subject: [PATCH] Definition dependency analysis tricu now allows defining terms in any order and will resolve dependencies to ensure that they're evaluated in the right order. Undefined terms are detected and throw errors during dependency ordering. For now we can't define top-level mutually recursive terms. --- demos/levelOrderTraversal.tri | 9 +-- demos/size.tri | 28 ++++---- lib/base.tri | 60 ++++++++-------- src/Eval.hs | 125 ++++++++++++++++++++++++++-------- src/Parser.hs | 2 +- src/Research.hs | 2 +- test/Spec.hs | 10 +-- test/size.tri | 21 ++++++ test/undefined.tri | 1 + tricu.cabal | 2 +- 10 files changed, 174 insertions(+), 86 deletions(-) create mode 100644 test/size.tri create mode 100644 test/undefined.tri diff --git a/demos/levelOrderTraversal.tri b/demos/levelOrderTraversal.tri index 179e300..ee46261 100644 --- 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 index dde6d66..2efd2c1 100644 --- 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 index 58bb07a..13527d4 100644 --- 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 index f49866d..51e9993 100644 --- 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 index 9178bdd..181c0e0 100644 --- 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 index 8638cdb..f93bc24 100644 --- 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 index c8ea93a..a44d320 100644 --- 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 new file mode 100644 index 0000000..2efd2c1 --- /dev/null +++ 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 new file mode 100644 index 0000000..d09629a --- /dev/null +++ b/test/undefined.tri @@ -0,0 +1 @@ +namedTerm = undefinedForTesting diff --git a/tricu.cabal b/tricu.cabal index c4a352f..de8367e 100644 --- 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