304 lines
12 KiB
Haskell
304 lines
12 KiB
Haskell
module REPL where
|
|
|
|
import Check (checkFileWithStore)
|
|
import Eval (evalTricu, result)
|
|
import FileEval
|
|
( ContractMode(..)
|
|
, LoadedSource(..)
|
|
, defaultStorePath
|
|
, loadFileWithStoreMode
|
|
)
|
|
import Parser (parseTricu)
|
|
import Research (EvaluatedForm(..), Env, formatT)
|
|
import ContentStore
|
|
( AliasKind(..)
|
|
, ObjectRef(..)
|
|
, StorePath(..)
|
|
, cachedFilesystemResolver
|
|
, getTreeTerm
|
|
, readAlias
|
|
, treeTermDomain
|
|
, unDomain
|
|
)
|
|
import Module.Resolver (resolveModuleImport, resolvedModulesEnv)
|
|
|
|
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 Paths_tricu (version)
|
|
import System.Console.Haskeline
|
|
import System.Directory (doesFileExist)
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Text 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
|
|
, replEnv :: Env
|
|
, replStore :: StorePath
|
|
, replContracts :: ContractMode
|
|
, replEnvRef :: IORef Env
|
|
}
|
|
|
|
repl :: IO ()
|
|
repl = defaultStorePath >>= replWithStore
|
|
|
|
replWithStore :: StorePath -> IO ()
|
|
replWithStore store = do
|
|
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
|
|
|
|
loop :: REPLState -> InputT IO ()
|
|
loop state = do
|
|
minput <- getInputLine "tricu < "
|
|
case minput of
|
|
Nothing -> return ()
|
|
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)
|
|
| "!use" `isPrefixOf` s -> handleUse state (strip $ drop 4 s)
|
|
| "!name" `isPrefixOf` s -> handleName state (strip $ drop 5 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 " !use MODULE [NS] - Load a module alias/manifest from the store (NS defaults to !Local)"
|
|
outputStrLn " !name NAME [LOCAL] - Load a name alias/tree-term hash from the store"
|
|
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 = outputFormats
|
|
outputStrLn "Available output formats:"
|
|
mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f)
|
|
(zip [1..] formats)
|
|
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
|
|
|
|
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
|
|
|
|
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 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
|
|
|
|
handleUse :: REPLState -> String -> InputT IO ()
|
|
handleUse state arg = case words arg of
|
|
[] -> outputStrLn "Usage: !use MODULE [NAMESPACE]" >> loop state
|
|
[moduleTarget] -> loadModule moduleTarget "!Local"
|
|
[moduleTarget, namespace] -> loadModule moduleTarget namespace
|
|
_ -> outputStrLn "Usage: !use MODULE [NAMESPACE]" >> loop state
|
|
where
|
|
loadModule moduleTarget namespace = do
|
|
resolver <- liftIO $ cachedFilesystemResolver (replStore state)
|
|
resolved <- liftIO $ resolveModuleImport resolver moduleTarget namespace
|
|
let importedEnv = resolvedModulesEnv [resolved]
|
|
env' = Map.union importedEnv (replEnv state)
|
|
liftIO $ writeIORef (replEnvRef state) env'
|
|
outputStrLn $ "Loaded " ++ show (Map.size importedEnv) ++ " export(s) from store module " ++ moduleTarget
|
|
loop state { replEnv = env' }
|
|
|
|
handleName :: REPLState -> String -> InputT IO ()
|
|
handleName state arg = case words arg of
|
|
[] -> outputStrLn "Usage: !name NAME [LOCAL]" >> loop state
|
|
[name] -> loadName name name
|
|
[name, localName] -> loadName name localName
|
|
_ -> outputStrLn "Usage: !name NAME [LOCAL]" >> loop state
|
|
where
|
|
loadName name localName = do
|
|
let store = replStore state
|
|
nameText = T.pack name
|
|
mAlias <- liftIO $ readAlias store NameAlias nameText
|
|
let root = maybe nameText objectRefHash mAlias
|
|
badKind = case mAlias of
|
|
Just ref -> objectRefKind ref /= unDomain treeTermDomain
|
|
Nothing -> False
|
|
if badKind
|
|
then outputStrLn ("Name alias does not point at a tree term: " ++ name) >> loop state
|
|
else do
|
|
mTerm <- liftIO $ getTreeTerm store root
|
|
case mTerm of
|
|
Nothing -> outputStrLn ("Tree term not found in store: " ++ name) >> loop state
|
|
Just term -> do
|
|
let env' = Map.insert localName term (replEnv state)
|
|
liftIO $ writeIORef (replEnvRef state) env'
|
|
outputStrLn $ "Loaded " ++ name ++ " as " ++ localName
|
|
loop state { replEnv = env' }
|
|
|
|
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 }
|
|
|
|
handleUnchecked :: REPLState -> String -> InputT IO ()
|
|
handleUnchecked state arg = setUnchecked state arg
|
|
|
|
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 }
|
|
|
|
reportContracts :: REPLState -> InputT IO ()
|
|
reportContracts state = outputStrLn $ contractModeMessage (replContracts 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 env' = evalTricu (replEnv state) (parseTricu input)
|
|
writeIORef (replEnvRef state) env'
|
|
putStrLn $ formatT (replForm state) (result env')
|
|
return state { replEnv = env' }
|
|
|
|
errorHandler :: REPLState -> SomeException -> IO REPLState
|
|
errorHandler state e = do
|
|
putStrLn $ "Error: " ++ displayException e
|
|
return state
|
|
|
|
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"
|
|
, "!use"
|
|
, "!name"
|
|
, "!check"
|
|
, "!store"
|
|
, "!unchecked"
|
|
, "!env"
|
|
]
|
|
commandWantsFile inputLine = any (`isPrefixOf` inputLine) ["!load ", "!check "]
|
|
termBreakChars = " \t\n\r()[]{}\"'"
|
|
|
|
outputFormats :: [EvaluatedForm]
|
|
outputFormats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit]
|
|
|
|
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
|
|
|
|
contractModeMessage :: ContractMode -> String
|
|
contractModeMessage EnforceContracts = "Contracts: on"
|
|
contractModeMessage IgnoreContracts = "Contracts: off (unchecked eval)"
|
|
|
|
storePathString :: StorePath -> FilePath
|
|
storePathString (StorePath path) = path
|
|
|
|
strip :: String -> String
|
|
strip = f . f
|
|
where f = reverse . dropWhile (`elem` [' ', '\t', '\n', '\r'])
|
|
|
|
readMaybeInt :: String -> Maybe Int
|
|
readMaybeInt s = case reads s of
|
|
[(n, "")] -> Just n
|
|
_ -> Nothing
|