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