Tricu 2.0.0
Sorry for squashing all of this but 🤷
This commit is contained in:
135
src/Eval.hs
135
src/Eval.hs
@@ -1,20 +1,16 @@
|
||||
module Eval where
|
||||
|
||||
import ContentStore
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Data.List (partition, (\\), elemIndex, foldl')
|
||||
import Data.Map ()
|
||||
import Data.Set (Set)
|
||||
import Database.SQLite.Simple
|
||||
import Debug.Trace (trace)
|
||||
|
||||
import qualified Data.Foldable as F ()
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
|
||||
data DB
|
||||
= BVar Int
|
||||
@@ -43,6 +39,16 @@ evalSingle env term
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
Nothing
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
| SDefAnn name args _ body <- term
|
||||
= let params = annotatedBinders args
|
||||
res = evalASTSync env (if null params then body else SLambda params body)
|
||||
in case Map.lookup name env of
|
||||
Just existingValue
|
||||
| existingValue == res -> env
|
||||
| otherwise
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
Nothing
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
| SApp func arg <- term
|
||||
= let res = apply (evalASTSync env func) (evalASTSync env arg)
|
||||
in Map.insert "!result" res env
|
||||
@@ -87,94 +93,17 @@ evalASTSync env term = case term of
|
||||
SEmpty -> Leaf
|
||||
_ -> errorWithoutStackTrace $ "Unexpected AST term: " ++ show term
|
||||
|
||||
evalAST :: Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T
|
||||
evalAST mconn selectedVersions ast = do
|
||||
let varNames = collectVarNames ast
|
||||
resolvedEnv <- resolveTermsFromStore mconn selectedVersions varNames
|
||||
return $ evalASTSync resolvedEnv ast
|
||||
|
||||
-- | Evaluate a single AST term using a local environment augmented by
|
||||
-- lazily-resolved store terms.
|
||||
evalASTWithEnv :: Maybe Connection -> Env -> TricuAST -> IO T
|
||||
evalASTWithEnv mconn localEnv ast = do
|
||||
let varNames = collectVarNames ast
|
||||
storeEnv <- resolveTermsFromStore mconn Map.empty varNames
|
||||
let combinedEnv = Map.union localEnv storeEnv
|
||||
return $ evalASTSync combinedEnv ast
|
||||
|
||||
evalSingleWithStore :: Maybe Connection -> Env -> TricuAST -> IO Env
|
||||
evalSingleWithStore mconn env term
|
||||
| SDef name params body <- term = do
|
||||
res <- evalASTWithEnv mconn env (if null params then body else SLambda params body)
|
||||
case Map.lookup name env of
|
||||
Just existingValue
|
||||
| existingValue == res -> return env
|
||||
| otherwise -> return $ Map.insert "!result" res (Map.insert name res env)
|
||||
Nothing -> return $ Map.insert "!result" res (Map.insert name res env)
|
||||
| otherwise = do
|
||||
res <- evalASTWithEnv mconn env term
|
||||
return $ Map.insert "!result" res env
|
||||
|
||||
evalTricuWithStore :: Maybe Connection -> Env -> [TricuAST] -> IO Env
|
||||
evalTricuWithStore mconn env x = go env (reorderDefs env (map recoverParams x))
|
||||
where
|
||||
go env' [] = return env'
|
||||
go env' [def] = do
|
||||
updatedEnv <- evalSingleWithStore mconn env' def
|
||||
return $ Map.insert "!result" (result updatedEnv) updatedEnv
|
||||
go env' (def:xs) = do
|
||||
updatedEnv <- evalSingleWithStore mconn env' def
|
||||
evalTricuWithStore mconn updatedEnv xs
|
||||
evalAST :: Env -> TricuAST -> IO T
|
||||
evalAST env ast = return $ evalASTSync env ast
|
||||
|
||||
recoverParams :: TricuAST -> TricuAST
|
||||
recoverParams (SDef name [] (SLambda params body)) = SDef name params body
|
||||
recoverParams term = term
|
||||
|
||||
collectVarNames :: TricuAST -> [(String, Maybe String)]
|
||||
collectVarNames = go []
|
||||
where
|
||||
go acc (SVar name mhash) = (name, mhash) : acc
|
||||
go acc (SApp t u) = go (go acc t) u
|
||||
go acc (SLambda vars body) =
|
||||
let boundVars = Set.fromList vars
|
||||
collected = go [] body
|
||||
in acc ++ filter (\(name, _) -> not $ Set.member name boundVars) collected
|
||||
go acc (TStem t) = go acc t
|
||||
go acc (TFork t u) = go (go acc t) u
|
||||
go acc (SList xs) = foldl' go acc xs
|
||||
go acc _ = acc
|
||||
|
||||
resolveTermsFromStore :: Maybe Connection -> Map.Map String T.Text -> [(String, Maybe String)] -> IO Env
|
||||
resolveTermsFromStore Nothing _ _ = return Map.empty
|
||||
resolveTermsFromStore (Just conn) selectedVersions varNames = do
|
||||
foldM (\env (name, mhash) -> do
|
||||
term <- resolveTermFromStore conn selectedVersions name mhash
|
||||
case term of
|
||||
Just t -> return $ Map.insert (getVarKey name mhash) t env
|
||||
Nothing -> return env
|
||||
) Map.empty varNames
|
||||
where
|
||||
getVarKey name Nothing = name
|
||||
getVarKey name (Just hash) = name ++ "#" ++ hash
|
||||
|
||||
resolveTermFromStore :: Connection -> Map.Map String T.Text -> String -> Maybe String -> IO (Maybe T)
|
||||
resolveTermFromStore conn selectedVersions name mhash = case mhash of
|
||||
Just hashPrefix -> do
|
||||
versions <- termVersions conn name
|
||||
let matchingVersions = filter (\(hash, _, _) ->
|
||||
T.isPrefixOf (T.pack hashPrefix) hash) versions
|
||||
case matchingVersions of
|
||||
[] -> return Nothing
|
||||
[(_, term, _)] -> return $ Just term
|
||||
_ -> return Nothing
|
||||
Nothing -> case Map.lookup name selectedVersions of
|
||||
Just hash -> loadTree conn hash
|
||||
Nothing -> do
|
||||
versions <- termVersions conn name
|
||||
case versions of
|
||||
[] -> return Nothing
|
||||
[(_, term, _)] -> return $ Just term
|
||||
_ -> return $ Just (head (map (\(_, t, _) -> t) versions))
|
||||
annotatedBinders :: [DefArg] -> [String]
|
||||
annotatedBinders [] = []
|
||||
annotatedBinders (DefBinder name _ : rest) = name : annotatedBinders rest
|
||||
annotatedBinders (DefPhantom _ : rest) = annotatedBinders rest
|
||||
|
||||
elimLambda :: TricuAST -> TricuAST
|
||||
elimLambda = go
|
||||
@@ -262,6 +191,7 @@ freeVars (SVar v (Just _)) = Set.singleton v
|
||||
freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
|
||||
freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs)
|
||||
freeVars (SDef _ params body) = Set.difference (freeVars body) (Set.fromList params)
|
||||
freeVars (SDefAnn _ args _ body) = Set.difference (freeVars body) (Set.fromList (annotatedBinders args))
|
||||
freeVars (TStem t) = freeVars t
|
||||
freeVars (TFork t u) = Set.union (freeVars t) (freeVars u)
|
||||
freeVars (SList xs) = foldMap freeVars xs
|
||||
@@ -275,13 +205,13 @@ reorderDefs env defs
|
||||
| otherwise = orderedDefs ++ others
|
||||
where
|
||||
(defsOnly, others) = partition isDef defs
|
||||
defNames = [ name | SDef name _ _ <- defsOnly ]
|
||||
defNames = [ defName def | def <- defsOnly ]
|
||||
|
||||
defsWithFreeVars = [(def, freeVars def) | def <- defsOnly]
|
||||
|
||||
graph = buildDepGraph defsOnly
|
||||
sortedDefs = sortDeps graph
|
||||
defMap = Map.fromList [(name, def) | def@(SDef name _ _) <- defsOnly]
|
||||
defMap = Map.fromList [(defName def, def) | def <- defsOnly]
|
||||
orderedDefs = map (defMap Map.!) sortedDefs
|
||||
|
||||
freeVarsDefs = foldMap snd defsWithFreeVars
|
||||
@@ -291,6 +221,7 @@ reorderDefs env defs
|
||||
missingDeps = Set.toList (allFreeVars `Set.difference` validNames)
|
||||
|
||||
isDef SDef {} = True
|
||||
isDef SDefAnn {} = True
|
||||
isDef _ = False
|
||||
|
||||
buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
|
||||
@@ -300,11 +231,11 @@ buildDepGraph topDefs
|
||||
"Conflicting definitions detected: " ++ show conflictingDefs
|
||||
| otherwise =
|
||||
Map.fromList
|
||||
[ (name, depends topDefs def)
|
||||
| def@(SDef name _ _) <- topDefs]
|
||||
[ (defName def, depends topDefs def)
|
||||
| def <- topDefs]
|
||||
where
|
||||
defsMap = Map.fromListWith (++)
|
||||
[(name, [(name, body)]) | SDef name _ body <- topDefs]
|
||||
[(defName def, [(defName def, defBody def)]) | def <- topDefs]
|
||||
|
||||
conflictingDefs =
|
||||
[ name
|
||||
@@ -330,10 +261,24 @@ sortDeps graph = go [] Set.empty (Map.keys graph)
|
||||
(Set.union sortedSet (Set.fromList ready))
|
||||
notReady
|
||||
|
||||
defName :: TricuAST -> String
|
||||
defName (SDef name _ _) = name
|
||||
defName (SDefAnn name _ _ _) = name
|
||||
defName _ = error "defName: expected definition"
|
||||
|
||||
defBody :: TricuAST -> TricuAST
|
||||
defBody (SDef _ _ body) = body
|
||||
defBody (SDefAnn _ _ _ body) = body
|
||||
defBody _ = error "defBody: expected definition"
|
||||
|
||||
depends :: [TricuAST] -> TricuAST -> Set.Set String
|
||||
depends topDefs def@(SDef _ _ _) =
|
||||
depends topDefs def@SDef {} =
|
||||
Set.intersection
|
||||
(Set.fromList [n | SDef n _ _ <- topDefs])
|
||||
(Set.fromList [defName d | d <- topDefs])
|
||||
(freeVars def)
|
||||
depends topDefs def@SDefAnn {} =
|
||||
Set.intersection
|
||||
(Set.fromList [defName d | d <- topDefs])
|
||||
(freeVars def)
|
||||
depends _ _ = Set.empty
|
||||
|
||||
@@ -353,6 +298,7 @@ findVarNames ast = case ast of
|
||||
SApp a b -> findVarNames a ++ findVarNames b
|
||||
SLambda args body -> findVarNames body \\ args
|
||||
SDef name args body -> name : (findVarNames body \\ args)
|
||||
SDefAnn name args _ body -> name : (findVarNames body \\ annotatedBinders args)
|
||||
_ -> []
|
||||
|
||||
-- Convert named TricuAST to De Bruijn form
|
||||
@@ -372,6 +318,7 @@ toDB env = \case
|
||||
SList xs -> BList (map (toDB env) xs)
|
||||
SEmpty -> BEmpty
|
||||
SDef{} -> error "toDB: unexpected SDef at this stage"
|
||||
SDefAnn{} -> error "toDB: unexpected SDefAnn at this stage"
|
||||
SImport _ _ -> BEmpty
|
||||
|
||||
-- Does a term depend on the current binder (level 0)?
|
||||
|
||||
Reference in New Issue
Block a user