From 43e83be9a47127ff4151778dbd0a528a7a1766b9 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Thu, 22 May 2025 16:13:57 -0500 Subject: [PATCH 1/6] Merge content store --- .gitignore | 1 + README.md | 26 +- lib/patterns.tri | 6 +- src/ContentStore.hs | 228 ++++++++++++++++ src/Eval.hs | 198 +++++++++----- src/FileEval.hs | 24 +- src/Lexer.hs | 24 +- src/Main.hs | 7 +- src/Parser.hs | 17 +- src/REPL.hs | 625 ++++++++++++++++++++++++++++++++++++-------- src/Research.hs | 17 +- test/Spec.hs | 13 +- tricu.cabal | 31 ++- 13 files changed, 1000 insertions(+), 217 deletions(-) create mode 100644 src/ContentStore.hs diff --git a/.gitignore b/.gitignore index e8c3ecb..be123b0 100644 --- a/.gitignore +++ b/.gitignore @@ -6,6 +6,7 @@ /Dockerfile /config.dhall /result +.aider* WD bin/ dist* diff --git a/README.md b/README.md index c5d6d4f..b730982 100644 --- a/README.md +++ b/README.md @@ -10,14 +10,14 @@ tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2) ## Features -- Tree Calculus operator: `t` -- Immutable definitions: `x = t t` -- Lambda abstraction: `id = (a : a)` -- List, Number, and String literals: `[(2) ("Hello")]` -- Function application: `not (not false)` -- Higher order/first-class functions: `map (a : append a "!") [("Hello")]` -- Intensionality blurs the distinction between functions and data (see REPL examples) -- Simple module system for code organization +- Tree Calculus **operator**: `t` +- **Immutable definitions**: `x = t t` +- **Lambda abstraction**: `id = (a : a)` +- **List, Number, and String** literals: `[(2) ("Hello")]` +- **Function application**: `not (not false)` +- **Higher order/first-class functions**: `map (a : append a "!") [("Hello")]` +- **Intensionality** blurs the distinction between functions and data (see REPL examples) +- **Content-addressed store**: save, version, tag, and recall your tricu terms. ## REPL examples @@ -52,6 +52,16 @@ tricu < !reset -- Clear all REPL definitions tricu < !version -- Print tricu version ``` +## Content Store + +tricu uses a "content store" SQLite database that saves and versions your definitions persistently. + +* **Persistent definitions:** Any term you define in the REPL is automatically saved. +* **Content-addressed:** Terms are stored based on a SHA256 hash of their content. This means identical terms are stored only once, even if they have different names. +* **Versioning and history:** If you redefine a name, the Content Store keeps a record of previous definitions associated with that name. You can explore the history of a term and access older versions. +* **Tagging:** You can assign tags to versions of your terms to organize and quickly switch between related function versions. +* **Querying:** The store allows you to search for terms by name, hash, or tags. + ## Installation and Use You can easily build and run this project using [Nix](https://nixos.org/download/). diff --git a/lib/patterns.tri b/lib/patterns.tri index da55395..3dc9e3b 100644 --- a/lib/patterns.tri +++ b/lib/patterns.tri @@ -1,5 +1,5 @@ !import "base.tri" !Local -!import "list.tri" List +!import "list.tri" !Local match_ = y (self value patterns : triage @@ -17,8 +17,8 @@ match_ = y (self value patterns : patterns) match = (value patterns : - match_ value (List.map (sublist : - pair (List.head sublist) (List.head (List.tail sublist))) + match_ value (map (sublist : + pair (head sublist) (head (tail sublist))) patterns)) otherwise = const (t t) diff --git a/src/ContentStore.hs b/src/ContentStore.hs new file mode 100644 index 0000000..70df48c --- /dev/null +++ b/src/ContentStore.hs @@ -0,0 +1,228 @@ +module ContentStore where + +import Research +import Parser + +import Control.Monad (foldM, forM) +import Crypto.Hash (hash, SHA256, Digest) +import Data.ByteString (ByteString) +import Data.List (intercalate, nub, sortBy, sort) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Database.SQLite.Simple +import Database.SQLite.Simple.FromRow (FromRow(..), field) +import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..)) +import System.FilePath ((), takeDirectory) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map +import qualified Data.Serialize as Cereal +import qualified Data.Text as T + +data StoredTerm = StoredTerm + { termHash :: Text + , termNames :: Text + , termData :: ByteString + , termMetadata :: Text + , termCreatedAt :: Integer + , termTags :: Text + } deriving (Show) + +instance FromRow StoredTerm where + fromRow = StoredTerm <$> field <*> field <*> field <*> field <*> field <*> field + +tryDeserializeTerm :: ByteString -> IO (Maybe T) +tryDeserializeTerm bs = + case deserializeTerm bs of + Right t -> return $ Just t + Left err -> do + putStrLn $ "Error deserializing term: " ++ err + return Nothing + +parseNameList :: Text -> [Text] +parseNameList = filter (not . T.null) . T.splitOn "," + +serializeNameList :: [Text] -> Text +serializeNameList = T.intercalate "," . nub . sort + +initContentStore :: IO Connection +initContentStore = do + dbPath <- getContentStorePath + createDirectoryIfMissing True (takeDirectory dbPath) + conn <- open dbPath + execute_ conn "CREATE TABLE IF NOT EXISTS terms (\ + \hash TEXT PRIMARY KEY, \ + \names TEXT, \ + \term_data BLOB, \ + \metadata TEXT, \ + \created_at INTEGER DEFAULT (strftime('%s','now')), \ + \tags TEXT DEFAULT '')" + execute_ conn "CREATE INDEX IF NOT EXISTS terms_names_idx ON terms(names)" + execute_ conn "CREATE INDEX IF NOT EXISTS terms_tags_idx ON terms(tags)" + return conn + +getContentStorePath :: IO FilePath +getContentStorePath = do + dataDir <- getXdgDirectory XdgData "tricu" + return $ dataDir "content-store.db" + +instance Cereal.Serialize T where + put Leaf = Cereal.putWord8 0 + put (Stem t) = do + Cereal.putWord8 1 + Cereal.put t + put (Fork a b) = do + Cereal.putWord8 2 + Cereal.put a + Cereal.put b + + get = do + tag <- Cereal.getWord8 + case tag of + 0 -> return Leaf + 1 -> Stem <$> Cereal.get + 2 -> Fork <$> Cereal.get <*> Cereal.get + _ -> fail $ "Invalid tag for T: " ++ show tag + +serializeTerm :: T -> ByteString +serializeTerm = LBS.toStrict . Cereal.encodeLazy + +deserializeTerm :: ByteString -> Either String T +deserializeTerm = Cereal.decodeLazy . LBS.fromStrict + +hashTerm :: T -> Text +hashTerm = T.pack . show . (hash :: ByteString -> Digest SHA256) . serializeTerm + +storeTerm :: Connection -> [String] -> T -> IO Text +storeTerm conn newNamesStrList term = do + let termBS = serializeTerm term + termHashText = hashTerm term + newNamesTextList = map T.pack newNamesStrList + metadataText = T.pack "{}" + + existingNamesQuery <- query conn + "SELECT names FROM terms WHERE hash = ?" + (Only termHashText) :: IO [Only Text] + + case existingNamesQuery of + [] -> do + let allNamesToStore = serializeNameList newNamesTextList + execute conn + "INSERT INTO terms (hash, names, term_data, metadata, tags) VALUES (?, ?, ?, ?, ?)" + (termHashText, allNamesToStore, termBS, metadataText, T.pack "") + [(Only currentNamesText)] -> do + let currentNamesList = parseNameList currentNamesText + let combinedNamesList = currentNamesList ++ newNamesTextList + let allNamesToStore = serializeNameList combinedNamesList + execute conn + "UPDATE terms SET names = ?, metadata = ? WHERE hash = ?" + (allNamesToStore, metadataText, termHashText) + + return termHashText + +hashToTerm :: Connection -> Text -> IO (Maybe StoredTerm) +hashToTerm conn hashText = + queryMaybeOne conn (selectStoredTermFields <> " WHERE hash = ?") (Only hashText) + +nameToTerm :: Connection -> Text -> IO (Maybe StoredTerm) +nameToTerm conn nameText = + queryMaybeOne conn (selectStoredTermFields <> " WHERE names LIKE ? ORDER BY created_at DESC LIMIT 1") (Only $ "%" <> nameText <> "%") + +listStoredTerms :: Connection -> IO [StoredTerm] +listStoredTerms conn = + query_ conn (selectStoredTermFields <> " ORDER BY created_at DESC") + +storeEnvironment :: Connection -> Env -> IO [(String, Text)] +storeEnvironment conn env = do + let defs = Map.toList $ Map.delete "!result" env + let groupedDefs = Map.toList $ Map.fromListWith (++) [(term, [name]) | (name, term) <- defs] + + forM groupedDefs $ \(term, namesList) -> do + hashVal <- storeTerm conn namesList term + return (head namesList, hashVal) + +loadTerm :: Connection -> String -> IO (Maybe T) +loadTerm conn identifier = do + result <- getTerm conn (T.pack identifier) + case result of + Just storedTerm -> tryDeserializeTerm (termData storedTerm) + Nothing -> return Nothing + +getTerm :: Connection -> Text -> IO (Maybe StoredTerm) +getTerm conn identifier = do + if '#' `elem` (T.unpack identifier) + then hashToTerm conn (T.pack $ drop 1 (T.unpack identifier)) + else nameToTerm conn identifier + +loadEnvironment :: Connection -> IO Env +loadEnvironment conn = do + terms <- listStoredTerms conn + foldM addTermToEnv Map.empty terms + where + addTermToEnv env storedTerm = do + maybeT <- tryDeserializeTerm (termData storedTerm) + case maybeT of + Just t -> do + let namesList = parseNameList (termNames storedTerm) + return $ foldl (\e name -> Map.insert (T.unpack name) t e) env namesList + Nothing -> return env + +termVersions :: Connection -> String -> IO [(Text, T, Integer)] +termVersions conn name = do + let nameText = T.pack name + results <- query conn + "SELECT hash, term_data, created_at FROM terms WHERE names LIKE ? ORDER BY created_at DESC" + (Only $ "%" <> nameText <> "%") + + catMaybes <$> mapM (\(hashVal, termDataVal, timestamp) -> do + maybeT <- tryDeserializeTerm termDataVal + return $ fmap (\t -> (hashVal, t, timestamp)) maybeT + ) results + +setTag :: Connection -> Text -> Text -> IO () +setTag conn hash tagValue = do + exists <- termExists conn hash + if exists + then do + currentTagsQuery <- query conn "SELECT tags FROM terms WHERE hash = ?" (Only hash) :: IO [Only Text] + case currentTagsQuery of + [Only tagsText] -> do + let tagsList = parseNameList tagsText + newTagsList = tagValue : tagsList + newTags = serializeNameList newTagsList + execute conn "UPDATE terms SET tags = ? WHERE hash = ?" (newTags, hash) + _ -> putStrLn $ "Term with hash " ++ T.unpack hash ++ " not found (should not happen if exists is true)" + else + putStrLn $ "Term with hash " ++ T.unpack hash ++ " does not exist" + +termExists :: Connection -> Text -> IO Bool +termExists conn hash = do + results <- query conn "SELECT 1 FROM terms WHERE hash = ? LIMIT 1" (Only hash) :: IO [[Int]] + return $ not (null results) + +termToTags :: Connection -> Text -> IO [Text] +termToTags conn hash = do + tagsQuery <- query conn "SELECT tags FROM terms WHERE hash = ?" (Only hash) :: IO [Only Text] + case tagsQuery of + [Only tagsText] -> return $ parseNameList tagsText + _ -> return [] + +tagToTerm :: Connection -> Text -> IO [StoredTerm] +tagToTerm conn tagValue = do + let pattern = "%" <> tagValue <> "%" + query conn (selectStoredTermFields <> " WHERE tags LIKE ? ORDER BY created_at DESC") (Only pattern) + +allTermTags :: Connection -> IO [StoredTerm] +allTermTags conn = do + query_ conn (selectStoredTermFields <> " WHERE tags IS NOT NULL AND tags != '' ORDER BY created_at DESC") + +selectStoredTermFields :: Query +selectStoredTermFields = "SELECT hash, names, term_data, metadata, created_at, tags FROM terms" + +queryMaybeOne :: (FromRow r, ToRow q) => Connection -> Query -> q -> IO (Maybe r) +queryMaybeOne conn qry params = do + results <- query conn qry params + case results of + [row] -> return $ Just row + _ -> return Nothing diff --git a/src/Eval.hs b/src/Eval.hs index a69f210..2a501b7 100644 --- a/src/Eval.hs +++ b/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) + _ -> [] diff --git a/src/FileEval.hs b/src/FileEval.hs index 50dd8b8..f0ddac1 100644 --- a/src/FileEval.hs +++ b/src/FileEval.hs @@ -109,9 +109,9 @@ nsDefinition moduleName other = nsBody moduleName other nsBody :: String -> TricuAST -> TricuAST -nsBody moduleName (SVar name) - | isPrefixed name = SVar name - | otherwise = SVar (nsVariable moduleName name) +nsBody moduleName (SVar name mhash) + | isPrefixed name = SVar name mhash + | otherwise = SVar (nsVariable moduleName name) mhash nsBody moduleName (SApp func arg) = SApp (nsBody moduleName func) (nsBody moduleName arg) nsBody moduleName (SLambda args body) = @@ -122,18 +122,16 @@ nsBody moduleName (TFork left right) = TFork (nsBody moduleName left) (nsBody moduleName right) nsBody moduleName (TStem subtree) = TStem (nsBody moduleName subtree) -nsBody moduleName (SDef name args body) - | isPrefixed name = SDef name args (nsBody moduleName body) - | otherwise = SDef (nsVariable moduleName name) - args (nsBody moduleName body) +nsBody moduleName (SDef name args body) = + SDef (nsVariable moduleName name) args (nsBodyScoped moduleName args body) nsBody _ other = other nsBodyScoped :: String -> [String] -> TricuAST -> TricuAST nsBodyScoped moduleName args body = case body of - SVar name -> + SVar name mhash -> if name `elem` args - then SVar name - else nsBody moduleName (SVar name) + then SVar name mhash + else nsBody moduleName (SVar name mhash) SApp func arg -> SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg) SLambda innerArgs innerBody -> @@ -141,13 +139,11 @@ nsBodyScoped moduleName args body = case body of SList items -> SList (map (nsBodyScoped moduleName args) items) TFork left right -> - TFork (nsBodyScoped moduleName args left) - (nsBodyScoped moduleName args right) + TFork (nsBodyScoped moduleName args left) (nsBodyScoped moduleName args right) TStem subtree -> TStem (nsBodyScoped moduleName args subtree) SDef name innerArgs innerBody -> - SDef (nsVariable moduleName name) innerArgs - (nsBodyScoped moduleName (args ++ innerArgs) innerBody) + SDef (nsVariable moduleName name) innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody) other -> other isPrefixed :: String -> Bool diff --git a/src/Lexer.hs b/src/Lexer.hs index 173f10e..358bb95 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -35,6 +35,7 @@ tricuLexer = do [ try lnewline , try namespace , try dot + , try identifierWithHash , try identifier , try keywordT , try integerLiteral @@ -56,12 +57,33 @@ lexTricu input = case runParser tricuLexer "" input of keywordT :: Lexer LToken keywordT = string "t" *> notFollowedBy alphaNumChar $> LKeywordT +identifierWithHash :: Lexer LToken +identifierWithHash = do + first <- lowerChar <|> char '_' + rest <- many $ letterChar + <|> digitChar <|> char '_' <|> char '-' <|> char '?' + <|> char '$' <|> char '@' <|> char '%' + _ <- char '#' -- Consume '#' + hashString <- some (alphaNumChar <|> char '-') -- Ensures at least one char for hash + "hash characters (alphanumeric or hyphen)" + + let name = first : rest + let hashLen = length hashString + if name == "t" || name == "!result" + then fail "Keywords (`t`, `!result`) cannot be used with a hash suffix." + else if hashLen < 16 then + fail $ "Hash suffix for '" ++ name ++ "' must be at least 16 characters long. Got " ++ show hashLen ++ " ('" ++ hashString ++ "')." + else if hashLen > 64 then -- Assuming SHA256, max 64 + fail $ "Hash suffix for '" ++ name ++ "' cannot be longer than 64 characters (SHA256). Got " ++ show hashLen ++ " ('" ++ hashString ++ "')." + else + return (LIdentifierWithHash name hashString) + identifier :: Lexer LToken identifier = do first <- lowerChar <|> char '_' rest <- many $ letterChar <|> digitChar <|> char '_' <|> char '-' <|> char '?' - <|> char '$' <|> char '#' <|> char '@' <|> char '%' + <|> char '$' <|> char '@' <|> char '%' let name = first : rest if name == "t" || name == "!result" then fail "Keywords (`t`, `!result`) cannot be used as an identifier" diff --git a/src/Main.hs b/src/Main.hs index 46cee46..5a43b33 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,6 +5,7 @@ import FileEval import Parser (parseTricu) import REPL import Research +import ContentStore import Control.Monad (foldM) import Control.Monad.IO.Class (liftIO) @@ -65,7 +66,7 @@ main = do putStrLn "Welcome to the tricu REPL" putStrLn "You may exit with `CTRL+D` or the `!exit` command." putStrLn "Try typing `!` with tab completion for more commands." - repl Map.empty + repl Evaluate { file = filePaths, form = form } -> do result <- case filePaths of [] -> runTricuT <$> getContents @@ -81,8 +82,6 @@ main = do (filePath:_) -> readFile filePath putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value --- Simple interfaces - runTricu :: String -> String runTricu = formatT TreeCalculus . runTricuT @@ -125,4 +124,4 @@ runTricuEnvWithEnv env input = let asts = parseTricu input finalEnv = evalTricu env asts res = result finalEnv - in (finalEnv, formatT TreeCalculus res) \ No newline at end of file + in (finalEnv, formatT TreeCalculus res) diff --git a/src/Parser.hs b/src/Parser.hs index 8efa9e4..ff33623 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -249,7 +249,7 @@ parseGroupedItemM = do parseSingleItemM :: ParserM TricuAST parseSingleItemM = do token <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False) - if | LIdentifier name <- token -> pure (SVar name) + if | LIdentifier name <- token -> pure (SVar name Nothing) | token == LKeywordT -> pure TLeaf | otherwise -> fail "Unexpected token in list item" @@ -258,16 +258,25 @@ parseVarM = do token <- satisfyM (\case LNamespace _ -> True LIdentifier _ -> True + LIdentifierWithHash _ _ -> True _ -> False) + case token of LNamespace ns -> do _ <- satisfyM (== LDot) LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False) - pure $ SVar (ns ++ "." ++ name) + pure $ SVar (ns ++ "." ++ name) Nothing + LIdentifier name | name == "t" || name == "!result" -> fail ("Reserved keyword: " ++ name ++ " cannot be assigned.") - | otherwise -> pure (SVar name) + | otherwise -> pure (SVar name Nothing) + + LIdentifierWithHash name hash -> + if name == "t" || name == "!result" + then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.") + else pure (SVar name (Just hash)) + _ -> fail "Unexpected token while parsing variable" parseIntLiteralM :: ParserM TricuAST @@ -275,7 +284,7 @@ parseIntLiteralM = do let intL = (\case LIntegerLiteral _ -> True; _ -> False) token <- satisfyM intL if | LIntegerLiteral value <- token -> - pure (SInt value) + pure (SInt (fromIntegral value)) | otherwise -> fail "Unexpected token while parsing integer literal" diff --git a/src/REPL.hs b/src/REPL.hs index 09428e2..f133be8 100644 --- a/src/REPL.hs +++ b/src/REPL.hs @@ -5,6 +5,17 @@ import FileEval import Lexer import Parser import Research +import ContentStore + +import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId) +import Control.Monad (forever, void, when, forM, forM_, foldM, unless) +import Data.ByteString (ByteString) +import Data.Maybe (isNothing, isJust, fromJust, catMaybes) +import Database.SQLite.Simple (Connection, Only(..), query, query_, execute, execute_, open) +import System.Directory (doesFileExist, createDirectoryIfMissing) +import System.FSNotify +import System.FilePath (takeDirectory, ()) +import Text.Read (readMaybe) import Control.Exception (IOException, SomeException, catch , displayException) @@ -14,17 +25,37 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Char (isSpace, isUpper) -import Data.List (dropWhile, dropWhileEnd, isPrefixOf) +import Data.List ((\\), dropWhile, dropWhileEnd, isPrefixOf, nub, sortBy, groupBy, intercalate, find) import Data.Version (showVersion) import Paths_tricu (version) import System.Console.Haskeline +import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..), + Color(..), ConsoleIntensity(..), clearFromCursorToLineEnd) import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Text.IO as T -repl :: Env -> IO () -repl env = runInputT settings (withInterrupt (loop env Decode)) +import Control.Concurrent (forkIO, threadDelay) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Time (UTCTime, getCurrentTime, diffUTCTime) +import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar) + +import Data.Time.Format (formatTime, defaultTimeLocale) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) + +data REPLState = REPLState + { replForm :: EvaluatedForm + , replContentStore :: Maybe Connection + , replWatchedFile :: Maybe FilePath + , replSelectedVersions :: Map.Map String T.Text + , replWatcherThread :: Maybe ThreadId + } + +repl :: IO () +repl = do + conn <- ContentStore.initContentStore + runInputT settings (withInterrupt (loop (REPLState Decode (Just conn) Nothing Map.empty Nothing))) where settings :: Settings IO settings = Settings @@ -39,49 +70,65 @@ repl env = runInputT settings (withInterrupt (loop env Decode)) where commands = [ "!exit" , "!output" - , "!definitions" , "!import" , "!clear" - , "!save" , "!reset" - , "!version" + , "!help" + , "!definitions" + , "!watch" + , "!refresh" + , "!versions" + , "!select" + , "!tag" ] - loop :: Env -> EvaluatedForm -> InputT IO () - loop env form = handle (interruptHandler env form) $ do + loop :: REPLState -> InputT IO () + loop state = handle (\Interrupt -> interruptHandler state Interrupt) $ do minput <- getInputLine "tricu < " case minput of - Nothing -> outputStrLn "Exiting tricu" + Nothing -> return () Just s - | strip s == "" -> loop env form + | strip s == "" -> loop state | strip s == "!exit" -> outputStrLn "Exiting tricu" | strip s == "!clear" -> do liftIO $ putStr "\ESC[2J\ESC[H" - loop env form + loop state | strip s == "!reset" -> do - outputStrLn "Environment reset to initial state" - loop Map.empty form - | strip s == "!version" -> do + outputStrLn "Selected versions reset" + loop state { replSelectedVersions = Map.empty } + | strip s == "!help" -> do outputStrLn $ "tricu version " ++ showVersion version - loop env form - | "!save" `isPrefixOf` strip s -> handleSave env form - | strip s == "!output" -> handleOutput env form - | strip s == "!definitions" -> do - let defs = Map.keys $ Map.delete "!result" env - if null defs - then outputStrLn "No definitions discovered." - else do - outputStrLn "Available definitions:" - mapM_ outputStrLn defs - loop env form - | "!import" `isPrefixOf` strip s -> handleImport env form - | take 2 s == "--" -> loop env form + outputStrLn "Available commands:" + outputStrLn " !exit - Exit the REPL" + outputStrLn " !clear - Clear the screen" + outputStrLn " !reset - Reset selected versions (for lookups)" + outputStrLn " !help - Show tricu version and available commands" + outputStrLn " !output - Change output format (tree|fsl|ast|ternary|ascii|decode)" + outputStrLn " !definitions - List all defined terms in the content store" + outputStrLn " !import - Import definitions from file (definitions are stored)" + outputStrLn " !watch - Watch a file for changes (definitions are stored)" + outputStrLn " !refresh - (Currently no-op, definitions are live)" + outputStrLn " !versions - Show all versions of a term by name" + outputStrLn " !select - Select a specific version of a term for subsequent lookups" + outputStrLn " !tag - Add or update a tag for a term (by hash or name)" + loop state + | strip s == "!output" -> handleOutput state + | strip s == "!definitions" -> handleDefinitions state + | "!import" `isPrefixOf` strip s -> handleImport state + | "!watch" `isPrefixOf` strip s -> handleWatch state + | strip s == "!refresh" -> handleRefresh state + | "!versions" `isPrefixOf` strip s -> handleVersions state + | "!select" `isPrefixOf` strip s -> handleSelect state + | "!tag" `isPrefixOf` strip s -> handleTag state + | take 2 s == "--" -> loop state | otherwise -> do - newEnv <- liftIO $ processInput env s form `catch` errorHandler env - loop newEnv form + result <- liftIO $ catch + (processInput state s) + (errorHandler state) + loop result - handleOutput :: Env -> EvaluatedForm -> InputT IO () - handleOutput env currentForm = do + handleOutput :: REPLState -> InputT IO () + handleOutput state = do let formats = [Decode, TreeCalculus, FSL, AST, Ternary, Ascii] outputStrLn "Available output formats:" mapM_ (\(i, f) -> outputStrLn $ show i ++ ". " ++ show f) @@ -97,94 +144,462 @@ repl env = runInputT settings (withInterrupt (loop env Decode)) case result of Nothing -> do outputStrLn "Invalid selection. Keeping current output format." - loop env currentForm + loop state Just newForm -> do outputStrLn $ "Output format changed to: " ++ show newForm - loop env newForm + loop state { replForm = newForm } - handleImport :: Env -> EvaluatedForm -> InputT IO () - handleImport env form = do - res <- runMaybeT $ do - let fset = setComplete completeFilename defaultSettings - path <- MaybeT $ runInputT fset $ - getInputLineWithInitial "File path to load < " ("", "") + handleDefinitions :: REPLState -> InputT IO () + handleDefinitions state = case replContentStore state of + Nothing -> do + liftIO $ printError "Content store not initialized" + loop state + Just conn -> do + terms <- liftIO $ ContentStore.listStoredTerms conn + + if null terms + then do + liftIO $ printWarning "No terms in content store." + loop state + else do + liftIO $ do + printSuccess $ "Content store contains " ++ show (length terms) ++ " terms:" - text <- MaybeT $ liftIO $ handle (\e -> do - putStrLn $ "Error reading file: " ++ displayException (e :: IOException) - return Nothing - ) $ Just <$> readFile (strip path) + let maxNameWidth = maximum $ map (length . T.unpack . termNames) terms - case parseProgram (lexTricu text) of - Left err -> do - lift $ outputStrLn $ "Parse error: " ++ handleParseError err - MaybeT $ return Nothing - Right ast -> do - ns <- MaybeT $ runInputT defaultSettings $ - getInputLineWithInitial "Namespace (or !Local for no namespace) < " ("", "") + forM_ terms $ \term -> do + let namesStr = T.unpack (termNames term) + hash = termHash term + padding = replicate (maxNameWidth - length namesStr) ' ' + + liftIO $ do + putStr " " + printVariable namesStr + putStr padding + putStr " [hash: " + displayColoredHash hash + putStrLn "]" + + tags <- ContentStore.termToTags conn hash + unless (null tags) $ displayTags tags - let name = strip ns - if (name /= "!Local" && (null name || not (isUpper (head name)))) then do - lift $ outputStrLn "Namespace must start with an uppercase letter" - MaybeT $ return Nothing - else do - prog <- liftIO $ preprocessFile (strip path) - let code = case name of - "!Local" -> prog - _ -> nsDefinitions name prog - env' = evalTricu env code - return env' - case res of + loop state + + handleImport :: REPLState -> InputT IO () + handleImport state = do + let fset = setComplete completeFilename defaultSettings + filename <- runInputT fset $ getInputLineWithInitial "File to import: " ("", "") + case filename of + Nothing -> loop state + Just f -> do + let cleanFilename = strip f + exists <- liftIO $ doesFileExist cleanFilename + if not exists + then do + liftIO $ printError $ "File not found: " ++ cleanFilename + loop state + else importFile state cleanFilename + + importFile :: REPLState -> String -> InputT IO () + importFile state cleanFilename = do + code <- liftIO $ readFile cleanFilename + case replContentStore state of Nothing -> do - outputStrLn "Import cancelled" - loop env form - Just env' -> - loop (Map.delete "!result" env') form + liftIO $ printError "Content store not initialized" + loop state + Just conn -> do + env <- liftIO $ evaluateFile cleanFilename + + liftIO $ do + printSuccess $ "Importing file: " ++ cleanFilename + let defs = Map.toList $ Map.delete "!result" env + + importedCount <- foldM (\count (name, term) -> do + hash <- ContentStore.storeTerm conn [name] term + printSuccess $ "Stored definition: " ++ name ++ " with hash " ++ T.unpack hash + return (count + 1) + ) 0 defs + + printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully" + + loop state - interruptHandler :: Env -> EvaluatedForm -> Interrupt -> InputT IO () - interruptHandler env form _ = do - outputStrLn "Interrupted with CTRL+C\n\ - \You can use the !exit command or CTRL+D to exit" - loop env form + handleWatch :: REPLState -> InputT IO () + handleWatch state = do + dbPath <- liftIO ContentStore.getContentStorePath + let filepath = takeDirectory dbPath "scratch.tri" + let dirPath = takeDirectory filepath - processInput :: Env -> String -> EvaluatedForm -> IO Env - processInput env input form = do - let asts = parseTricu input - newEnv = evalTricu env asts - case Map.lookup "!result" newEnv of - Just r -> do - putStrLn $ "tricu > " ++ formatT form r - Nothing -> pure () - return newEnv + liftIO $ createDirectoryIfMissing True dirPath - errorHandler :: Env -> SomeException -> IO (Env) - errorHandler env e = do - putStrLn $ "Error: " ++ show e - return env + fileExists <- liftIO $ doesFileExist filepath + unless fileExists $ liftIO $ writeFile filepath "-- tricu scratch file\n\n" + + outputStrLn $ "Using scratch file: " ++ filepath + + when (isJust (replWatcherThread state)) $ do + outputStrLn "Stopping previous file watch" + liftIO $ killThread (fromJust $ replWatcherThread state) + + outputStrLn $ "Starting to watch file: " ++ filepath + outputStrLn "Press Ctrl+C to stop watching and return to REPL" + + liftIO $ processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state) + + lastProcessedRef <- liftIO $ newIORef =<< getCurrentTime + + watcherId <- liftIO $ forkIO $ withManager $ \mgr -> do + stopAction <- watchDir mgr dirPath (\event -> eventPath event == filepath) $ \event -> do + now <- getCurrentTime + lastProcessed <- readIORef lastProcessedRef + when (diffUTCTime now lastProcessed > 0.5) $ do + putStrLn $ "\nFile changed: " ++ filepath + processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state) + writeIORef lastProcessedRef now + forever $ threadDelay 1000000 + + watchLoop state { replWatchedFile = Just filepath, replWatcherThread = Just watcherId } + + handleUnwatch :: REPLState -> InputT IO () + handleUnwatch state = case replWatchedFile state of + Nothing -> do + outputStrLn "No file is currently being watched" + loop state + Just path -> do + outputStrLn $ "Stopped watching " ++ path + when (isJust (replWatcherThread state)) $ do + liftIO $ killThread (fromJust $ replWatcherThread state) + loop state { replWatchedFile = Nothing, replWatcherThread = Nothing } + + handleRefresh :: REPLState -> InputT IO () + handleRefresh state = case replContentStore state of + Nothing -> do + outputStrLn "Content store not initialized" + loop state + Just conn -> do + outputStrLn "Environment refreshed from content store (definitions are live)" + loop state + + handleVersions :: REPLState -> InputT IO () + handleVersions state = case replContentStore state of + Nothing -> do + liftIO $ printError "Content store not initialized" + loop state + Just conn -> do + liftIO $ printPrompt "Term name: " + nameInput <- getInputLine "" + case nameInput of + Nothing -> loop state + Just n -> do + let termName = strip n + versions <- liftIO $ ContentStore.termVersions conn termName + if null versions + then liftIO $ printError $ "No versions found for term: " ++ termName + else do + liftIO $ do + printKeyword "Versions of " + printVariable termName + putStrLn ":" + + forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do + tags <- ContentStore.termToTags conn hash + putStr $ show (i :: Int) ++ ". " + displayColoredHash hash + putStr $ " (" ++ formatTimestamp ts ++ ")" + unless (null tags) $ do + putStr " [" + printKeyword "Tags: " + forM_ (zip [0..] tags) $ \(j, tag) -> do + printTag (T.unpack tag) + when (j < length tags - 1) $ putStr ", " + putStr "]" + putStrLn "" + loop state + + handleSelect :: REPLState -> InputT IO () + handleSelect state = case replContentStore state of + Nothing -> do + liftIO $ printError "Content store not initialized" + loop state + Just conn -> do + liftIO $ printPrompt "Term name: " + nameInput <- getInputLine "" + case nameInput of + Nothing -> loop state + Just n -> do + let cleanName = strip n + versions <- liftIO $ ContentStore.termVersions conn cleanName + if null versions + then do + liftIO $ printError $ "No versions found for term: " ++ cleanName + loop state + else do + liftIO $ do + printKeyword "Versions of " + printVariable cleanName + putStrLn ":" + + forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do + tags <- ContentStore.termToTags conn hash + putStr $ show (i :: Int) ++ ". " + displayColoredHash hash + putStr $ " (" ++ formatTimestamp ts ++ ")" + unless (null tags) $ do + putStr " [" + printKeyword "Tags: " + forM_ (zip [0..] tags) $ \(j, tag) -> do + printTag (T.unpack tag) + when (j < length tags - 1) $ putStr ", " + putStr "]" + putStrLn "" + + liftIO $ printPrompt "Select version (number or full hash, Enter to cancel): " + choiceInput <- getInputLine "" + let choice = strip <$> choiceInput + + selectedHash <- case choice of + Just selectedStr | not (null selectedStr) -> do + case readMaybe selectedStr :: Maybe Int of + Just idx | idx > 0 && idx <= length versions -> do + let (h, _, _) = versions !! (idx - 1) + return $ Just h + _ -> do + let potentialHash = T.pack selectedStr + let foundByHash = find (\(h, _, _) -> T.isPrefixOf potentialHash h) versions + case foundByHash of + Just (h, _, _) -> return $ Just h + Nothing -> do + liftIO $ printError "Invalid selection or hash not found in list." + return Nothing + _ -> return Nothing + + case selectedHash of + Just hashToSelect -> do + let newState = state { replSelectedVersions = + Map.insert cleanName hashToSelect (replSelectedVersions state) } + liftIO $ do + printSuccess "Selected version " + displayColoredHash hashToSelect + putStr " for term " + printVariable cleanName + putStrLn "" + loop newState + Nothing -> loop state + + handleTag :: REPLState -> InputT IO () + handleTag state = case replContentStore state of + Nothing -> do + liftIO $ printError "Content store not initialized" + loop state + Just conn -> do + liftIO $ printPrompt "Term hash (full or prefix) or name (most recent version will be used): " + identInput <- getInputLine "" + case identInput of + Nothing -> loop state + Just ident -> do + let cleanIdent = strip ident + + mFullHash <- liftIO $ resolveIdentifierToHash conn cleanIdent + + case mFullHash of + Nothing -> do + liftIO $ printError $ "Could not resolve identifier: " ++ cleanIdent + loop state + Just fullHash -> do + liftIO $ do + putStr "Tagging term with hash: " + displayColoredHash fullHash + putStrLn "" + tags <- liftIO $ ContentStore.termToTags conn fullHash + unless (null tags) $ do + liftIO $ do + printKeyword "Existing tags:" + displayTags tags + + liftIO $ printPrompt "Tag to add/set: " + tagValueInput <- getInputLine "" + case tagValueInput of + Nothing -> loop state + Just tv -> do + let tagVal = T.pack (strip tv) + liftIO $ do + ContentStore.setTag conn fullHash tagVal + printSuccess $ "Tag '" + printTag (T.unpack tagVal) + putStr "' set for term with hash " + displayColoredHash fullHash + putStrLn "" + loop state + + resolveIdentifierToHash :: Connection -> String -> IO (Maybe T.Text) + resolveIdentifierToHash conn ident + | T.pack "#" `T.isInfixOf` T.pack ident = do + let hashPrefix = T.pack ident + matchingHashes <- liftIO $ query conn "SELECT hash FROM terms WHERE hash LIKE ?" (Only (hashPrefix <> "%")) :: IO [Only T.Text] + case matchingHashes of + [Only fullHash] -> return $ Just fullHash + [] -> do printError $ "No hash found starting with: " ++ T.unpack hashPrefix; return Nothing + _ -> do printError $ "Ambiguous hash prefix: " ++ T.unpack hashPrefix; return Nothing + | otherwise = do + versions <- ContentStore.termVersions conn ident + if null versions + then do printError $ "No versions found for term name: " ++ ident; return Nothing + else return $ Just $ (\(h,_,_) -> h) $ head versions + + interruptHandler :: REPLState -> Interrupt -> InputT IO () + interruptHandler state _ = do + liftIO $ do + printWarning "Interrupted with CTRL+C" + printWarning "You can use the !exit command or CTRL+D to exit" + loop state + + errorHandler :: REPLState -> SomeException -> IO REPLState + errorHandler state e = do + printError $ "Error: " ++ displayException e + return state + + processInput :: REPLState -> String -> IO REPLState + processInput state input = do + let asts = parseTricu input + case asts of + [] -> return state + _ -> case replContentStore state of + Nothing -> do + printError "Content store not initialized" + return state + Just conn -> do + newState <- foldM (\s astNode -> do + let varsInAst = Eval.findVarNames astNode + foldM (\currentSelectionState varName -> + if Map.member varName (replSelectedVersions currentSelectionState) + then return currentSelectionState + else do + versions <- ContentStore.termVersions conn varName + if length versions > 1 + then do + let (latestHash, _, _) = head versions + liftIO $ printWarning $ "Multiple versions of '" ++ varName ++ "' found. Using most recent." + return currentSelectionState { replSelectedVersions = Map.insert varName latestHash (replSelectedVersions currentSelectionState) } + else return currentSelectionState + ) s varsInAst + ) state asts + + forM_ asts $ \ast -> do + case ast of + SDef name [] body -> do + result <- evalAST (Just conn) (replSelectedVersions newState) body + hash <- ContentStore.storeTerm conn [name] result + + liftIO $ do + putStr "tricu > " + printSuccess "Stored definition: " + printVariable name + putStr " with hash " + displayColoredHash hash + putStrLn "" + + putStr "tricu > " + printResult $ formatT (replForm newState) result + putStrLn "" + + _ -> do + result <- evalAST (Just conn) (replSelectedVersions newState) ast + liftIO $ do + putStr "tricu > " + printResult $ formatT (replForm newState) result + putStrLn "" + return newState strip :: String -> String strip = dropWhileEnd isSpace . dropWhile isSpace - handleSave :: Env -> EvaluatedForm -> InputT IO () - handleSave env form = do - let fset = setComplete completeFilename defaultSettings - path <- runInputT fset $ - getInputLineWithInitial "File to save < " ("", "") + watchLoop :: REPLState -> InputT IO () + watchLoop state = handle (\Interrupt -> do + outputStrLn "\nStopped watching file" + when (isJust (replWatcherThread state)) $ do + liftIO $ killThread (fromJust $ replWatcherThread state) + loop state { replWatchedFile = Nothing, replWatcherThread = Nothing }) $ do + liftIO $ threadDelay 1000000 + watchLoop state - case path of - Nothing -> do - outputStrLn "Save cancelled" - loop env form - Just p -> do - let definitions = Map.toList $ Map.delete "!result" env - filepath = strip p + processWatchedFile :: FilePath -> Maybe Connection -> Map.Map String T.Text -> EvaluatedForm -> IO () + processWatchedFile filepath mconn selectedVersions outputForm = do + content <- readFile filepath + let asts = parseTricu content - outputStrLn "Starting save..." - liftIO $ writeFile filepath "" - outputStrLn "File created..." - forM_ definitions $ \(name, value) -> do - let content = name ++ " = " ++ formatT TreeCalculus value ++ "\n" - outputStrLn $ "Writing definition: " ++ name ++ " with length " ++ show (length content) - liftIO $ appendFile filepath content - outputStrLn $ "Saved " ++ show (length definitions) ++ " definitions to " ++ p + case mconn of + Nothing -> putStrLn "Content store not initialized for watched file processing." + Just conn -> do + forM_ asts $ \ast -> case ast of + SDef name [] body -> do + result <- evalAST (Just conn) selectedVersions body + hash <- ContentStore.storeTerm conn [name] result + putStrLn $ "tricu > Stored definition: " ++ name ++ " with hash " ++ T.unpack hash + putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm result + _ -> do + result <- evalAST (Just conn) selectedVersions ast + putStrLn $ "tricu > Result: " ++ formatT outputForm result + putStrLn $ "tricu > Processed file: " ++ filepath - loop env form + formatTimestamp :: Integer -> String + formatTimestamp ts = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" (posixSecondsToUTCTime (fromIntegral ts)) + + displayColoredHash :: T.Text -> IO () + displayColoredHash hash = do + let (prefix, rest) = T.splitAt 16 hash + setSGR [SetColor Foreground Vivid Cyan] + putStr $ T.unpack prefix + setSGR [SetColor Foreground Dull White] + putStr $ T.unpack rest + setSGR [Reset] + + coloredHashString :: T.Text -> String + coloredHashString hash = + "\ESC[1;36m" ++ T.unpack (T.take 16 hash) ++ + "\ESC[0;37m" ++ T.unpack (T.drop 16 hash) ++ + "\ESC[0m" + + withColor :: ColorIntensity -> Color -> IO () -> IO () + withColor intensity color action = do + setSGR [SetColor Foreground intensity color] + action + setSGR [Reset] + + printColored :: ColorIntensity -> Color -> String -> IO () + printColored intensity color text = withColor intensity color $ putStr text + + printlnColored :: ColorIntensity -> Color -> String -> IO () + printlnColored intensity color text = withColor intensity color $ putStrLn text + + printSuccess :: String -> IO () + printSuccess = printlnColored Vivid Green + + printError :: String -> IO () + printError = printlnColored Vivid Red + + printWarning :: String -> IO () + printWarning = printlnColored Vivid Yellow + + printPrompt :: String -> IO () + printPrompt = printColored Vivid Blue + + printVariable :: String -> IO () + printVariable = printColored Vivid Magenta + + printTag :: String -> IO () + printTag = printColored Vivid Yellow + + printKeyword :: String -> IO () + printKeyword = printColored Vivid Blue + + printResult :: String -> IO () + printResult = printColored Dull White + + displayTags :: [T.Text] -> IO () + displayTags [] = return () + displayTags tags = do + putStr " Tags: " + forM_ (zip [0..] tags) $ \(i, tag) -> do + printTag (T.unpack tag) + when (i < length tags - 1) $ putStr ", " + putStrLn "" diff --git a/src/Research.hs b/src/Research.hs index 2140388..781208e 100644 --- a/src/Research.hs +++ b/src/Research.hs @@ -14,7 +14,7 @@ data T = Leaf | Stem T | Fork T T -- Abstract Syntax Tree for tricu data TricuAST - = SVar String + = SVar String (Maybe String) -- Variable name and optional hash prefix | SInt Integer | SStr String | SList [TricuAST] @@ -30,11 +30,11 @@ data TricuAST -- Lexer Tokens data LToken - = LKeywordT - | LIdentifier String + = LIdentifier String + | LIdentifierWithHash String String + | LKeywordT | LNamespace String - | LIntegerLiteral Integer - | LStringLiteral String + | LImport String String | LAssign | LColon | LDot @@ -42,9 +42,10 @@ data LToken | LCloseParen | LOpenBracket | LCloseBracket + | LStringLiteral String + | LIntegerLiteral Int | LNewline - | LImport String String - deriving (Show, Eq, Ord) + deriving (Eq, Show, Ord) -- Output formats data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode @@ -54,7 +55,7 @@ data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode type Env = Map.Map String T -- Tree Calculus Reduction Rules -{- +{- The t operator is left associative. 1. t t a b -> a 2. t (t a) b c -> a c (b c) diff --git a/test/Spec.hs b/test/Spec.hs index c3af997..8972327 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,7 +12,6 @@ import Control.Monad.IO.Class (liftIO) import Data.List (isInfixOf) import Test.Tasty import Test.Tasty.HUnit -import Test.Tasty.QuickCheck import Text.Megaparsec (runParser) import qualified Data.Map as Map @@ -33,7 +32,7 @@ tests = testGroup "Tricu Tests" , providedLibraries , fileEval , modules - , demos +-- , demos , decoding ] @@ -103,7 +102,7 @@ parser = testGroup "Parser Tests" , testCase "Parse function definitions" $ do let input = "x = (a b c : a)" - expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a")))) + expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a" Nothing)))) parseSingle input @?= expect , testCase "Parse nested Tree Calculus terms" $ do @@ -123,7 +122,7 @@ parser = testGroup "Parser Tests" , testCase "Parse function with applications" $ do let input = "f = (x : t x)" - expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x"))) + expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x" Nothing))) parseSingle input @?= expect , testCase "Parse nested lists" $ do @@ -170,17 +169,17 @@ parser = testGroup "Parser Tests" , testCase "Parse lambda abstractions" $ do let input = "(a : a)" - expect = (SLambda ["a"] (SVar "a")) + expect = (SLambda ["a"] (SVar "a" Nothing)) parseSingle input @?= expect , testCase "Parse multiple arguments to lambda abstractions" $ do let input = "x = (a b : a)" - expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a"))) + expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a" Nothing))) parseSingle input @?= expect , testCase "Grouping T terms with parentheses in function application" $ do let input = "x = (a : a)\nx (t)" - expect = [SDef "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf] + expect = [SDef "x" [] (SLambda ["a"] (SVar "a" Nothing)),SApp (SVar "x" Nothing) TLeaf] parseTricu input @?= expect , testCase "Comments 1" $ do diff --git a/tricu.cabal b/tricu.cabal index 8bd6232..5bfe9ff 100644 --- a/tricu.cabal +++ b/tricu.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: tricu -version: 0.19.0 +version: 0.20.0 description: A micro-language for exploring Tree Calculus author: James Eversole maintainer: james@eversole.co @@ -21,18 +21,32 @@ executable tricu LambdaCase MultiWayIf OverloadedStrings + ScopedTypeVariables ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC build-depends: base >=4.7 + , aeson + , ansi-terminal + , base64-bytestring + , bytestring + , cereal , cmdargs , containers + , cryptonite + , directory , exceptions , filepath + , fsnotify , haskeline , megaparsec , mtl + , sqlite-simple + , tasty + , tasty-hunit , text + , time , transformers + , zlib other-modules: Eval FileEval @@ -51,20 +65,31 @@ test-suite tricu-tests LambdaCase MultiWayIf OverloadedStrings + ScopedTypeVariables build-depends: - base + base >=4.7 + , aeson + , ansi-terminal + , base64-bytestring + , bytestring + , cereal , cmdargs , containers + , cryptonite + , directory , exceptions , filepath + , fsnotify , haskeline , megaparsec , mtl + , sqlite-simple , tasty , tasty-hunit - , tasty-quickcheck , text + , time , transformers + , zlib default-language: Haskell2010 other-modules: Eval From 94514f7dd03c48578dceb1ed478ab891336c1c28 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Thu, 22 May 2025 16:52:37 -0500 Subject: [PATCH 2/6] Update README and !help REPL command --- README.md | 23 ++++++++++++++--------- src/REPL.hs | 9 ++++----- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/README.md b/README.md index b730982..eeb4739 100644 --- a/README.md +++ b/README.md @@ -41,15 +41,20 @@ tricu < -- or calculate its size (/demos/size.tri) tricu < size not? tricu > 12 -tricu < -- REPL Commands: -tricu < !definitions -- Lists all available definitions -tricu < !output -- Change output format (Tree, FSL, AST, etc.) -tricu < !import -- Import definitions from a file -tricu < !exit -- Exit the REPL -tricu < !clear -- ANSI screen clear -tricu < !save -- Save all REPL definitions to a file that you can !import -tricu < !reset -- Clear all REPL definitions -tricu < !version -- Print tricu version +tricu < !help +tricu version 0.20.0 +Available commands: + !exit - Exit the REPL + !clear - Clear the screen + !reset - Reset preferences for selected versions + !help - Show tricu version and available commands + !output - Change output format (tree|fsl|ast|ternary|ascii|decode) + !definitions - List all defined terms in the content store + !import - Import definitions from file (definitions are stored) + !watch - Watch a file for changes (definitions are stored) + !versions - Show all versions of a term by name + !select - Select a specific version of a term for subsequent lookups + !tag - Add or update a tag for a term by hash or name ``` ## Content Store diff --git a/src/REPL.hs b/src/REPL.hs index f133be8..873a460 100644 --- a/src/REPL.hs +++ b/src/REPL.hs @@ -101,16 +101,15 @@ repl = do outputStrLn "Available commands:" outputStrLn " !exit - Exit the REPL" outputStrLn " !clear - Clear the screen" - outputStrLn " !reset - Reset selected versions (for lookups)" + outputStrLn " !reset - Reset preferences for selected versions" outputStrLn " !help - Show tricu version and available commands" outputStrLn " !output - Change output format (tree|fsl|ast|ternary|ascii|decode)" outputStrLn " !definitions - List all defined terms in the content store" - outputStrLn " !import - Import definitions from file (definitions are stored)" - outputStrLn " !watch - Watch a file for changes (definitions are stored)" - outputStrLn " !refresh - (Currently no-op, definitions are live)" + outputStrLn " !import - Import definitions from file to the content store" + outputStrLn " !watch - Watch a file for changes, evaluate terms, and store them" outputStrLn " !versions - Show all versions of a term by name" outputStrLn " !select - Select a specific version of a term for subsequent lookups" - outputStrLn " !tag - Add or update a tag for a term (by hash or name)" + outputStrLn " !tag - Add or update a tag for a term by hash or name" loop state | strip s == "!output" -> handleOutput state | strip s == "!definitions" -> handleDefinitions state From 6780b242b1e28d4467b937811f8f5940872ccba3 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Mon, 26 May 2025 09:00:51 -0500 Subject: [PATCH 3/6] Use exact name matches in nameToTerm --- src/ContentStore.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ContentStore.hs b/src/ContentStore.hs index 70df48c..16696e8 100644 --- a/src/ContentStore.hs +++ b/src/ContentStore.hs @@ -127,7 +127,7 @@ hashToTerm conn hashText = nameToTerm :: Connection -> Text -> IO (Maybe StoredTerm) nameToTerm conn nameText = - queryMaybeOne conn (selectStoredTermFields <> " WHERE names LIKE ? ORDER BY created_at DESC LIMIT 1") (Only $ "%" <> nameText <> "%") + queryMaybeOne conn (selectStoredTermFields <> " WHERE names = ? ORDER BY created_at DESC LIMIT 1") (Only nameText) listStoredTerms :: Connection -> IO [StoredTerm] listStoredTerms conn = @@ -172,8 +172,8 @@ termVersions :: Connection -> String -> IO [(Text, T, Integer)] termVersions conn name = do let nameText = T.pack name results <- query conn - "SELECT hash, term_data, created_at FROM terms WHERE names LIKE ? ORDER BY created_at DESC" - (Only $ "%" <> nameText <> "%") + "SELECT hash, term_data, created_at FROM terms WHERE names = ? ORDER BY created_at DESC" + (Only nameText) catMaybes <$> mapM (\(hashVal, termDataVal, timestamp) -> do maybeT <- tryDeserializeTerm termDataVal From b96a3f2ef0ebe2e2b038cbd686627214aba98840 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Mon, 26 May 2025 17:40:06 -0500 Subject: [PATCH 4/6] Fixes list and name lookup bugs --- src/ContentStore.hs | 8 +++++--- src/Eval.hs | 19 ++++++++++++++----- src/Main.hs | 1 - 3 files changed, 19 insertions(+), 9 deletions(-) diff --git a/src/ContentStore.hs b/src/ContentStore.hs index 16696e8..7b15626 100644 --- a/src/ContentStore.hs +++ b/src/ContentStore.hs @@ -127,7 +127,9 @@ hashToTerm conn hashText = nameToTerm :: Connection -> Text -> IO (Maybe StoredTerm) nameToTerm conn nameText = - queryMaybeOne conn (selectStoredTermFields <> " WHERE names = ? ORDER BY created_at DESC LIMIT 1") (Only nameText) + queryMaybeOne conn + (selectStoredTermFields <> " WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC LIMIT 1") + (nameText, nameText <> T.pack ",%", T.pack "%," <> nameText <> T.pack ",%", T.pack "%," <> nameText) listStoredTerms :: Connection -> IO [StoredTerm] listStoredTerms conn = @@ -172,8 +174,8 @@ termVersions :: Connection -> String -> IO [(Text, T, Integer)] termVersions conn name = do let nameText = T.pack name results <- query conn - "SELECT hash, term_data, created_at FROM terms WHERE names = ? ORDER BY created_at DESC" - (Only nameText) + ("SELECT hash, term_data, created_at FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC") + (nameText, nameText <> T.pack ",%", T.pack "%," <> nameText <> T.pack ",%", T.pack "%," <> nameText) catMaybes <$> mapM (\(hashVal, termDataVal, timestamp) -> do maybeT <- tryDeserializeTerm termDataVal diff --git a/src/Eval.hs b/src/Eval.hs index 2a501b7..28ccf0f 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -137,6 +137,7 @@ elimLambda = go | lambdaList term = elimLambda $ lambdaListResult term | nestedLambda term = nestedLambdaResult term | application term = applicationResult term + | isSList term = slistTransform term | otherwise = term etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (isFree v f) @@ -157,18 +158,26 @@ elimLambda = go nestedLambda (SLambda (_:_) _) = True nestedLambda _ = False nestedLambdaResult (SLambda (v:vs) body) - | null vs = toSKI v (elimLambda body) - | otherwise = elimLambda (SLambda [v] (SLambda vs body)) + | null vs = toSKI v (go body) -- Changed elimLambda to go + | otherwise = go (SLambda [v] (SLambda vs body)) -- Changed elimLambda to go application (SApp _ _) = True application _ = False - applicationResult (SApp f g) = SApp (elimLambda f) (elimLambda g) + applicationResult (SApp f g) = SApp (go f) (go g) -- Changed elimLambda to go + + isSList (SList _) = True + isSList _ = False + + slistTransform :: TricuAST -> TricuAST + slistTransform (SList xs) = foldr (\m r -> SApp (SApp TLeaf (go m)) r) TLeaf xs + slistTransform ast = ast -- Should not be reached if isSList is the guard 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 x (SLambda [y] body) = toSKI x (toSKI y body) -- This should ideally not happen if lambdas are fully eliminated first + toSKI _ sl@(SList _) = SApp _K (go sl) -- Ensure SList itself is transformed if somehow passed to toSKI directly toSKI _ term = SApp _K term _S = parseSingle "t (t (t t t)) t" @@ -178,7 +187,7 @@ elimLambda = go _TRI = parseSingle "t (t (t t (t (t (t t t))))) t" 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) + composeBody f g x = SApp (SVar f Nothing) (SVar g Nothing) -- Note: This might not be the standard B combinator body f(g x) isFree :: String -> TricuAST -> Bool isFree x = Set.member x . freeVars diff --git a/src/Main.hs b/src/Main.hs index 5a43b33..f3d1d98 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -65,7 +65,6 @@ main = do Repl -> do putStrLn "Welcome to the tricu REPL" putStrLn "You may exit with `CTRL+D` or the `!exit` command." - putStrLn "Try typing `!` with tab completion for more commands." repl Evaluate { file = filePaths, form = form } -> do result <- case filePaths of From 72e5810ca97e05316f6ea81fda94a68faf21b603 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Thu, 29 May 2025 13:31:21 -0500 Subject: [PATCH 5/6] Update README to reflect completion of experiment --- README.md | 22 ++++++++-------------- tricu.cabal | 2 +- 2 files changed, 9 insertions(+), 15 deletions(-) diff --git a/README.md b/README.md index eeb4739..04ac7ce 100644 --- a/README.md +++ b/README.md @@ -2,12 +2,18 @@ ## Introduction -tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included to provide a useful programming tool. +tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included. -*tricu is under active development and you should expect breaking changes with every commit.* +*This experiment has concluded. tricu will see no further development or bugfixes.* tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`. +## Acknowledgements + +Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog). + +[treecalcul.us](https://treecalcul.us) is an excellent website with an intuitive Tree Calculus code playground created by [Johannes Bader](https://johannes-bader.com/) that introduced me to Tree Calculus. + ## Features - Tree Calculus **operator**: `t` @@ -105,15 +111,3 @@ tricu decode [OPTIONS] -f --file=FILE Optional input file path to attempt decoding. Defaults to stdin. ``` - -## Collaborating - -I am happy to accept issue reports, pull requests, or questions about tricu [via email](mailto:james@eversole.co). - -If you want to collaborate but don't want to email back-and-forth, please reach out via email once to let me know and I will provision a git.eversole.co account for you. - -## Acknowledgements - -Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog). - -[treecalcul.us](https://treecalcul.us) is an excellent website with an intuitive Tree Calculus code playground created by [Johannes Bader](https://johannes-bader.com/) that introduced me to Tree Calculus. diff --git a/tricu.cabal b/tricu.cabal index 5bfe9ff..992e9f8 100644 --- a/tricu.cabal +++ b/tricu.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: tricu -version: 0.20.0 +version: 1.0.0 description: A micro-language for exploring Tree Calculus author: James Eversole maintainer: james@eversole.co From 6b97b210ca2af2e13c60590856c475f10fdc98cc Mon Sep 17 00:00:00 2001 From: James Eversole Date: Tue, 5 May 2026 12:43:03 -0500 Subject: [PATCH 6/6] Full Merkle tree resolution --- README.md | 52 ++++--------------- src/ContentStore.hs | 122 +++++++++++++++++++++++++++----------------- src/Eval.hs | 8 +-- src/Research.hs | 96 +++++++++++++++++++++++++++++++++- tricu.cabal | 2 + 5 files changed, 182 insertions(+), 98 deletions(-) diff --git a/README.md b/README.md index 04ac7ce..696bc79 100644 --- a/README.md +++ b/README.md @@ -2,28 +2,13 @@ ## Introduction -tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included. - -*This experiment has concluded. tricu will see no further development or bugfixes.* +tricu (pronounced "tree-shoe") is a programming language experiment in Haskell. It is fundamentally based on the application of [Triage Calculus](https://olydis.medium.com/a-visual-introduction-to-tree-calculus-2f4a34ceffc2), an extended form of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf), terms, but minimal syntax sugar is included. tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`. ## Acknowledgements -Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog). - -[treecalcul.us](https://treecalcul.us) is an excellent website with an intuitive Tree Calculus code playground created by [Johannes Bader](https://johannes-bader.com/) that introduced me to Tree Calculus. - -## Features - -- Tree Calculus **operator**: `t` -- **Immutable definitions**: `x = t t` -- **Lambda abstraction**: `id = (a : a)` -- **List, Number, and String** literals: `[(2) ("Hello")]` -- **Function application**: `not (not false)` -- **Higher order/first-class functions**: `map (a : append a "!") [("Hello")]` -- **Intensionality** blurs the distinction between functions and data (see REPL examples) -- **Content-addressed store**: save, version, tag, and recall your tricu terms. +Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog). The addition of Triage rules were suggested by [Johannes Bader](https://johannes-bader.com/). Johannes is also the creator of [treecalcul.us](https://treecalcul.us) which has a great intuitive code playground using his language LambAda. ## REPL examples @@ -47,32 +32,17 @@ tricu < -- or calculate its size (/demos/size.tri) tricu < size not? tricu > 12 -tricu < !help -tricu version 0.20.0 -Available commands: - !exit - Exit the REPL - !clear - Clear the screen - !reset - Reset preferences for selected versions - !help - Show tricu version and available commands - !output - Change output format (tree|fsl|ast|ternary|ascii|decode) - !definitions - List all defined terms in the content store - !import - Import definitions from file (definitions are stored) - !watch - Watch a file for changes (definitions are stored) - !versions - Show all versions of a term by name - !select - Select a specific version of a term for subsequent lookups - !tag - Add or update a tag for a term by hash or name +tricu < -- REPL Commands: +tricu < !definitions -- Lists all available definitions +tricu < !output -- Change output format (Tree, FSL, AST, etc.) +tricu < !import -- Import definitions from a file +tricu < !exit -- Exit the REPL +tricu < !clear -- ANSI screen clear +tricu < !save -- Save all REPL definitions to a file that you can !import +tricu < !reset -- Clear all REPL definitions +tricu < !version -- Print tricu version ``` -## Content Store - -tricu uses a "content store" SQLite database that saves and versions your definitions persistently. - -* **Persistent definitions:** Any term you define in the REPL is automatically saved. -* **Content-addressed:** Terms are stored based on a SHA256 hash of their content. This means identical terms are stored only once, even if they have different names. -* **Versioning and history:** If you redefine a name, the Content Store keeps a record of previous definitions associated with that name. You can explore the history of a term and access older versions. -* **Tagging:** You can assign tags to versions of your terms to organize and quickly switch between related function versions. -* **Querying:** The store allows you to search for terms by name, hash, or tags. - ## Installation and Use You can easily build and run this project using [Nix](https://nixos.org/download/). diff --git a/src/ContentStore.hs b/src/ContentStore.hs index 7b15626..83ba82e 100644 --- a/src/ContentStore.hs +++ b/src/ContentStore.hs @@ -4,10 +4,9 @@ import Research import Parser import Control.Monad (foldM, forM) -import Crypto.Hash (hash, SHA256, Digest) import Data.ByteString (ByteString) -import Data.List (intercalate, nub, sortBy, sort) -import Data.Maybe (catMaybes) +import Data.List (nub, sort) +import Data.Maybe (catMaybes, fromJust) import Data.Text (Text) import Database.SQLite.Simple import Database.SQLite.Simple.FromRow (FromRow(..), field) @@ -15,30 +14,24 @@ import System.Directory (createDirectoryIfMissing, getXdgDirectory import System.FilePath ((), takeDirectory) import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map -import qualified Data.Serialize as Cereal import qualified Data.Text as T +data StoredNode = StoredNode ByteString deriving (Show) + +instance FromRow StoredNode where + fromRow = StoredNode <$> field + data StoredTerm = StoredTerm { termHash :: Text , termNames :: Text - , termData :: ByteString , termMetadata :: Text , termCreatedAt :: Integer , termTags :: Text } deriving (Show) instance FromRow StoredTerm where - fromRow = StoredTerm <$> field <*> field <*> field <*> field <*> field <*> field - -tryDeserializeTerm :: ByteString -> IO (Maybe T) -tryDeserializeTerm bs = - case deserializeTerm bs of - Right t -> return $ Just t - Left err -> do - putStrLn $ "Error deserializing term: " ++ err - return Nothing + fromRow = StoredTerm <$> field <*> field <*> field <*> field <*> field parseNameList :: Text -> [Text] parseNameList = filter (not . T.null) . T.splitOn "," @@ -60,6 +53,9 @@ initContentStore = do \tags TEXT DEFAULT '')" execute_ conn "CREATE INDEX IF NOT EXISTS terms_names_idx ON terms(names)" execute_ conn "CREATE INDEX IF NOT EXISTS terms_tags_idx ON terms(tags)" + execute_ conn "CREATE TABLE IF NOT EXISTS merkle_nodes (\ + \hash TEXT PRIMARY KEY, \ + \node_data BLOB NOT NULL)" return conn getContentStorePath :: IO FilePath @@ -67,40 +63,18 @@ getContentStorePath = do dataDir <- getXdgDirectory XdgData "tricu" return $ dataDir "content-store.db" -instance Cereal.Serialize T where - put Leaf = Cereal.putWord8 0 - put (Stem t) = do - Cereal.putWord8 1 - Cereal.put t - put (Fork a b) = do - Cereal.putWord8 2 - Cereal.put a - Cereal.put b - get = do - tag <- Cereal.getWord8 - case tag of - 0 -> return Leaf - 1 -> Stem <$> Cereal.get - 2 -> Fork <$> Cereal.get <*> Cereal.get - _ -> fail $ "Invalid tag for T: " ++ show tag - -serializeTerm :: T -> ByteString -serializeTerm = LBS.toStrict . Cereal.encodeLazy - -deserializeTerm :: ByteString -> Either String T -deserializeTerm = Cereal.decodeLazy . LBS.fromStrict hashTerm :: T -> Text -hashTerm = T.pack . show . (hash :: ByteString -> Digest SHA256) . serializeTerm +hashTerm = nodeHash . buildMerkle storeTerm :: Connection -> [String] -> T -> IO Text storeTerm conn newNamesStrList term = do - let termBS = serializeTerm term - termHashText = hashTerm term + let termHashText = hashTerm term newNamesTextList = map T.pack newNamesStrList metadataText = T.pack "{}" - + -- Store all Merkle nodes for this term + _ <- storeMerkleNodes conn term existingNamesQuery <- query conn "SELECT names FROM terms WHERE hash = ?" (Only termHashText) :: IO [Only Text] @@ -110,7 +84,7 @@ storeTerm conn newNamesStrList term = do let allNamesToStore = serializeNameList newNamesTextList execute conn "INSERT INTO terms (hash, names, term_data, metadata, tags) VALUES (?, ?, ?, ?, ?)" - (termHashText, allNamesToStore, termBS, metadataText, T.pack "") + (termHashText, allNamesToStore, BS.pack [], metadataText, T.pack "") [(Only currentNamesText)] -> do let currentNamesList = parseNameList currentNamesText let combinedNamesList = currentNamesList ++ newNamesTextList @@ -118,9 +92,61 @@ storeTerm conn newNamesStrList term = do execute conn "UPDATE terms SET names = ?, metadata = ? WHERE hash = ?" (allNamesToStore, metadataText, termHashText) + _ -> error $ "Multiple terms with same hash? " ++ show (length existingNamesQuery) return termHashText +-- | Reconstruct a Tree Calculus term from its Merkle root hash. +-- Recursively loads nodes and rebuilds the T structure. +loadTree conn h + | h == nodeHash NLeaf = return (Just Leaf) -- NLeaf is implicit, not stored + | otherwise = do + maybeNode <- getNodeMerkle conn h + case maybeNode of + Nothing -> return Nothing + Just node -> Just <$> buildTree node + where + buildTree :: Node -> IO T + buildTree (NStem childHash) = do + child <- fromJust <$> loadTree conn childHash + return (Stem child) + buildTree (NFork lHash rHash) = do + left <- fromJust <$> loadTree conn lHash + right <- fromJust <$> loadTree conn rHash + return (Fork left right) + +-- | Store all nodes of a Merkle DAG by traversing the Term and building/storing nodes. +-- Returns the hash of the root node. +storeMerkleNodes :: Connection -> T -> IO MerkleHash +storeMerkleNodes _ Leaf = return $ nodeHash NLeaf +storeMerkleNodes conn (Stem t) = do + childHash <- storeMerkleNodes conn t + let thisNode = NStem childHash + putMerkleNode conn thisNode + return $ nodeHash thisNode +storeMerkleNodes conn (Fork l r) = do + leftHash <- storeMerkleNodes conn l + rightHash <- storeMerkleNodes conn r + let thisNode = NFork leftHash rightHash + putMerkleNode conn thisNode + return $ nodeHash thisNode + + +-- | Insert a Merkle node into the store (idempotent). +putMerkleNode :: Connection -> Node -> IO () +putMerkleNode conn node = + execute conn "INSERT OR IGNORE INTO merkle_nodes (hash, node_data) VALUES (?, ?)" + (nodeHash node, serializeNode node) + +-- | Retrieve a Merkle node by its hash. +getNodeMerkle :: Connection -> MerkleHash -> IO (Maybe Node) +getNodeMerkle conn h = + queryMaybeOne conn "SELECT node_data FROM merkle_nodes WHERE hash = ?" (Only h) >>= \case + Just (StoredNode bs) -> return $ Just (deserializeNode bs) + Nothing -> return Nothing + + + hashToTerm :: Connection -> Text -> IO (Maybe StoredTerm) hashToTerm conn hashText = queryMaybeOne conn (selectStoredTermFields <> " WHERE hash = ?") (Only hashText) @@ -148,7 +174,7 @@ loadTerm :: Connection -> String -> IO (Maybe T) loadTerm conn identifier = do result <- getTerm conn (T.pack identifier) case result of - Just storedTerm -> tryDeserializeTerm (termData storedTerm) + Just storedTerm -> loadTree conn (termHash storedTerm) Nothing -> return Nothing getTerm :: Connection -> Text -> IO (Maybe StoredTerm) @@ -163,7 +189,7 @@ loadEnvironment conn = do foldM addTermToEnv Map.empty terms where addTermToEnv env storedTerm = do - maybeT <- tryDeserializeTerm (termData storedTerm) + maybeT <- loadTree conn (termHash storedTerm) case maybeT of Just t -> do let namesList = parseNameList (termNames storedTerm) @@ -174,11 +200,11 @@ termVersions :: Connection -> String -> IO [(Text, T, Integer)] termVersions conn name = do let nameText = T.pack name results <- query conn - ("SELECT hash, term_data, created_at FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC") + ("SELECT hash, created_at FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC") (nameText, nameText <> T.pack ",%", T.pack "%," <> nameText <> T.pack ",%", T.pack "%," <> nameText) - catMaybes <$> mapM (\(hashVal, termDataVal, timestamp) -> do - maybeT <- tryDeserializeTerm termDataVal + catMaybes <$> mapM (\(hashVal, timestamp) -> do + maybeT <- loadTree conn hashVal return $ fmap (\t -> (hashVal, t, timestamp)) maybeT ) results @@ -220,7 +246,7 @@ allTermTags conn = do query_ conn (selectStoredTermFields <> " WHERE tags IS NOT NULL AND tags != '' ORDER BY created_at DESC") selectStoredTermFields :: Query -selectStoredTermFields = "SELECT hash, names, term_data, metadata, created_at, tags FROM terms" +selectStoredTermFields = "SELECT hash, names, metadata, created_at, tags FROM terms" queryMaybeOne :: (FromRow r, ToRow q) => Connection -> Query -> q -> IO (Maybe r) queryMaybeOne conn qry params = do diff --git a/src/Eval.hs b/src/Eval.hs index 28ccf0f..fdfc8d7 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -113,13 +113,7 @@ resolveTermFromStore conn selectedVersions name mhash = case mhash of [(_, 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 + Just hash -> loadTree conn hash Nothing -> do versions <- termVersions conn name case versions of diff --git a/src/Research.hs b/src/Research.hs index 781208e..1a0b5ec 100644 --- a/src/Research.hs +++ b/src/Research.hs @@ -1,12 +1,17 @@ module Research where +import Data.ByteArray (convert) +import Data.Char (chr, ord) import Data.List (intercalate) import Data.Map (Map) -import Data.Text (Text, replace) +import Data.Text (Text, replace, unpack) +import Data.Word (Word8) import System.Console.CmdArgs (Data, Typeable) +import qualified Data.ByteString as BS import qualified Data.Map as Map -import qualified Data.Text as T +import qualified Data.Text as T +import Crypto.Hash (hash, SHA256, Digest) -- Tree Calculus Types data T = Leaf | Stem T | Fork T T @@ -54,6 +59,93 @@ data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode -- Environment containing previously evaluated TC terms type Env = Map.Map String T +-- Merkle DAG Node types +-- Each Tree Calculus node becomes a content-addressed object. + +type MerkleHash = Text + +data Node + = NLeaf + | NStem MerkleHash + | NFork MerkleHash MerkleHash + deriving (Show, Eq, Ord) + +-- | Canonical serialization of a Node for hashing. +-- Leaf: 0x00 +-- Stem: 0x01 || child_hash (32 bytes) +-- Fork: 0x02 || left_hash (32 bytes) || right_hash (32 bytes) +serializeNode :: Node -> BS.ByteString +serializeNode NLeaf = BS.pack [0x00] +serializeNode (NStem h) = BS.pack [0x01] <> hexToBytes h +serializeNode (NFork l r) = BS.pack [0x02] <> hexToBytes l <> hexToBytes r + +-- | Hash a node per the Merkle content-addressing spec. +-- hash = SHA256( "tricu.merkle.node.v1" <> 0x00 <> node_payload ) +nodeHash :: Node -> MerkleHash +nodeHash node = bytesToHex (sha256WithPrefix (serializeNode node)) + where sha256WithPrefix payload = + convert . (hash :: BS.ByteString -> Digest SHA256) $ utf8Tag <> BS.pack [0x00] <> payload + utf8Tag = BS.pack $ map fromIntegral $ BS.unpack "tricu.merkle.node.v1" + +-- | Convert a Hex Text hash into raw ByteString (2 hex chars per byte) +hexToBytes :: Text -> BS.ByteString +hexToBytes h = BS.pack $ map combinePair pairs + where + chars = unpack h + pairs = chunkPairs chars + chunkPairs :: String -> [(Char, Char)] + chunkPairs (c1:c2:rest) = (c1, c2) : chunkPairs rest + chunkPairs [] = [] + chunkPairs _ = error "hexToBytes: odd number of hex digits" + combinePair :: (Char, Char) -> Word8 + combinePair (c1, c2) = fromIntegral (hexDigitToInt c1 * 16 + hexDigitToInt c2) + hexDigitToInt :: Char -> Int + hexDigitToInt c + | '0' <= c && c <= '9' = ord c - ord '0' + | 'a' <= c && c <= 'f' = ord c - ord 'a' + 10 + | 'A' <= c && c <= 'F' = ord c - ord 'A' + 10 + | otherwise = error $ "Invalid hex digit: " ++ show c + +-- | Deserialize a Node from canonical bytes. +deserializeNode :: BS.ByteString -> Node +deserializeNode bs = + case BS.uncons bs of + Just (0x00, rest) + | BS.null rest -> NLeaf + + Just (0x01, rest) + | BS.length rest == 32 -> + NStem $ bytesToHex rest + + Just (0x02, rest) + | BS.length rest == 64 -> + let (l, r) = BS.splitAt 32 rest + in NFork (bytesToHex l) (bytesToHex r) + + _ -> error "invalid merkle node payload" + + +-- | Convert 32-byte ByteString back to hex Text +bytesToHex :: BS.ByteString -> Text +bytesToHex bs = T.pack $ concatMap byteToHexChars $ BS.unpack bs + where + byteToHexChars :: Word8 -> String + byteToHexChars w = [hexDigit (fromIntegral w `div` 16), hexDigit (fromIntegral w `mod` 16)] + hexDigit :: Int -> Char + hexDigit n + | n < 10 = chr (ord '0' + n) + | otherwise = chr (ord 'a' + n - 10) + +-- | Build a Merkle DAG from a Tree Calculus term. +buildMerkle :: T -> Node +buildMerkle Leaf = NLeaf +buildMerkle (Stem t) = NStem (nodeHash child) + where child = buildMerkle t +buildMerkle (Fork l r) = NFork (nodeHash left) (nodeHash right) + where + left = buildMerkle l + right = buildMerkle r + -- Tree Calculus Reduction Rules {- The t operator is left associative. diff --git a/tricu.cabal b/tricu.cabal index 992e9f8..20fc8a7 100644 --- a/tricu.cabal +++ b/tricu.cabal @@ -39,6 +39,7 @@ executable tricu , fsnotify , haskeline , megaparsec + , memory , mtl , sqlite-simple , tasty @@ -82,6 +83,7 @@ test-suite tricu-tests , fsnotify , haskeline , megaparsec + , memory , mtl , sqlite-simple , tasty