commit d55ac43d6531a8a550e69c21124b122d3048622a
parent 98b1abb9dcea63c03263842ffce259ae7bfd2abd
Author: James Eversole <james@eversole.co>
Date: Thu, 22 May 2025 16:13:57 -0500
Merge content store
Diffstat:
13 files changed, 1002 insertions(+), 220 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -6,6 +6,7 @@
/Dockerfile
/config.dhall
/result
+.aider*
WD
bin/
dist*
diff --git a/README.md b/README.md
@@ -43,6 +43,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
@@ -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
@@ -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
@@ -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"
-
- -- Combinators and special forms
+ 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
+
_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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
-
- 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 < " ("", "")
-
- text <- MaybeT $ liftIO $ handle (\e -> do
- putStrLn $ "Error reading file: " ++ displayException (e :: IOException)
- return Nothing
- ) $ Just <$> readFile (strip path)
-
- 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) < " ("", "")
-
- 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 { replForm = newForm }
+
+ 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:"
+
+ let maxNameWidth = maximum $ map (length . T.unpack . termNames) terms
+
+ 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
+
+ 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
-
- 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
-
- 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
-
- errorHandler :: Env -> SomeException -> IO (Env)
- errorHandler env e = do
- putStrLn $ "Error: " ++ show e
- return env
+ 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
+
+ handleWatch :: REPLState -> InputT IO ()
+ handleWatch state = do
+ dbPath <- liftIO ContentStore.getContentStorePath
+ let filepath = takeDirectory dbPath </> "scratch.tri"
+ let dirPath = takeDirectory filepath
+
+ liftIO $ createDirectoryIfMissing True dirPath
+
+ 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
-
- 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
-
- loop env form
+ processWatchedFile :: FilePath -> Maybe Connection -> Map.Map String T.Text -> EvaluatedForm -> IO ()
+ processWatchedFile filepath mconn selectedVersions outputForm = do
+ content <- readFile filepath
+ let asts = parseTricu content
+
+ 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
+
+ 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
@@ -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
@@ -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
@@ -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
