Merge content store
This commit is contained in:
198
src/Eval.hs
198
src/Eval.hs
@@ -1,35 +1,42 @@
|
||||
module Eval where
|
||||
|
||||
import ContentStore
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
import Control.Monad (forM_, foldM)
|
||||
import Data.List (partition, (\\))
|
||||
import Data.Map (Map)
|
||||
import Database.SQLite.Simple
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import Data.List (foldl')
|
||||
|
||||
evalSingle :: Env -> TricuAST -> Env
|
||||
evalSingle env term
|
||||
| SDef name [] body <- term
|
||||
= case Map.lookup name env of
|
||||
Just existingValue
|
||||
| existingValue == evalAST env body -> env
|
||||
| otherwise -> errorWithoutStackTrace $
|
||||
"Unable to rebind immutable identifier: " ++ name
|
||||
Nothing ->
|
||||
let res = evalAST env body
|
||||
in Map.insert "!result" res (Map.insert name res env)
|
||||
| existingValue == evalASTSync env body -> env
|
||||
| otherwise
|
||||
-> let res = evalASTSync env body
|
||||
in Map.insert "!result" res (Map.insert name res env)
|
||||
Nothing
|
||||
-> let res = evalASTSync env body
|
||||
in Map.insert "!result" res (Map.insert name res env)
|
||||
| SApp func arg <- term
|
||||
= let res = apply (evalAST env func) (evalAST env arg)
|
||||
in Map.insert "!result" res env
|
||||
| SVar name <- term
|
||||
= let res = apply (evalASTSync env func) (evalASTSync env arg)
|
||||
in Map.insert "!result" res env
|
||||
| SVar name Nothing <- term
|
||||
= case Map.lookup name env of
|
||||
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."
|
||||
Just v -> Map.insert "!result" v env
|
||||
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
||||
| SVar name (Just hash) <- term
|
||||
= errorWithoutStackTrace $ "Hash-specific variable lookup not supported in local evaluation: " ++ name ++ "#" ++ hash
|
||||
| otherwise
|
||||
= Map.insert "!result" (evalAST env term) env
|
||||
= let res = evalASTSync env term
|
||||
in Map.insert "!result" res env
|
||||
|
||||
evalTricu :: Env -> [TricuAST] -> Env
|
||||
evalTricu env x = go env (reorderDefs env x)
|
||||
@@ -41,23 +48,84 @@ evalTricu env x = go env (reorderDefs env x)
|
||||
go env (x:xs) =
|
||||
evalTricu (evalSingle env x) xs
|
||||
|
||||
evalAST :: Env -> TricuAST -> T
|
||||
evalAST env term
|
||||
| SLambda _ _ <- term = evalAST env (elimLambda term)
|
||||
| SVar name <- term = evalVar name
|
||||
| TLeaf <- term = Leaf
|
||||
| TStem t <- term = Stem (evalAST env t)
|
||||
| TFork t u <- term = Fork (evalAST env t) (evalAST env u)
|
||||
| SApp t u <- term = apply (evalAST env t) (evalAST env u)
|
||||
| SStr s <- term = ofString s
|
||||
| SInt n <- term = ofNumber n
|
||||
| SList xs <- term = ofList (map (evalAST env) xs)
|
||||
| SEmpty <- term = Leaf
|
||||
| otherwise = errorWithoutStackTrace "Unexpected AST term"
|
||||
where
|
||||
evalVar name = Map.findWithDefault
|
||||
(errorWithoutStackTrace $ "Variable " ++ name ++ " not defined")
|
||||
name env
|
||||
evalASTSync :: Env -> TricuAST -> T
|
||||
evalASTSync env term = case term of
|
||||
SLambda _ _ -> evalASTSync env (elimLambda term)
|
||||
SVar name Nothing -> case Map.lookup name env of
|
||||
Just v -> v
|
||||
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
||||
SVar name (Just hash) ->
|
||||
case Map.lookup (name ++ "#" ++ hash) env of
|
||||
Just v -> v
|
||||
Nothing -> errorWithoutStackTrace $
|
||||
"Variable " ++ name ++ " with hash " ++ hash ++ " not found in environment"
|
||||
TLeaf -> Leaf
|
||||
TStem t -> Stem (evalASTSync env t)
|
||||
TFork t u -> Fork (evalASTSync env t) (evalASTSync env u)
|
||||
SApp t u -> apply (evalASTSync env t) (evalASTSync env u)
|
||||
SStr s -> ofString s
|
||||
SInt n -> ofNumber n
|
||||
SList xs -> ofList (map (evalASTSync env) xs)
|
||||
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
|
||||
|
||||
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 -- Ambiguous or too many matches
|
||||
Nothing -> case Map.lookup name selectedVersions of
|
||||
Just hash -> do
|
||||
mterm <- hashToTerm conn hash
|
||||
case mterm of
|
||||
Just term -> case deserializeTerm (termData term) of
|
||||
Right t -> return $ Just t
|
||||
Left _ -> return Nothing
|
||||
Nothing -> return Nothing
|
||||
Nothing -> do
|
||||
versions <- termVersions conn name
|
||||
case versions of
|
||||
[] -> return Nothing
|
||||
[(_, term, _)] -> return $ Just term
|
||||
_ -> return $ Just $ (\(_, t, _) -> t) $ head versions
|
||||
|
||||
elimLambda :: TricuAST -> TricuAST
|
||||
elimLambda = go
|
||||
@@ -71,7 +139,7 @@ elimLambda = go
|
||||
| application term = applicationResult term
|
||||
| otherwise = term
|
||||
|
||||
etaReduction (SLambda [v] (SApp f (SVar x))) = v == x && not (isFree v f)
|
||||
etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (isFree v f)
|
||||
etaReduction _ = False
|
||||
etaReduceResult (SLambda [_] (SApp f _)) = f
|
||||
|
||||
@@ -96,45 +164,31 @@ elimLambda = go
|
||||
application _ = False
|
||||
applicationResult (SApp f g) = SApp (elimLambda f) (elimLambda g)
|
||||
|
||||
toSKI x (SVar y)
|
||||
| x == y = _I
|
||||
| otherwise = SApp _K (SVar y)
|
||||
toSKI x t@(SApp n u)
|
||||
| not (isFree x t) = SApp _K t
|
||||
| otherwise = SApp (SApp _S (toSKI x n)) (toSKI x u)
|
||||
toSKI x (SList xs)
|
||||
| not (isFree x (SList xs)) = SApp _K (SList xs)
|
||||
| otherwise = SList (map (toSKI x) xs)
|
||||
toSKI x t
|
||||
| not (isFree x t) = SApp _K t
|
||||
| otherwise = errorWithoutStackTrace "Unhandled toSKI conversion"
|
||||
toSKI x (SVar y Nothing)
|
||||
| x == y = _I
|
||||
| otherwise = SApp _K (SVar y Nothing)
|
||||
toSKI x (SApp m n) = SApp (SApp _S (toSKI x m)) (toSKI x n)
|
||||
toSKI x (SLambda [y] body) = toSKI x (toSKI y body)
|
||||
toSKI _ term = SApp _K term
|
||||
|
||||
-- Combinators and special forms
|
||||
_S = parseSingle "t (t (t t t)) t"
|
||||
_K = parseSingle "t t"
|
||||
_I = parseSingle "t (t (t t)) t"
|
||||
_B = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
|
||||
_TRI = parseSingle "t (t (t t (t (t (t t t))))) t"
|
||||
|
||||
-- Pattern bodies
|
||||
triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c)
|
||||
composeBody f g x = SApp (SVar f) (SApp (SVar g) (SVar x))
|
||||
|
||||
triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a Nothing)) (SVar b Nothing))) (SVar c Nothing)
|
||||
composeBody f g x = SApp (SVar f Nothing) (SVar g Nothing)
|
||||
|
||||
isFree :: String -> TricuAST -> Bool
|
||||
isFree x = Set.member x . freeVars
|
||||
|
||||
freeVars :: TricuAST -> Set.Set String
|
||||
freeVars (SVar v ) = Set.singleton v
|
||||
freeVars (SList s ) = foldMap freeVars s
|
||||
freeVars (SLambda v b ) = foldr Set.delete (freeVars b) v
|
||||
freeVars (SApp f a ) = freeVars f <> freeVars a
|
||||
freeVars (TFork l r ) = freeVars l <> freeVars r
|
||||
freeVars (SDef _ _ b) = freeVars b
|
||||
freeVars (TStem t ) = freeVars t
|
||||
freeVars (SInt _ ) = Set.empty
|
||||
freeVars (SStr _ ) = Set.empty
|
||||
freeVars TLeaf = Set.empty
|
||||
freeVars _ = Set.empty
|
||||
freeVars (SVar v Nothing) = Set.singleton v
|
||||
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 _ = Set.empty
|
||||
|
||||
reorderDefs :: Env -> [TricuAST] -> [TricuAST]
|
||||
reorderDefs env defs
|
||||
@@ -215,3 +269,27 @@ mainResult :: Env -> T
|
||||
mainResult r = case Map.lookup "main" r of
|
||||
Just a -> a
|
||||
Nothing -> errorWithoutStackTrace "No valid definition for `main` found."
|
||||
|
||||
evalWithEnv :: Env -> Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T
|
||||
evalWithEnv env mconn selectedVersions ast = do
|
||||
let varNames = findVarNames ast
|
||||
resolvedEnv <- case mconn of
|
||||
Just conn -> foldM (\e name ->
|
||||
if Map.member name e
|
||||
then return e
|
||||
else do
|
||||
mterm <- resolveTermFromStore conn selectedVersions name Nothing
|
||||
case mterm of
|
||||
Just term -> return $ Map.insert name term e
|
||||
Nothing -> return e
|
||||
) env varNames
|
||||
Nothing -> return env
|
||||
return $ evalASTSync resolvedEnv ast
|
||||
|
||||
findVarNames :: TricuAST -> [String]
|
||||
findVarNames ast = case ast of
|
||||
SVar name _ -> [name]
|
||||
SApp a b -> findVarNames a ++ findVarNames b
|
||||
SLambda args body -> findVarNames body \\ args
|
||||
SDef name args body -> name : (findVarNames body \\ args)
|
||||
_ -> []
|
||||
|
||||
Reference in New Issue
Block a user