785 lines
31 KiB
Haskell
785 lines
31 KiB
Haskell
module REPL where
|
|
|
|
import Eval
|
|
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)
|
|
import Control.Monad (forM_)
|
|
import Control.Monad.Catch (handle, MonadCatch)
|
|
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, nub, sortBy, groupBy, intercalate)
|
|
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
|
|
|
|
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 <- initContentStore
|
|
runInputT settings (withInterrupt (loop (REPLState Decode (Just conn) Nothing Map.empty Nothing)))
|
|
where
|
|
settings :: Settings IO
|
|
settings = Settings
|
|
{ complete = completeWord Nothing " \t" completeCommands
|
|
, historyFile = Just "~/.local/state/tricu/history"
|
|
, autoAddHistory = True
|
|
}
|
|
|
|
completeCommands :: String -> IO [Completion]
|
|
completeCommands str = return $ map simpleCompletion $
|
|
filter (str `isPrefixOf`) commands
|
|
where
|
|
commands = [ "!exit"
|
|
, "!output"
|
|
, "!import"
|
|
, "!clear"
|
|
, "!save"
|
|
, "!reset"
|
|
, "!help"
|
|
, "!definitions"
|
|
, "!watch"
|
|
, "!unwatch"
|
|
, "!refresh"
|
|
, "!versions"
|
|
, "!select"
|
|
, "!tag"
|
|
]
|
|
|
|
loop :: REPLState -> InputT IO ()
|
|
loop state = handle (\Interrupt -> interruptHandler state Interrupt) $ do
|
|
minput <- getInputLine "tricu < "
|
|
case minput of
|
|
Nothing -> return ()
|
|
Just s
|
|
| strip s == "" -> loop state
|
|
| strip s == "!exit" -> outputStrLn "Exiting tricu"
|
|
| strip s == "!clear" -> do
|
|
liftIO $ putStr "\ESC[2J\ESC[H"
|
|
loop state
|
|
| strip s == "!reset" -> do
|
|
outputStrLn "Selected versions reset"
|
|
loop state { replSelectedVersions = Map.empty }
|
|
| strip s == "!help" -> do
|
|
outputStrLn $ "tricu version " ++ showVersion version
|
|
outputStrLn "Available commands:"
|
|
outputStrLn " !exit - Exit the REPL"
|
|
outputStrLn " !clear - Clear the screen"
|
|
outputStrLn " !reset - Reset selected versions"
|
|
outputStrLn " !help - Show tricu version and available commands"
|
|
outputStrLn " !output - Change output format (tree|fsl|ast|ternary|ascii|decode)"
|
|
outputStrLn " !definitions - List all defined terms in the content store"
|
|
outputStrLn " !import - Import definitions from file"
|
|
outputStrLn " !watch - Watch a file for changes"
|
|
outputStrLn " !unwatch - Stop watching file"
|
|
outputStrLn " !refresh - Refresh from content store"
|
|
outputStrLn " !versions - Show all versions of a term"
|
|
outputStrLn " !select - Select a specific version of a term"
|
|
outputStrLn " !tag - Add or update a tag for a term"
|
|
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 == "!unwatch" -> handleUnwatch 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
|
|
-- Process the input with error handling
|
|
result <- liftIO $ catch
|
|
(processInput state s)
|
|
(errorHandler state)
|
|
loop result
|
|
|
|
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)
|
|
(zip [1..] formats)
|
|
|
|
result <- runMaybeT $ do
|
|
input <- MaybeT $ getInputLine "Select output format (1-6) < "
|
|
case reads input of
|
|
[(n, "")] | n >= 1 && n <= 6 ->
|
|
return $ formats !! (n-1)
|
|
_ -> MaybeT $ return Nothing
|
|
|
|
case result of
|
|
Nothing -> do
|
|
outputStrLn "Invalid selection. Keeping current output format."
|
|
loop state
|
|
Just newForm -> do
|
|
outputStrLn $ "Output format changed to: " ++ show newForm
|
|
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 $ 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:"
|
|
|
|
-- Calculate the maximum width of names
|
|
let maxNameWidth = maximum $ map (length . intercalate ", " . map T.unpack . T.splitOn "," . termNames) terms
|
|
|
|
-- Process each term and display its names
|
|
forM_ terms $ \term -> do
|
|
let namesList = T.splitOn "," (termNames term)
|
|
hash = termHash term
|
|
namesStr = intercalate ", " (map T.unpack namesList)
|
|
padding = replicate (maxNameWidth - length namesStr) ' '
|
|
|
|
liftIO $ do
|
|
putStr " "
|
|
printVariable namesStr
|
|
putStr padding
|
|
putStr " [hash: "
|
|
displayColoredHash hash
|
|
putStrLn "]"
|
|
|
|
-- Show tags if any
|
|
tags <- getTagsForTerm 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
|
|
liftIO $ printError "Content store not initialized"
|
|
loop state
|
|
Just conn -> do
|
|
-- Parse the entire file content at once
|
|
let asts = parseTricu code
|
|
|
|
-- First, evaluate the file using the standard evaluation pipeline
|
|
-- This will handle dependencies correctly
|
|
env <- liftIO $ evaluateFile cleanFilename
|
|
|
|
-- Now store all the definitions from the environment
|
|
liftIO $ do
|
|
printSuccess $ "Importing file: " ++ cleanFilename
|
|
|
|
-- Get all definitions from the environment (excluding result)
|
|
let defs = Map.toList $ Map.delete "!result" env
|
|
|
|
-- Store each definition
|
|
importedCount <- foldM (\count (name, term) -> do
|
|
-- Check if this tree form already exists with other names
|
|
let hashValue = hashTerm term
|
|
existingTerm <- getTermByHash conn hashValue
|
|
|
|
-- Determine the names to store
|
|
namesList <- case existingTerm of
|
|
Just existingTerm -> do
|
|
let existingNames = T.splitOn "," (termNames existingTerm)
|
|
if T.pack name `elem` existingNames
|
|
then return $ map T.unpack existingNames -- Name already exists
|
|
else return $ map T.unpack existingNames ++ [name] -- Add new name
|
|
Nothing -> return [name] -- New term
|
|
|
|
-- Store with all names
|
|
hash <- storeTerm conn namesList term
|
|
|
|
printSuccess $ "Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
|
|
|
return (count + 1)
|
|
) 0 defs
|
|
|
|
printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully"
|
|
|
|
loop state
|
|
|
|
processAST :: Connection -> REPLState -> TricuAST -> IO REPLState
|
|
processAST conn state ast = do
|
|
case ast of
|
|
SDef name [] body -> do
|
|
-- Evaluate the body using the existing evaluation pipeline
|
|
result <- evalAST (Just conn) (replSelectedVersions state) body
|
|
|
|
-- Check if this tree form already exists with other names
|
|
let hashValue = hashTerm result
|
|
existingTerm <- getTermByHash conn hashValue
|
|
|
|
-- Determine the names to store
|
|
names <- case existingTerm of
|
|
Just term -> do
|
|
let existingNames = T.splitOn "," (termNames term)
|
|
if T.pack name `elem` existingNames
|
|
then return $ T.unpack (termNames term) -- Name already exists
|
|
else return $ T.unpack (termNames term) ++ "," ++ name -- Add new name
|
|
Nothing -> return name -- New term
|
|
|
|
-- Store with all names
|
|
hash <- storeTerm conn [names] result
|
|
|
|
putStr "tricu > "
|
|
printSuccess "Stored definition: "
|
|
printVariable name
|
|
putStr " with hash "
|
|
displayColoredHash hash
|
|
putStrLn ""
|
|
|
|
return state
|
|
_ -> return state
|
|
|
|
handleWatch :: REPLState -> InputT IO ()
|
|
handleWatch state = do
|
|
-- Get the default scratch file path
|
|
dbPath <- liftIO $ getContentStorePath
|
|
let filepath = takeDirectory dbPath </> "scratch.tri"
|
|
let dirPath = takeDirectory filepath
|
|
|
|
-- Ensure the directory exists
|
|
liftIO $ createDirectoryIfMissing True dirPath
|
|
|
|
-- Create the file if it doesn't exist
|
|
fileExists <- liftIO $ doesFileExist filepath
|
|
unless fileExists $ liftIO $ do
|
|
-- Create a simple template file
|
|
writeFile filepath "-- tricu scratch file\n\n"
|
|
|
|
outputStrLn $ "Using scratch file: " ++ filepath
|
|
|
|
-- Stop any existing watcher
|
|
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"
|
|
|
|
-- First, process the file immediately
|
|
liftIO $ processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state)
|
|
|
|
-- Create a reference time for debouncing
|
|
lastProcessedRef <- liftIO $ newIORef =<< getCurrentTime
|
|
|
|
-- Start a new file watcher in a separate thread
|
|
watcherId <- liftIO $ forkIO $ withManager $ \mgr -> do
|
|
-- Watch for changes in the file
|
|
stopAction <- watchDir mgr dirPath (\event -> eventPath event == filepath) $ \event -> do
|
|
-- Implement debouncing to prevent multiple rapid triggers
|
|
now <- getCurrentTime
|
|
lastProcessed <- readIORef lastProcessedRef
|
|
|
|
-- Only process if at least 500ms have passed since last processing
|
|
when (diffUTCTime now lastProcessed > 0.5) $ do
|
|
putStrLn $ "\nFile changed: " ++ filepath
|
|
processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state)
|
|
writeIORef lastProcessedRef now
|
|
|
|
-- Keep the watcher alive
|
|
forever $ threadDelay 1000000
|
|
|
|
-- Enter a blocking loop that can be interrupted with Ctrl+C
|
|
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
|
|
-- Kill the watcher thread if it exists
|
|
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"
|
|
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: "
|
|
name <- getInputLine ""
|
|
case name of
|
|
Nothing -> loop state
|
|
Just n -> do
|
|
versions <- liftIO $ getTermVersions conn (strip n)
|
|
if null versions
|
|
then liftIO $ printError $ "No versions found for term: " ++ n
|
|
else do
|
|
liftIO $ do
|
|
printKeyword "Versions of "
|
|
printVariable (strip n)
|
|
putStrLn ":"
|
|
|
|
forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do
|
|
-- Get tags for this version
|
|
tags <- getTagsForTerm conn hash
|
|
|
|
-- Display version number
|
|
putStr $ show (i :: Int) ++ ". "
|
|
|
|
-- Display hash with color
|
|
displayColoredHash hash
|
|
|
|
-- Display timestamp
|
|
putStr $ " (" ++ formatTimestamp ts ++ ")"
|
|
|
|
-- Display tags if any
|
|
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: "
|
|
name <- getInputLine ""
|
|
case name of
|
|
Nothing -> loop state
|
|
Just n -> do
|
|
let cleanName = strip n
|
|
versions <- liftIO $ getTermVersions 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
|
|
-- Get tags for this version
|
|
tags <- getTagsForTerm conn hash
|
|
|
|
-- Display version number
|
|
putStr $ show (i :: Int) ++ ". "
|
|
|
|
-- Display hash with color
|
|
displayColoredHash hash
|
|
|
|
-- Display timestamp
|
|
putStr $ " (" ++ formatTimestamp ts ++ ")"
|
|
|
|
-- Display tags if any
|
|
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 (or press Enter to cancel): "
|
|
choice <- getInputLine ""
|
|
case choice >>= readMaybe of
|
|
Just idx | idx > 0 && idx <= length versions -> do
|
|
let (hash, _, _) = versions !! (idx - 1)
|
|
let newState = state { replSelectedVersions =
|
|
Map.insert cleanName hash (replSelectedVersions state) }
|
|
|
|
liftIO $ do
|
|
printSuccess "Selected version "
|
|
displayColoredHash hash
|
|
putStr " for term "
|
|
printVariable cleanName
|
|
putStrLn ""
|
|
|
|
loop newState
|
|
_ -> 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
|
|
-- Get the hash
|
|
liftIO $ printPrompt "Term hash (or name): "
|
|
hash <- getInputLine ""
|
|
case hash of
|
|
Nothing -> loop state
|
|
Just h -> do
|
|
let hashText = T.pack (strip h)
|
|
|
|
-- If input is a name, try to get the most recent version's hash
|
|
finalHash <- if T.any (== '#') hashText
|
|
then return hashText
|
|
else do
|
|
versions <- liftIO $ getTermVersions conn (strip h)
|
|
if null versions
|
|
then do
|
|
liftIO $ printError $ "No versions found for term: " ++ h
|
|
return hashText
|
|
else do
|
|
let (mostRecentHash, _, _) = head versions
|
|
return mostRecentHash
|
|
|
|
-- Show existing tags
|
|
tags <- liftIO $ getTagsForTerm conn finalHash
|
|
unless (null tags) $ do
|
|
liftIO $ do
|
|
printKeyword "Existing tags:"
|
|
displayTags tags
|
|
|
|
-- Get the tag value
|
|
liftIO $ printPrompt "Tag: "
|
|
tagValue <- getInputLine ""
|
|
case tagValue of
|
|
Nothing -> loop state
|
|
Just tv -> do
|
|
-- Set the tag
|
|
liftIO $ do
|
|
setTag conn finalHash (T.pack (strip tv))
|
|
printSuccess $ "Tag set to '"
|
|
printTag (strip tv)
|
|
putStr "' for term with hash "
|
|
displayColoredHash (T.take 8 finalHash)
|
|
putStrLn ""
|
|
loop state
|
|
|
|
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
|
|
|
|
-- Simple error handler that returns the original state
|
|
errorHandler :: REPLState -> SomeException -> IO REPLState
|
|
errorHandler state e = do
|
|
printError $ "Error: " ++ displayException e
|
|
return state
|
|
|
|
-- Process input and return the new 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
|
|
-- First, check for any variables that have multiple versions and auto-select the most recent
|
|
newState <- foldM (\s ast -> do
|
|
let varNames = findVarNames ast
|
|
foldM (\s' name -> do
|
|
-- Skip if already selected
|
|
if Map.member name (replSelectedVersions s')
|
|
then return s'
|
|
else do
|
|
versions <- getTermVersions conn name
|
|
if length versions > 1
|
|
then do
|
|
let (hash, _, _) = head versions -- Most recent version
|
|
printWarning $ "Multiple versions of '" ++ name ++ "' found:"
|
|
|
|
forM_ (zip [1..] versions) $ \(i, (h, _, ts)) -> do
|
|
putStr $ show (i :: Int) ++ ". "
|
|
displayColoredHash (T.take 8 h)
|
|
putStrLn $ " (" ++ formatTimestamp ts ++ ")"
|
|
|
|
printWarning "Please `!select` a version"
|
|
printWarning $ "For now, using the most recent version of '" ++ name ++ "'"
|
|
|
|
-- Auto-select the most recent version
|
|
return s' { replSelectedVersions = Map.insert name hash (replSelectedVersions s') }
|
|
else return s'
|
|
) s varNames
|
|
) state asts
|
|
|
|
-- Process each AST node
|
|
forM_ asts $ \ast -> do
|
|
case ast of
|
|
SDef name [] body -> do
|
|
-- Store the definition in the database
|
|
result <- evalAST (Just conn) (replSelectedVersions newState) body
|
|
hash <- storeTerm conn [name] result
|
|
|
|
putStr "tricu > "
|
|
printSuccess "Stored definition: "
|
|
printVariable name
|
|
putStr " with hash "
|
|
displayColoredHash hash
|
|
putStrLn ""
|
|
|
|
putStr "tricu > "
|
|
printResult $ formatT (replForm newState) result
|
|
putStrLn ""
|
|
|
|
_ -> do
|
|
-- Evaluate the expression
|
|
result <- evalAST (Just conn) (replSelectedVersions newState) ast
|
|
putStr "tricu > "
|
|
printResult $ formatT (replForm newState) result
|
|
putStrLn ""
|
|
|
|
return newState
|
|
|
|
strip :: String -> String
|
|
strip = dropWhileEnd isSpace . dropWhile isSpace
|
|
|
|
-- Add a new watchLoop function that handles watching mode
|
|
watchLoop :: REPLState -> InputT IO ()
|
|
watchLoop state = handle (\Interrupt -> do
|
|
outputStrLn "\nStopped watching file"
|
|
-- Kill the watcher thread when interrupted
|
|
when (isJust (replWatcherThread state)) $ do
|
|
liftIO $ killThread (fromJust $ replWatcherThread state)
|
|
loop state { replWatchedFile = Nothing, replWatcherThread = Nothing }) $ do
|
|
-- This is a blocking loop that does nothing but wait for Ctrl+C
|
|
liftIO $ threadDelay 1000000
|
|
watchLoop state
|
|
|
|
-- Add a helper function to process a watched file
|
|
processWatchedFile :: FilePath -> Maybe Connection -> Map.Map String T.Text -> EvaluatedForm -> IO ()
|
|
processWatchedFile filepath mconn selectedVersions outputForm = do
|
|
content <- readFile filepath
|
|
let asts = parseTricu content
|
|
|
|
-- Process each AST node
|
|
forM_ asts $ \ast -> case ast of
|
|
SDef name [] body -> do
|
|
-- Evaluate the body using the database
|
|
result <- evalAST mconn selectedVersions body
|
|
|
|
-- Store the result in the database
|
|
case mconn of
|
|
Just conn -> do
|
|
hash <- storeTerm conn [name] result
|
|
putStrLn $ "tricu > Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
|
Nothing -> putStrLn "Content store not initialized"
|
|
|
|
-- Display the result
|
|
putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm result
|
|
|
|
_ -> do
|
|
-- Evaluate the expression using the database
|
|
result <- evalAST mconn selectedVersions ast
|
|
putStrLn $ "tricu > Result: " ++ formatT outputForm result
|
|
|
|
putStrLn $ "tricu > Processed file: " ++ filepath
|
|
|
|
-- Helper function to find all variable names in an 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)
|
|
_ -> []
|
|
|
|
-- Add this helper function to format timestamps
|
|
formatTimestamp :: Integer -> String
|
|
formatTimestamp ts = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" (posixSecondsToUTCTime (fromIntegral ts))
|
|
|
|
-- Helper function to display a hash with the first 8 chars highlighted
|
|
displayColoredHash :: T.Text -> IO ()
|
|
displayColoredHash hash = do
|
|
let (prefix, rest) = T.splitAt 8 hash
|
|
|
|
-- Set color to bright cyan for the first 8 chars
|
|
setSGR [SetColor Foreground Vivid Cyan]
|
|
putStr $ T.unpack prefix
|
|
|
|
-- Reset to normal color for the rest
|
|
setSGR [SetColor Foreground Dull White]
|
|
putStr $ T.unpack rest
|
|
|
|
-- Reset all attributes
|
|
setSGR [Reset]
|
|
|
|
-- Helper function to display a hash with the first 8 chars highlighted in a string
|
|
coloredHashString :: T.Text -> String
|
|
coloredHashString hash =
|
|
"\ESC[1;36m" ++ T.unpack (T.take 8 hash) ++
|
|
"\ESC[0;37m" ++ T.unpack (T.drop 8 hash) ++
|
|
"\ESC[0m"
|
|
|
|
-- Color helper functions
|
|
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
|
|
|
|
-- Specialized color functions for different elements
|
|
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
|
|
|
|
-- Helper function to display tags with color
|
|
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 ""
|
|
|
|
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
|
|
|
|
storeTerm :: Connection -> [String] -> T -> IO T.Text
|
|
storeTerm conn names term = do
|
|
let termBS = serializeTerm term
|
|
termHashText = hashTerm term
|
|
namesText = T.pack $ intercalate "," names
|
|
metadataText = T.pack "{}"
|
|
tagsText = T.pack ""
|
|
|
|
existing <- query conn
|
|
"SELECT hash FROM terms WHERE hash = ?"
|
|
(Only termHashText) :: IO [Only T.Text]
|
|
|
|
case existing of
|
|
[] -> execute conn
|
|
"INSERT INTO terms (hash, names, term_data, metadata, tags) VALUES (?, ?, ?, ?, ?)"
|
|
(termHashText, namesText, termBS, metadataText, tagsText)
|
|
_ -> execute conn
|
|
"UPDATE terms SET names = ?, metadata = ? WHERE hash = ?"
|
|
(namesText, metadataText, termHashText)
|
|
|
|
return termHashText
|
|
|
|
getTermByName :: Connection -> T.Text -> IO (Maybe StoredTerm)
|
|
getTermByName conn nameText = do
|
|
results <- query conn
|
|
"SELECT hash, names, term_data, metadata, created_at, tags FROM terms WHERE names LIKE ? ORDER BY created_at DESC LIMIT 1"
|
|
(Only $ "%" <> nameText <> "%")
|
|
case results of
|
|
[term] -> return $ Just term
|
|
_ -> return Nothing
|
|
|
|
listStoredTerms :: Connection -> IO [StoredTerm]
|
|
listStoredTerms conn = do
|
|
query_ conn "SELECT hash, names, term_data, metadata, created_at, tags FROM terms ORDER BY created_at DESC"
|