Merge content store
This commit is contained in:
625
src/REPL.hs
625
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 ""
|
||||
|
||||
Reference in New Issue
Block a user