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

feat(haskell): CLI rewrite

Browse Source
This commit is contained in:
James Eversole
2026-05-11 15:29:12 -05:00
parent ea748b2e5e
commit e0b1e95729
8 changed files with 441 additions and 330 deletions
Download Patch File Download Diff File Expand all files Collapse all files

588
src/Main.hs
View File

@@ -1,280 +1,374 @@
module Main where
import ContentStore (initContentStore, loadEnvironment, loadTerm, resolveExportTarget)
import ContentStore (initContentStoreWithPath, loadEnvironment, loadTerm, resolveExportTarget)
import System.Exit (die)
import Server (runServer)
import Eval (evalTricu, mainResult, result)
import FileEval
import Parser (parseTricu)
import REPL
import Research
import Wire
import Server (runServerWithPath)
import Eval (evalTricu, evalTricuWithStore, mainResult, result)
import FileEval (evaluateFileWithContext, evaluateFileWithStore, compileFile)
import Parser (parseTricu)
import REPL (repl)
import Research (T, EvaluatedForm(..), Env, formatT, exportDag)
import Wire (exportNamedBundle, defaultExportNames, importBundle)
import Control.Monad (foldM)
import Data.Text (Text, unpack)
import qualified Data.Text as T
import Data.Version (showVersion)
import Paths_tricu (version)
import System.Console.CmdArgs
import System.Environment (lookupEnv)
import System.IO (hPutStrLn, stderr)
import Text.Megaparsec ()
import Control.Monad (foldM, unless, when)
import Data.Text (unpack, pack)
import qualified Data.Text as T
import Data.Version (showVersion)
import Paths_tricu (version)
import Options.Applicative
import qualified Data.ByteString.Lazy as BL
import Database.SQLite.Simple (close)
import Database.SQLite.Simple (Connection, close)
import qualified Data.Map as Map
import System.Environment (lookupEnv)
-- ---------------------------------------------------------------------------
-- CLI argument types
-- ---------------------------------------------------------------------------
data TricuArgs
= Repl
| Evaluate { file :: [FilePath], form :: EvaluatedForm, outFile :: FilePath }
| TDecode { file :: [FilePath] }
| Compile { inputFile :: FilePath, outFile :: FilePath, names :: [String] }
| Export { hash :: String, exportNameOpt :: String, outFile :: FilePath, names :: [String] }
| Import { inFile :: FilePath }
| Serve { host :: String, port :: Int }
| ExportDag { target :: String, outFile :: FilePath }
deriving (Show, Data, Typeable)
| Eval
{ evalFiles :: [FilePath]
, evalFormat :: EvaluatedForm
, evalOutput :: FilePath
, evalDb :: Maybe FilePath
}
| ArboricxCompile
{ compileInput :: FilePath
, compileOutput :: FilePath
, compileNames :: [String]
, compileDb :: Maybe FilePath
}
| ArboricxImport
{ importFile :: FilePath
, importDb :: Maybe FilePath
}
| ArboricxExport
{ exportTargets :: [String]
, exportOutput :: FilePath
, exportNames :: [String]
, exportDb :: Maybe FilePath
, dag :: Bool
}
| ArboricxServe
{ serveHost :: String
, servePort :: Int
, serveDb :: Maybe FilePath
}
deriving (Show)
replMode :: TricuArgs
replMode = Repl
&= help "Start interactive REPL"
&= auto
&= name "repl"
-- ---------------------------------------------------------------------------
-- optparse-applicative parsers
-- ---------------------------------------------------------------------------
evaluateMode :: TricuArgs
evaluateMode = Evaluate
{ file = def &= help "Input file path(s) for evaluation.\n \
\ Defaults to stdin."
&= name "f" &= typ "FILE"
, form = TreeCalculus &= typ "FORM"
&= help "Optional output form: (tree|fsl|ast|ternary|ascii|decode).\n \
\ Defaults to tricu-compatible `t` tree form."
&= name "t"
, outFile = def &= help "Optional output file path. Defaults to stdout."
&= name "o" &= typ "FILE"
}
&= help "Evaluate tricu and return the result of the final expression."
&= explicit
&= name "eval"
readEvaluatedForm :: ReadM EvaluatedForm
readEvaluatedForm = eitherReader $ \s -> case s of
"tree" -> Right Tree
"fsl" -> Right FSL
"ast" -> Right AST
"ternary" -> Right Ternary
"ascii" -> Right Ascii
"decode" -> Right Decode
_ -> Left $ "Unknown format: " ++ s ++ ". Expected: tree, fsl, ast, ternary, ascii, decode"
decodeMode :: TricuArgs
decodeMode = TDecode
{ file = def
&= help "Optional input file path to attempt decoding.\n \
\ Defaults to stdin."
&= name "f" &= typ "FILE"
}
&= help "Decode a Tree Calculus value into a string representation."
&= explicit
&= name "decode"
evalParser :: Parser TricuArgs
evalParser = Eval
<$> many (argument str (metavar "FILE..."))
<*> option readEvaluatedForm
( long "format"
<> short 'f'
<> metavar "FORM"
<> value Tree
<> help "Output format: tree, fsl, ast, ternary, ascii, decode"
)
<*> option str
( long "output"
<> short 'o'
<> metavar "FILE"
<> value ""
<> help "Write output to file instead of stdout"
)
<*> optional (option str
( long "db"
<> short 'd'
<> metavar "PATH"
<> help "Content store database path"
))
exportMode :: TricuArgs
exportMode = Export
{ hash = def &= help "Hash or stored term name(s) to export (comma-separated)."
&= name "h" &= typ "HASH_OR_NAME"
, exportNameOpt = def &= help "Export name (legacy; use -n NAME for full control)."
&= name "n" &= typ "NAME"
, outFile = def &= help "Output file path for the bundle." &= name "o" &= typ "FILE"
, names = def &= help "Export name(s) for the bundle manifest (comma-separated or repeated -n)."
&= typ "NAME"
}
&= help "Export a Merkle bundle from the content store."
&= explicit
&= name "export"
compileParser :: Parser TricuArgs
compileParser = ArboricxCompile
<$> option str
( long "file"
<> short 'f'
<> metavar "FILE"
<> value ""
<> help "Input .tri source file"
)
<*> option str
( long "output"
<> short 'o'
<> metavar "FILE"
<> value ""
<> help "Output bundle file path (required)"
)
<*> many (option str
( long "name"
<> short 'n'
<> metavar "NAME"
<> help "Definition name(s) to export as bundle roots (repeatable)"
))
<*> optional (option str
( long "db"
<> short 'd'
<> metavar "PATH"
<> help "Content store database path"
))
importMode :: TricuArgs
importMode = Import
{ inFile = def &= help "Path to the bundle file to import."
&= name "f" &= typ "FILE"
}
&= help "Import a Merkle bundle into the content store."
&= explicit
&= name "import"
importParser :: Parser TricuArgs
importParser = ArboricxImport
<$> option str
( long "file"
<> short 'f'
<> metavar "FILE"
<> value ""
<> help "Bundle file to import"
)
<*> optional (option str
( long "db"
<> short 'd'
<> metavar "PATH"
<> help "Content store database path"
))
compileMode :: TricuArgs
compileMode = Compile
{ inputFile = def &= help "Path to the tricu source file (.tri) to compile."
&= name "f" &= typ "FILE"
, outFile = def &= help "Output bundle file path (.tri.bundle)."
&= name "o" &= typ "FILE"
, names = def &= help "Definition name(s) to export as bundle roots (comma-separated or repeated -x). Defaults to 'main'."
&= name "x" &= typ "NAME"
}
&= help "Compile a tricu source file into a standalone Arboricx portable bundle."
&= explicit
&= name "compile"
exportParser :: Parser TricuArgs
exportParser = ArboricxExport
<$> many (option str
( long "target"
<> short 't'
<> metavar "TARGET"
<> help "Target hash or name (repeatable)"
))
<*> option str
( long "output"
<> short 'o'
<> metavar "FILE"
<> value ""
<> help "Output file path (required for bundle export)"
)
<*> many (option str
( long "name"
<> short 'n'
<> metavar "NAME"
<> help "Export name(s) for the bundle manifest (repeatable)"
))
<*> optional (option str
( long "db"
<> short 'd'
<> metavar "PATH"
<> help "Content store database path"
))
<*> switch
( long "dag"
<> help "Export as a topologically-sorted DAG node table instead of a bundle"
)
serveMode :: TricuArgs
serveMode = Serve
{ host = "127.0.0.1" &= help "Host to bind the server to." &= name "h" &= typ "HOST"
, port = 8787 &= help "HTTP port to listen on." &= name "p" &= typ "PORT"
}
&= help "Start a read-only HTTP server for exporting Arboricx bundles."
&= explicit
&= name "server"
serveParser :: Parser TricuArgs
serveParser = ArboricxServe
<$> option str
( long "host"
<> metavar "HOST"
<> value "127.0.0.1"
<> help "Host to bind the server to"
)
<*> option auto
( long "port"
<> short 'p'
<> metavar "PORT"
<> value 8787
<> help "HTTP port to listen on"
)
<*> optional (option str
( long "db"
<> short 'd'
<> metavar "PATH"
<> help "Content store database path"
))
exportDagMode :: TricuArgs
exportDagMode = ExportDag
{ target = def &= help "Stored term name or hash to export as a DAG node table."
&= name "t" &= typ "NAME_OR_HASH"
, outFile = def &= help "Optional output file path. Defaults to stdout."
&= name "o" &= typ "FILE"
}
&= help "Export a term's Merkle DAG as a topologically-sorted node table for host embedding."
&= explicit
&= name "export-dag"
versionStr :: String
versionStr = "tricu " ++ showVersion version
tricuParser :: Parser TricuArgs
tricuParser = (subparser topCommands <|> pure Repl)
<**> infoOption versionStr (long "version" <> help "Show version")
where
topCommands = mconcat
[ command "eval" (info (evalParser <**> helper)
(progDesc "Evaluate tricu source and print the result of the final expression"))
, command "arboricx" (info (arboricxParser <**> helper)
(progDesc "Arboricx bundle operations"))
]
arboricxParser :: Parser TricuArgs
arboricxParser = subparser $ mconcat
[ command "compile" (info (compileParser <**> helper)
(progDesc "Compile a .tri file into a standalone Arboricx bundle"))
, command "import" (info (importParser <**> helper)
(progDesc "Import an Arboricx bundle into the content store"))
, command "export" (info (exportParser <**> helper)
(progDesc "Export one or more terms from the content store"))
, command "serve" (info (serveParser <**> helper)
(progDesc "Start a read-only HTTP server for Arboricx bundles"))
]
-- ---------------------------------------------------------------------------
-- Entry point
-- ---------------------------------------------------------------------------
main :: IO ()
main = do
let versionStr = "tricu Evaluator and REPL " ++ showVersion version
cmdArgsParsed <- cmdArgs $ modes [replMode, evaluateMode, decodeMode, compileMode, exportMode, importMode, serveMode, exportDagMode]
&= help "tricu: Exploring Tree Calculus"
&= program "tricu"
&= summary versionStr
&= versionArg [explicit, name "version", summary versionStr]
case cmdArgsParsed of
Repl -> do
putStrLn "Welcome to the tricu REPL"
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
repl
Evaluate { file = filePaths, form = outputForm, outFile = evalOutFile } -> do
maybeDbPath <- lookupEnv "TRICU_DB_PATH"
evalResult <- case filePaths of
[] -> do
initialEnv <- case maybeDbPath of
Just _ -> do
conn <- initContentStore
env <- loadEnvironment conn
close conn
return env
Nothing -> return Map.empty
input <- getContents
pure $ runTricuTEnv initialEnv input
filePaths@(_:_) -> do
initialEnv <- case maybeDbPath of
Just _ -> do
conn <- initContentStore
env <- loadEnvironment conn
close conn
return env
Nothing -> return Map.empty
finalEnv <- foldM evaluateFileWithContext initialEnv filePaths
pure $ mainResult finalEnv
let fRes = formatT outputForm evalResult
if null evalOutFile
then putStr fRes
else writeFile evalOutFile fRes
TDecode { file = filePaths } -> do
value <- case filePaths of
[] -> getContents
(filePath:_) -> readFile filePath
putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value
Export { hash = hashStr, exportNameOpt = legacyName, names = namesArg, outFile = outFilePath } -> do
conn <- initContentStore
let hashList = T.split (== ',') (T.pack hashStr)
hashes <- mapM (\h -> do
(resolvedHash, _) <- resolveExportTarget conn (T.unpack h)
return resolvedHash) hashList
-- Merge legacy -n and new -n (names); names wins when non-empty
let allNames = if null namesArg
then if null legacyName then [] else [legacyName]
else namesArg
let expNames = if null allNames
then defaultExportNames (length hashes)
else map T.pack allNames
let exports = zip expNames hashes
bundleData <- exportNamedBundle conn exports
BL.writeFile outFilePath (BL.fromStrict bundleData)
putStrLn $ "Exported bundle with " ++ show (length exports) ++ " export(s) to " ++ outFilePath
close conn
Import { inFile = importFile } -> do
conn <- initContentStore
bundleData <- BL.readFile importFile
roots <- importBundle conn (BL.toStrict bundleData)
putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
mapM_ (\r -> putStrLn $ " " ++ unpack r) roots
close conn
Compile { inputFile = compileInputFile, outFile = compileOutFile, names = namesArg } ->
let exportNames = if null namesArg then [] else map T.pack namesArg
in compileFile compileInputFile compileOutFile exportNames
Serve { host = hostStr, port = portNum } -> do
putStrLn $ "Starting Arboricx bundle server on " ++ hostStr ++ ":" ++ show portNum
putStrLn $ " GET /bundle/hash/:hash -- primary endpoint"
putStrLn $ " GET /bundle/name/:name -- convenience endpoint"
putStrLn $ " Content-Type: application/vnd.arboricx.bundle"
runServer hostStr portNum
ExportDag { target = targetName, outFile = dagOutFile } -> do
conn <- initContentStore
maybeTerm <- loadTerm conn targetName
close conn
args <- execParser $ info (tricuParser <**> helper)
( fullDesc
<> progDesc "Exploring Tree Calculus"
<> header versionStr
)
case args of
Repl -> runRepl
Eval {} -> runEval args
ArboricxCompile {} -> runCompile args
ArboricxImport {} -> runImport args
ArboricxExport {} -> runExport args
ArboricxServe {} -> runServe args
-- ---------------------------------------------------------------------------
-- Command runners
-- ---------------------------------------------------------------------------
runRepl :: IO ()
runRepl = do
putStrLn "Welcome to the tricu REPL"
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
repl
runEval :: TricuArgs -> IO ()
runEval opts = do
let files = evalFiles opts
form = evalFormat opts
out = evalOutput opts
mconn <- case evalDb opts of
Just dbPath -> Just <$> initContentStoreWithPath (Just dbPath)
Nothing -> do
mDbPath <- lookupEnv "TRICU_DB_PATH"
case mDbPath of
Just _ -> Just <$> initContentStoreWithPath Nothing
Nothing -> return Nothing
resultT <- case files of
[] -> do
input <- getContents
env <- evalTricuWithStore mconn Map.empty (parseTricu input)
return $ result env
_ -> do
finalEnv <- foldM (evaluateFileWithStore mconn) Map.empty files
return $ mainResult finalEnv
case mconn of
Just conn -> close conn
Nothing -> return ()
writeOutput out (formatT form resultT)
runCompile :: TricuArgs -> IO ()
runCompile opts = do
let input = compileInput opts
out = compileOutput opts
names = compileNames opts
when (null out) $ die "tricu arboricx compile: --output is required"
when (null input) $ die "tricu arboricx compile: input file is required"
let nameTexts = if null names then [] else map T.pack names
compileFile input out nameTexts
runImport :: TricuArgs -> IO ()
runImport opts = do
let file = importFile opts
when (null file) $ die "tricu arboricx import: input file is required"
withContentStore (importDb opts) $ \conn -> do
bundleData <- BL.readFile file
roots <- importBundle conn (BL.toStrict bundleData)
putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
mapM_ (\r -> putStrLn $ " " ++ unpack r) roots
runExport :: TricuArgs -> IO ()
runExport opts =
if dag opts
then runExportDag opts
else runExportBundle opts
runExportBundle :: TricuArgs -> IO ()
runExportBundle opts = do
let targets = exportTargets opts
out = exportOutput opts
names = exportNames opts
when (null out) $ die "tricu arboricx export: --output is required"
when (null targets) $ die "tricu arboricx export: at least one --target is required"
withContentStore (exportDb opts) $ \conn -> do
hashes <- mapM (\t -> do
(h, _) <- resolveExportTarget conn t
return h) targets
let expNames = if null names
then defaultExportNames (length hashes)
else map T.pack names
when (length expNames /= length hashes) $
die "tricu arboricx export: number of --name values must match number of TARGETs"
let exports = zip expNames hashes
bundleData <- exportNamedBundle conn exports
BL.writeFile out (BL.fromStrict bundleData)
putStrLn $ "Exported bundle with " ++ show (length exports) ++ " export(s) to " ++ out
runExportDag :: TricuArgs -> IO ()
runExportDag opts = do
let targets = exportTargets opts
out = exportOutput opts
case targets of
[target] -> withContentStore (exportDb opts) $ \conn -> do
maybeTerm <- loadTerm conn target
case maybeTerm of
Nothing -> die $ "Term not found: " ++ targetName
Nothing -> die $ "Term not found: " ++ target
Just term -> do
let (rootIdx, nodes) = exportDag term
output = unlines $ show rootIdx : map (\(tag, refs) -> unwords (tag : map show refs)) nodes
if null dagOutFile
then putStr output
else writeFile dagOutFile output
let (rootIdx, nodes) = Research.exportDag term
output = unlines $
show rootIdx :
map (\(tag, refs) -> unwords (tag : map show refs)) nodes
writeOutput out output
[] -> die "tricu arboricx export --dag: exactly one --target is required"
_ -> die "tricu arboricx export --dag: exactly one --target is required"
runTricu :: String -> String
runTricu = formatT TreeCalculus . runTricuT
runServe :: TricuArgs -> IO ()
runServe opts = do
let hostStr = serveHost opts
portNum = servePort opts
putStrLn $ "Starting Arboricx bundle server on " ++ hostStr ++ ":" ++ show portNum
putStrLn $ " GET /bundle/hash/:hash -- primary endpoint"
putStrLn $ " GET /bundle/name/:name -- convenience endpoint"
putStrLn $ " Content-Type: application/vnd.arboricx.bundle"
runServerWithPath (serveDb opts) hostStr portNum
runTricuT :: String -> T
runTricuT input =
let asts = parseTricu input
finalEnv = evalTricu Map.empty asts
in result finalEnv
-- ---------------------------------------------------------------------------
-- Helpers
-- ---------------------------------------------------------------------------
runTricuEnv :: Env -> String -> String
runTricuEnv env = formatT TreeCalculus . runTricuTEnv env
withContentStore :: Maybe FilePath -> (Connection -> IO a) -> IO a
withContentStore mPath act = do
conn <- initContentStoreWithPath mPath
result <- act conn
close conn
return result
writeOutput :: FilePath -> String -> IO ()
writeOutput path content
| null path = putStr content
| otherwise = writeFile path content
runTricuTEnv :: Env -> String -> T
runTricuTEnv env input =
let asts = parseTricu input
finalEnv = evalTricu env asts
in result finalEnv
runTricuWithEnvT :: String -> (Env, T)
runTricuWithEnvT input =
let asts = parseTricu input
finalEnv = evalTricu Map.empty asts
in (finalEnv, result finalEnv)
runTricuWithEnv :: String -> (Env, String)
runTricuWithEnv input =
let asts = parseTricu input
finalEnv = evalTricu Map.empty asts
res = result finalEnv
in (finalEnv, formatT TreeCalculus res)
runTricuEnvWithEnvT :: Env -> String -> (Env, T)
runTricuEnvWithEnvT env input =
let asts = parseTricu input
finalEnv = evalTricu env asts
in (finalEnv, result finalEnv)
runTricuEnvWithEnv :: Env -> String -> (Env, String)
runTricuEnvWithEnv env input =
let asts = parseTricu input
finalEnv = evalTricu env asts
res = result finalEnv
in (finalEnv, formatT TreeCalculus res)
chooseExportName :: String -> String -> [Text] -> IO Text
chooseExportName explicitName input storedNames
| not (null explicitName) = return $ T.pack explicitName
| Just firstName <- firstNonEmpty storedNames = return firstName
| otherwise = do
hPutStrLn stderr $
"No stored name found for export target " ++ input ++ "; using export name 'root'. "
++ "Use export -n NAME to preserve a semantic name."
return "root"
firstNonEmpty :: [Text] -> Maybe Text
firstNonEmpty = go
where
go [] = Nothing
go (x:xs)
| T.null x = go xs
| otherwise = Just x