Tricu 2.0.0
Sorry for squashing all of this but 🤷
This commit is contained in:
816
src/REPL.hs
816
src/REPL.hs
@@ -1,675 +1,241 @@
|
||||
module REPL where
|
||||
|
||||
import ContentStore
|
||||
import Eval
|
||||
import Check (checkFileWithStore)
|
||||
import Eval (evalTricu, result)
|
||||
import FileEval
|
||||
import Lexer ()
|
||||
import Parser
|
||||
import Research
|
||||
import Wire (buildBundle, encodeBundle, importBundle)
|
||||
( ContractMode(..)
|
||||
, LoadedSource(..)
|
||||
, defaultStorePath
|
||||
, loadFileWithStoreMode
|
||||
)
|
||||
import Parser (parseTricu)
|
||||
import Research (EvaluatedForm(..), Env, formatT)
|
||||
import ContentStore (StorePath(..))
|
||||
|
||||
import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
|
||||
import Control.Exception (SomeException, catch, displayException)
|
||||
import Control.Monad ()
|
||||
import Control.Monad (forever, when, forM_, foldM, unless)
|
||||
import Control.Monad.Catch (handle)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Class ()
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
||||
import Data.ByteString ()
|
||||
import Data.Char (isSpace)
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.IORef (newIORef, readIORef, writeIORef)
|
||||
import Data.List (dropWhileEnd, isPrefixOf, find)
|
||||
import Data.Maybe (isJust, fromJust)
|
||||
import Data.Time (getCurrentTime, diffUTCTime)
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
||||
import Data.Time.Format (formatTime, defaultTimeLocale)
|
||||
import Control.Exception (SomeException, catch, displayException)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import Data.List (isPrefixOf, sort)
|
||||
import Data.Version (showVersion)
|
||||
import Database.SQLite.Simple (Connection, Only(..), query)
|
||||
import Paths_tricu (version)
|
||||
import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..), Color(..))
|
||||
import System.Console.Haskeline
|
||||
import System.Directory (doesFileExist, createDirectoryIfMissing)
|
||||
import System.FSNotify
|
||||
import System.FilePath (takeDirectory, (</>))
|
||||
import Text.Read (readMaybe)
|
||||
import System.Directory (doesFileExist)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T ()
|
||||
|
||||
-- | Source-local REPL with the same filesystem CAS/module loader used by the
|
||||
-- CLI. View Contract checking is explicit (`!check`); evaluation can run in
|
||||
-- normal publishing mode or unchecked mode.
|
||||
data REPLState = REPLState
|
||||
{ replForm :: EvaluatedForm
|
||||
, replContentStore :: Maybe Connection
|
||||
, replWatchedFile :: Maybe FilePath
|
||||
, replSelectedVersions :: Map.Map String T.Text
|
||||
, replWatcherThread :: Maybe ThreadId
|
||||
{ replForm :: EvaluatedForm
|
||||
, replEnv :: Env
|
||||
, replStore :: StorePath
|
||||
, replContracts :: ContractMode
|
||||
, replEnvRef :: IORef Env
|
||||
}
|
||||
|
||||
repl :: IO ()
|
||||
repl = do
|
||||
conn <- ContentStore.initContentStore
|
||||
runInputT settings (withInterrupt (loop (REPLState Decode (Just conn) Nothing Map.empty Nothing)))
|
||||
store <- defaultStorePath
|
||||
envRef <- newIORef Map.empty
|
||||
let settings = Settings
|
||||
{ complete = completeRepl envRef
|
||||
, historyFile = Just "~/.local/state/tricu/history"
|
||||
, autoAddHistory = True
|
||||
}
|
||||
runInputT settings (loop (REPLState Decode Map.empty store EnforceContracts envRef))
|
||||
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"
|
||||
, "!reset"
|
||||
, "!help"
|
||||
, "!definitions"
|
||||
, "!watch"
|
||||
, "!refresh"
|
||||
, "!versions"
|
||||
, "!select"
|
||||
, "!tag"
|
||||
, "!export"
|
||||
, "!bundleimport"
|
||||
]
|
||||
|
||||
loop :: REPLState -> InputT IO ()
|
||||
loop state = handle (\Interrupt -> interruptHandler state Interrupt) $ do
|
||||
loop state = 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 preferences for selected versions"
|
||||
outputStrLn " !help - Show tricu version and available commands"
|
||||
outputStrLn " !output - Change output format (tree|fsl|ast|ternary|ascii|decode)"
|
||||
outputStrLn " !definitions - List all defined terms in the content store"
|
||||
outputStrLn " !import - Import definitions from file to the content store"
|
||||
outputStrLn " !watch - Watch a file for changes, evaluate terms, and store them"
|
||||
outputStrLn " !versions - Show all versions of a term by name"
|
||||
outputStrLn " !select - Select a specific version of a term for subsequent lookups"
|
||||
outputStrLn " !tag - Add or update a tag for a term by hash or name"
|
||||
outputStrLn " !export - Export a term bundle to file (hash, file)"
|
||||
outputStrLn " !bundleimport- Import a bundle file into the content store"
|
||||
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
|
||||
| "!export" `isPrefixOf` strip s -> handleExport state
|
||||
| "!bundleimport" `isPrefixOf` strip s -> handleBundleImport state
|
||||
| take 2 s == "--" -> loop state
|
||||
| otherwise -> do
|
||||
evalResult <- liftIO $ catch
|
||||
(processInput state s)
|
||||
(errorHandler state)
|
||||
loop evalResult
|
||||
Just raw -> do
|
||||
let s = strip raw
|
||||
case s of
|
||||
"" -> loop state
|
||||
"!exit" -> outputStrLn "Exiting tricu"
|
||||
"!clear" -> liftIO (putStr "\ESC[2J\ESC[H") >> loop state
|
||||
"!reset" -> do
|
||||
liftIO $ writeIORef (replEnvRef state) Map.empty
|
||||
outputStrLn "Environment reset"
|
||||
loop state { replEnv = Map.empty }
|
||||
"!help" -> printHelp >> loop state
|
||||
"!output" -> handleOutput state
|
||||
"!env" -> handleEnv state >> loop state
|
||||
_ | "!load" `isPrefixOf` s -> handleLoad state (strip $ drop 5 s)
|
||||
| "!check" `isPrefixOf` s -> handleCheck state (strip $ drop 6 s)
|
||||
| "!store" `isPrefixOf` s -> handleStore state (strip $ drop 6 s)
|
||||
| "!format" `isPrefixOf` s -> handleFormat state (strip $ drop 7 s)
|
||||
| "!unchecked" `isPrefixOf` s -> handleUnchecked state (strip $ drop 10 s)
|
||||
| take 2 s == "--" -> loop state
|
||||
| otherwise -> do
|
||||
next <- liftIO $ catch (processInput state raw) (errorHandler state)
|
||||
loop next
|
||||
|
||||
printHelp :: InputT IO ()
|
||||
printHelp = do
|
||||
outputStrLn $ "tricu version " ++ showVersion version
|
||||
outputStrLn "Available commands:"
|
||||
outputStrLn " !exit - Exit the REPL"
|
||||
outputStrLn " !clear - Clear the screen"
|
||||
outputStrLn " !reset - Reset the in-memory environment"
|
||||
outputStrLn " !help - Show this help"
|
||||
outputStrLn " !output - Change output format interactively"
|
||||
outputStrLn " !format FORM - Set output format: tree, fsl, ast, ternary, ascii, decode, number, string"
|
||||
outputStrLn " !load FILE - Load and evaluate a .tri file into the environment"
|
||||
outputStrLn " !check FILE - Check View Contract annotations in a .tri file"
|
||||
outputStrLn " !store [PATH] - Show or set the content-addressed store path"
|
||||
outputStrLn " !unchecked [on|off] - Show or set unchecked eval mode"
|
||||
outputStrLn " !env - List names currently in the REPL environment"
|
||||
|
||||
handleOutput :: REPLState -> InputT IO ()
|
||||
handleOutput state = do
|
||||
let formats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit]
|
||||
let formats = outputFormats
|
||||
outputStrLn "Available output formats:"
|
||||
mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f)
|
||||
(zip [1..] formats)
|
||||
|
||||
evalResult <- runMaybeT $ do
|
||||
input <- MaybeT $ getInputLine "Select output format (1-8) < "
|
||||
case reads input of
|
||||
[(n, "")] | n >= 1 && n <= 8 ->
|
||||
return $ formats !! (n-1)
|
||||
_ -> MaybeT $ return Nothing
|
||||
|
||||
case evalResult of
|
||||
Nothing -> do
|
||||
outputStrLn "Invalid selection. Keeping current output format."
|
||||
loop state
|
||||
Just newForm -> do
|
||||
input <- getInputLine "Select output format (1-8) < "
|
||||
case input >>= readMaybeInt of
|
||||
Just n | n >= 1 && n <= length formats -> do
|
||||
let newForm = formats !! (n - 1)
|
||||
outputStrLn $ "Output format changed to: " ++ show newForm
|
||||
loop state { replForm = newForm }
|
||||
_ -> outputStrLn "Invalid selection. Keeping current output format." >> loop state
|
||||
|
||||
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:"
|
||||
handleFormat :: REPLState -> String -> InputT IO ()
|
||||
handleFormat state arg =
|
||||
case readEvaluatedForm arg of
|
||||
Just form -> outputStrLn ("Output format changed to: " ++ show form) >> loop state { replForm = form }
|
||||
Nothing -> outputStrLn "Usage: !format tree|fsl|ast|ternary|ascii|decode|number|string" >> loop state
|
||||
|
||||
let maxNameWidth = maximum $ map (length . T.unpack . termNames) terms
|
||||
|
||||
forM_ terms $ \term -> do
|
||||
let namesStr = T.unpack (termNames term)
|
||||
hash = termHash term
|
||||
padding = replicate (maxNameWidth - length namesStr) ' '
|
||||
|
||||
liftIO $ do
|
||||
putStr " "
|
||||
printVariable namesStr
|
||||
putStr padding
|
||||
putStr " [hash: "
|
||||
displayColoredHash hash
|
||||
putStrLn "]"
|
||||
|
||||
tags <- ContentStore.termToTags conn hash
|
||||
unless (null tags) $ displayTags tags
|
||||
|
||||
loop state
|
||||
|
||||
handleImport :: REPLState -> InputT IO ()
|
||||
handleImport state = do
|
||||
let fset = setComplete completeFilename defaultSettings
|
||||
filename <- runInputT fset $ getInputLineWithInitial "File to import: " ("", "")
|
||||
case filename of
|
||||
Nothing -> loop state
|
||||
Just f -> do
|
||||
let cleanFilename = strip f
|
||||
exists <- liftIO $ doesFileExist cleanFilename
|
||||
handleLoad :: REPLState -> String -> InputT IO ()
|
||||
handleLoad state path
|
||||
| null path = outputStrLn "Usage: !load FILE" >> loop state
|
||||
| otherwise = do
|
||||
exists <- liftIO $ doesFileExist path
|
||||
if not exists
|
||||
then do
|
||||
liftIO $ printError $ "File not found: " ++ cleanFilename
|
||||
then outputStrLn ("File not found: " ++ path) >> loop state
|
||||
else do
|
||||
loaded <- liftIO $ loadFileWithStoreMode (replContracts state) (replStore state) path
|
||||
let env' = evalTricu (Map.union (loadedImports loaded) (replEnv state)) (loadedAst loaded)
|
||||
liftIO $ writeIORef (replEnvRef state) env'
|
||||
outputStrLn $ "Loaded " ++ path
|
||||
loop state { replEnv = env' }
|
||||
|
||||
handleCheck :: REPLState -> String -> InputT IO ()
|
||||
handleCheck state path
|
||||
| null path = outputStrLn "Usage: !check FILE" >> loop state
|
||||
| otherwise = do
|
||||
exists <- liftIO $ doesFileExist path
|
||||
if not exists
|
||||
then outputStrLn ("File not found: " ++ path) >> loop state
|
||||
else do
|
||||
output <- liftIO $ checkFileWithStore (replStore state) path
|
||||
outputStrLn output
|
||||
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
|
||||
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 :: Int))
|
||||
) 0 defs
|
||||
|
||||
printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully"
|
||||
|
||||
handleStore :: REPLState -> String -> InputT IO ()
|
||||
handleStore state path
|
||||
| null path = do
|
||||
outputStrLn $ "Store: " ++ storePathString (replStore state)
|
||||
loop state
|
||||
| otherwise = do
|
||||
outputStrLn $ "Store changed to: " ++ path
|
||||
loop state { replStore = StorePath path }
|
||||
|
||||
handleWatch :: REPLState -> InputT IO ()
|
||||
handleWatch state = do
|
||||
dbPath <- liftIO ContentStore.getContentStorePath
|
||||
let filepath = takeDirectory dbPath </> "scratch.tri"
|
||||
let dirPath = takeDirectory filepath
|
||||
handleUnchecked :: REPLState -> String -> InputT IO ()
|
||||
handleUnchecked state arg = setUnchecked state arg
|
||||
|
||||
liftIO $ createDirectoryIfMissing True dirPath
|
||||
setUnchecked :: REPLState -> String -> InputT IO ()
|
||||
setUnchecked state arg = case arg of
|
||||
"" -> reportContracts state >> loop state
|
||||
"on" -> setMode IgnoreContracts
|
||||
"off" -> setMode EnforceContracts
|
||||
_ -> outputStrLn "Usage: !unchecked [on|off]" >> loop state
|
||||
where
|
||||
setMode mode = do
|
||||
outputStrLn $ contractModeMessage mode
|
||||
loop state { replContracts = mode }
|
||||
|
||||
fileExists <- liftIO $ doesFileExist filepath
|
||||
unless fileExists $ liftIO $ writeFile filepath "-- tricu scratch file\n\n"
|
||||
reportContracts :: REPLState -> InputT IO ()
|
||||
reportContracts state = outputStrLn $ contractModeMessage (replContracts state)
|
||||
|
||||
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 (\ev -> eventPath ev == filepath) $ \_ -> 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
|
||||
|
||||
handleExport :: REPLState -> InputT IO ()
|
||||
handleExport state = do
|
||||
let fset = setComplete completeFilename defaultSettings
|
||||
hashInput <- runInputT fset $ getInputLineWithInitial "Hash or name: " ("", "")
|
||||
case hashInput of
|
||||
Nothing -> loop state
|
||||
Just hashStr -> do
|
||||
fileInput <- runInputT fset $ getInputLineWithInitial "Output file: " ("", "")
|
||||
case fileInput of
|
||||
Nothing -> loop state
|
||||
Just outFile -> case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
let cleanHash = strip hashStr
|
||||
hash <- liftIO $ do
|
||||
let h = T.pack cleanHash
|
||||
if '#' `T.elem` h
|
||||
then return h
|
||||
else do
|
||||
results <- query conn "SELECT hash FROM terms WHERE names LIKE ? LIMIT 1"
|
||||
(Only (h <> "%")) :: IO [Only T.Text]
|
||||
case results of
|
||||
[Only fullHash] -> return fullHash
|
||||
[] -> do
|
||||
results2 <- query conn "SELECT hash FROM terms WHERE hash LIKE ? LIMIT 1"
|
||||
(Only (h <> "%")) :: IO [Only T.Text]
|
||||
case results2 of
|
||||
[Only fullHash] -> return fullHash
|
||||
_ -> do
|
||||
printError $ "No term found matching: " ++ cleanHash
|
||||
return h
|
||||
_ -> do
|
||||
printError $ "Ambiguous match for: " ++ cleanHash
|
||||
return h
|
||||
maybeTree <- liftIO $ loadTree conn hash
|
||||
case maybeTree of
|
||||
Nothing -> do
|
||||
liftIO $ printError $ "Term not found in store: " ++ T.unpack hash
|
||||
loop state
|
||||
Just tree -> do
|
||||
let bundle = buildBundle [(T.pack "root", tree)]
|
||||
bundleData = encodeBundle bundle
|
||||
liftIO $ BL.writeFile outFile (BL.fromStrict bundleData)
|
||||
liftIO $ do
|
||||
printSuccess $ "Exported bundle with root "
|
||||
displayColoredHash hash
|
||||
putStrLn $ " to " ++ outFile
|
||||
loop state
|
||||
|
||||
handleBundleImport :: REPLState -> InputT IO ()
|
||||
handleBundleImport state = do
|
||||
let fset = setComplete completeFilename defaultSettings
|
||||
fileInput <- runInputT fset $ getInputLineWithInitial "Bundle file: " ("", "")
|
||||
case fileInput of
|
||||
Nothing -> loop state
|
||||
Just inFile -> case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
exists <- liftIO $ doesFileExist inFile
|
||||
if not exists
|
||||
then do
|
||||
liftIO $ printError $ "File not found: " ++ inFile
|
||||
loop state
|
||||
else do
|
||||
bundleData <- liftIO $ BL.readFile inFile
|
||||
roots <- liftIO $ importBundle conn (BL.toStrict bundleData)
|
||||
liftIO $ do
|
||||
printSuccess $ "Imported " ++ show (length roots) ++ " root(s):"
|
||||
mapM_ (\r -> putStrLn $ " " ++ T.unpack r) roots
|
||||
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
|
||||
|
||||
errorHandler :: REPLState -> SomeException -> IO REPLState
|
||||
errorHandler state e = do
|
||||
printError $ "Error: " ++ displayException e
|
||||
return state
|
||||
handleEnv :: REPLState -> InputT IO ()
|
||||
handleEnv state =
|
||||
case sort (Map.keys (replEnv state)) of
|
||||
[] -> outputStrLn "Environment is empty"
|
||||
names -> mapM_ outputStrLn names
|
||||
|
||||
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
|
||||
let env' = evalTricu (replEnv state) (parseTricu input)
|
||||
writeIORef (replEnvRef state) env'
|
||||
putStrLn $ formatT (replForm state) (result env')
|
||||
return state { replEnv = env' }
|
||||
|
||||
forM_ asts $ \ast -> do
|
||||
case ast of
|
||||
SDef name [] body -> do
|
||||
evalResult <- evalAST (Just conn) (replSelectedVersions newState) body
|
||||
hash <- ContentStore.storeTerm conn [name] evalResult
|
||||
|
||||
liftIO $ do
|
||||
putStr "tricu > "
|
||||
printSuccess "Stored definition: "
|
||||
printVariable name
|
||||
putStr " with hash "
|
||||
displayColoredHash hash
|
||||
putStrLn ""
|
||||
|
||||
putStr "tricu > "
|
||||
printResult $ formatT (replForm newState) evalResult
|
||||
putStrLn ""
|
||||
errorHandler :: REPLState -> SomeException -> IO REPLState
|
||||
errorHandler state e = do
|
||||
putStrLn $ "Error: " ++ displayException e
|
||||
return state
|
||||
|
||||
_ -> do
|
||||
evalResult <- evalAST (Just conn) (replSelectedVersions newState) ast
|
||||
liftIO $ do
|
||||
putStr "tricu > "
|
||||
printResult $ formatT (replForm newState) evalResult
|
||||
putStrLn ""
|
||||
return newState
|
||||
completeRepl :: IORef Env -> CompletionFunc IO
|
||||
completeRepl envRef input@(left, _right)
|
||||
| commandWantsFile line = completeFilename input
|
||||
| "!" `isPrefixOf` line = completeWord Nothing " \t" completeCommands input
|
||||
| otherwise = completeWord Nothing termBreakChars completeTerms input
|
||||
where
|
||||
line = reverse left
|
||||
completeCommands str = return $ map simpleCompletion $
|
||||
filter (str `isPrefixOf`) commands
|
||||
completeTerms str = do
|
||||
env <- readIORef envRef
|
||||
return $ map simpleCompletion $
|
||||
filter (str `isPrefixOf`) (sort $ Map.keys env)
|
||||
commands =
|
||||
[ "!exit"
|
||||
, "!output"
|
||||
, "!format"
|
||||
, "!clear"
|
||||
, "!reset"
|
||||
, "!help"
|
||||
, "!load"
|
||||
, "!check"
|
||||
, "!store"
|
||||
, "!unchecked"
|
||||
, "!env"
|
||||
]
|
||||
commandWantsFile inputLine = any (`isPrefixOf` inputLine) ["!load ", "!check "]
|
||||
termBreakChars = " \t\n\r()[]{}\"'"
|
||||
|
||||
strip :: String -> String
|
||||
strip = dropWhileEnd isSpace . dropWhile isSpace
|
||||
outputFormats :: [EvaluatedForm]
|
||||
outputFormats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit]
|
||||
|
||||
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
|
||||
readEvaluatedForm :: String -> Maybe EvaluatedForm
|
||||
readEvaluatedForm s = case s of
|
||||
"tree" -> Just Tree
|
||||
"fsl" -> Just FSL
|
||||
"ast" -> Just AST
|
||||
"ternary" -> Just Ternary
|
||||
"ascii" -> Just Ascii
|
||||
"decode" -> Just Decode
|
||||
"number" -> Just Number
|
||||
"string" -> Just StringLit
|
||||
_ -> Nothing
|
||||
|
||||
processWatchedFile :: FilePath -> Maybe Connection -> Map.Map String T.Text -> EvaluatedForm -> IO ()
|
||||
processWatchedFile filepath mconn selectedVersions outputForm = do
|
||||
content <- readFile filepath
|
||||
let asts = parseTricu content
|
||||
contractModeMessage :: ContractMode -> String
|
||||
contractModeMessage EnforceContracts = "Contracts: on"
|
||||
contractModeMessage IgnoreContracts = "Contracts: off (unchecked eval)"
|
||||
|
||||
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
|
||||
evalResult <- evalAST (Just conn) selectedVersions body
|
||||
hash <- ContentStore.storeTerm conn [name] evalResult
|
||||
putStrLn $ "tricu > Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
||||
putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm evalResult
|
||||
_ -> do
|
||||
evalResult <- evalAST (Just conn) selectedVersions ast
|
||||
putStrLn $ "tricu > Result: " ++ formatT outputForm evalResult
|
||||
putStrLn $ "tricu > Processed file: " ++ filepath
|
||||
storePathString :: StorePath -> FilePath
|
||||
storePathString (StorePath path) = path
|
||||
|
||||
formatTimestamp :: Integer -> String
|
||||
formatTimestamp ts = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" (posixSecondsToUTCTime (fromIntegral ts))
|
||||
strip :: String -> String
|
||||
strip = f . f
|
||||
where f = reverse . dropWhile (`elem` [' ', '\t', '\n', '\r'])
|
||||
|
||||
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]
|
||||
|
||||
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 ""
|
||||
readMaybeInt :: String -> Maybe Int
|
||||
readMaybeInt s = case reads s of
|
||||
[(n, "")] -> Just n
|
||||
_ -> Nothing
|
||||
|
||||
Reference in New Issue
Block a user