James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Some REPL niceties

Browse Source
This commit is contained in:
James Eversole
2026-06-22 17:26:21 -05:00
parent a4fcc1cb36
commit c6c1ef1fe1
3 changed files with 184 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files

118
src/Main.hs
View File

@@ -17,11 +17,13 @@ import FileEval
)
import IODriver (IOPermissions(..), runIO)
import Parser (parseTricu)
import REPL (repl)
import REPL (repl, replWithStore)
import Research (T, EvaluatedForm(..), Env, formatT, exportDag)
import Wire (encodeBundle, defaultExportNames, Bundle(..))
import Control.Monad (foldM, unless, when)
import Control.Monad (foldM, forM, unless, when)
import Data.Char (isAlphaNum)
import Data.List (sortOn)
import qualified Data.Text as T
import Data.Version (showVersion)
import Paths_tricu (version)
@@ -31,13 +33,18 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Sequence as Seq
import qualified Data.Map as Map
import System.Directory (getHomeDirectory)
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
import System.FilePath (takeBaseName, (</>))
-- ---------------------------------------------------------------------------
-- CLI argument types
-- ---------------------------------------------------------------------------
data AppArgs = AppArgs
{ globalStore :: Maybe FilePath
, appCommand :: TricuArgs
} deriving (Show)
data TricuArgs
= Repl
| Check
@@ -74,6 +81,8 @@ data TricuArgs
, exportOutput :: FilePath
, exportNames :: [String]
, exportStore :: Maybe FilePath
, exportAll :: Bool
, exportSplit :: Bool
, dag :: Bool
}
| StoreAliasList
@@ -251,6 +260,14 @@ exportParser = ArboricxExport
<> metavar "PATH"
<> help "Content-addressed store path"
))
<*> switch
( long "all"
<> help "Export all name aliases that point at tree-term objects"
)
<*> switch
( long "split"
<> help "Write one single-export bundle per export; --output is treated as a directory"
)
<*> switch
( long "dag"
<> help "Export as a topologically-sorted DAG node table instead of a bundle"
@@ -297,9 +314,15 @@ storeAliasGetParser = StoreAliasGet
versionStr :: String
versionStr = "tricu " ++ showVersion version
tricuParser :: Parser TricuArgs
tricuParser = (subparser topCommands <|> pure Repl)
<**> infoOption versionStr (long "version" <> help "Show version")
tricuParser :: Parser AppArgs
tricuParser = AppArgs
<$> optional (option str
( long "store"
<> metavar "PATH"
<> help "Global content-addressed store path used by commands and the REPL unless a subcommand overrides it"
))
<*> ((subparser topCommands <|> pure Repl)
<**> infoOption versionStr (long "version" <> help "Show version"))
where
topCommands = mconcat
[ command "check" (info (checkParser <**> helper)
@@ -342,13 +365,15 @@ storeAliasParser = subparser $ mconcat
main :: IO ()
main = do
args <- execParser $ info (tricuParser <**> helper)
appArgs <- execParser $ info (tricuParser <**> helper)
( fullDesc
<> progDesc "Exploring Tree Calculus"
<> header versionStr
)
let mGlobalStore = globalStore appArgs
args = applyGlobalStore mGlobalStore (appCommand appArgs)
case args of
Repl -> runRepl
Repl -> runReplWithStore mGlobalStore
Check {} -> runCheck args
Eval {} -> runEval args
ArboricxCompile {} -> runCompile args
@@ -362,11 +387,31 @@ main = do
-- Command runners
-- ---------------------------------------------------------------------------
applyGlobalStore :: Maybe FilePath -> TricuArgs -> TricuArgs
applyGlobalStore mGlobal args = case args of
Repl -> Repl
Check {} -> args { checkStore = preferLocal (checkStore args) }
Eval {} -> args { evalStore = preferLocal (evalStore args) }
ArboricxCompile {} -> args { compileStore = preferLocal (compileStore args) }
ArboricxImport {} -> args { importStore = preferLocal (importStore args) }
ArboricxExport {} -> args { exportStore = preferLocal (exportStore args) }
StoreAliasList {} -> args { storePathOpt = preferLocal (storePathOpt args) }
StoreAliasGet {} -> args { storePathOpt = preferLocal (storePathOpt args) }
where
preferLocal local = case local of
Just _ -> local
Nothing -> mGlobal
runRepl :: IO ()
runRepl = do
runRepl = runReplWithStore Nothing
runReplWithStore :: Maybe FilePath -> IO ()
runReplWithStore mStore = do
putStrLn "Welcome to the tricu REPL"
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
repl
case mStore of
Nothing -> repl
Just store -> replWithStore (StorePath store)
runCheck :: TricuArgs -> IO ()
runCheck opts = do
@@ -466,17 +511,27 @@ runExportBundle opts = do
modules = exportModules opts
out = exportOutput opts
names = exportNames opts
allFlag = exportAll opts
splitFlag = exportSplit opts
when (null out) $ die "tricu arboricx export: --output is required"
when (null targets && null modules) $
die "tricu arboricx export: at least one --target or --module is required"
when (null targets && null modules && not allFlag) $
die "tricu arboricx export: at least one --target, --module, or --all is required"
when (splitFlag && not (null names)) $
die "tricu arboricx export --split: --name is not supported; split bundles use their export names"
store <- resolveStorePath (exportStore opts)
allEntries <- if allFlag then resolveAllNameExports store else pure []
targetRoots <- mapM (resolveStoreTarget store) targets
moduleRoots <- concat <$> mapM (resolveModuleExports store) modules
let targetEntries = zip (defaultExportNames (length targetRoots)) targetRoots
entries = targetEntries ++ moduleRoots
entries = allEntries ++ targetEntries ++ moduleRoots
expNames = if null names then map fst entries else map T.pack names
when (null entries) $
die "tricu arboricx export: no tree-term exports found"
when (length expNames /= length entries) $
die "tricu arboricx export: number of --name values must match number of exported roots"
if splitFlag
then runExportBundleSplit store out (zip expNames (map snd entries))
else do
bundle <- packBundleFromStore store (zip expNames (map snd entries))
let bundleData = encodeBundle bundle
BL.writeFile out (BL.fromStrict bundleData)
@@ -484,6 +539,19 @@ runExportBundle opts = do
putStrLn $ " nodes: " ++ show (Seq.length (bundleNodes bundle))
putStrLn $ " size: " ++ show (BS.length bundleData) ++ " bytes"
runExportBundleSplit :: StorePath -> FilePath -> [(T.Text, ObjectHash)] -> IO ()
runExportBundleSplit store outDir entries = do
createDirectoryIfMissing True outDir
written <- forM (zip [0 :: Int ..] entries) $ \(i, (name, root)) -> do
bundle <- packBundleFromStore store [(name, root)]
let bundleData = encodeBundle bundle
path = outDir </> splitBundleFileName i name
BL.writeFile path (BL.fromStrict bundleData)
pure (path, Seq.length (bundleNodes bundle), BS.length bundleData)
putStrLn $ "Exported " ++ show (length written) ++ " split bundle(s) to " ++ outDir
mapM_ (\(path, nodeCount, byteCount) ->
putStrLn $ " " ++ path ++ " (nodes: " ++ show nodeCount ++ ", size: " ++ show byteCount ++ " bytes)") written
runStoreAliasList :: TricuArgs -> IO ()
runStoreAliasList opts = do
store <- resolveStorePath (storePathOpt opts)
@@ -543,6 +611,19 @@ resolveStoreTarget store target = do
Just _ -> return root
Nothing -> die $ "Term not found in store: " ++ target
resolveAllNameExports :: StorePath -> IO [(T.Text, ObjectHash)]
resolveAllNameExports store = do
aliases <- sortOn fst <$> listAliases store NameAlias
fmap concat $ mapM exportAlias aliases
where
exportAlias (name, ref)
| objectRefKind ref /= unDomain treeTermDomain = pure []
| otherwise = do
mTree <- getTreeTerm store (objectRefHash ref)
case mTree of
Nothing -> die $ "Name alias tree term not found: " ++ T.unpack name
Just _ -> pure [(name, objectRefHash ref)]
resolveModuleExports :: StorePath -> String -> IO [(T.Text, ObjectHash)]
resolveModuleExports store moduleTarget = do
manifestHash <- resolveModuleManifestHash store moduleTarget
@@ -574,6 +655,17 @@ resolveModuleManifestHash store moduleTarget = do
formatObjectRef :: ObjectRef -> String
formatObjectRef ref = T.unpack (objectRefKind ref) ++ " " ++ T.unpack (objectRefHash ref)
splitBundleFileName :: Int -> T.Text -> FilePath
splitBundleFileName i name = show i ++ "-" ++ sanitize (T.unpack name) ++ ".arboricx"
where
sanitize [] = "export"
sanitize xs = case map safeChar xs of
[] -> "export"
ys -> ys
safeChar c
| isAlphaNum c || c == '-' || c == '_' || c == '.' = c
| otherwise = '_'
writeOutput :: FilePath -> String -> IO ()
writeOutput path content
| null path = putStr content

68
src/REPL.hs
View File

@@ -10,7 +10,17 @@ import FileEval
)
import Parser (parseTricu)
import Research (EvaluatedForm(..), Env, formatT)
import ContentStore (StorePath(..))
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)
@@ -22,6 +32,7 @@ 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
@@ -35,8 +46,10 @@ data REPLState = REPLState
}
repl :: IO ()
repl = do
store <- defaultStorePath
repl = defaultStorePath >>= replWithStore
replWithStore :: StorePath -> IO ()
replWithStore store = do
envRef <- newIORef Map.empty
let settings = Settings
{ complete = completeRepl envRef
@@ -66,6 +79,8 @@ repl = do
"!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)
@@ -85,6 +100,8 @@ repl = do
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"
@@ -136,6 +153,49 @@ repl = do
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
@@ -201,6 +261,8 @@ completeRepl envRef input@(left, _right)
, "!reset"
, "!help"
, "!load"
, "!use"
, "!name"
, "!check"
, "!store"
, "!unchecked"

16
test/Spec.hs
View File

@@ -77,13 +77,13 @@ allTestLibsEnv = unsafePerformIO $ do
tests :: TestTree
tests = testGroup "Tricu Tests"
[ lexer
--, parser
--, simpleEvaluation
--, lambdas
--, providedLibraries
--, maybeTests
--, fileEval
--, demos
, parser
, simpleEvaluation
, lambdas
, providedLibraries
, maybeTests
, fileEval
, demos
--, decoding
--, elimLambdaSingle
--, stressElimLambda
@@ -94,7 +94,7 @@ tests = testGroup "Tricu Tests"
--, binaryParserTests
--, httpParsingTests
--, contentStoreTests
, viewContractTests
--, viewContractTests
--, ioDriverTests
]