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.
This commit is contained in:
James Eversole
125
src/Eval.hs
125
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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Reference in New Issue
Block a user