commit 844aa391bd60e79bc8da9887f67941ebc8bf1e2c
parent 42f5dbaff9d4ee36310cad7adeb67fa4b39d5d64
Author: James Eversole <james@eversole.co>
Date: Mon, 11 May 2026 15:29:12 -0500
CLI rewrite
Diffstat:
8 files changed, 441 insertions(+), 330 deletions(-)
diff --git a/src/ContentStore.hs b/src/ContentStore.hs
@@ -40,8 +40,15 @@ serializeNameList :: [Text] -> Text
serializeNameList = T.intercalate "," . nub . sort
initContentStore :: IO Connection
-initContentStore = do
- dbPath <- getContentStorePath
+initContentStore = initContentStoreWithPath Nothing
+
+-- | Initialise a content store with an explicit path, or fall back
+-- to the environment variable / default location.
+initContentStoreWithPath :: Maybe FilePath -> IO Connection
+initContentStoreWithPath mPath = do
+ dbPath <- case mPath of
+ Just p -> return p
+ Nothing -> getContentStorePath
createDirectoryIfMissing True (takeDirectory dbPath)
conn <- open dbPath
setupDatabase conn
diff --git a/src/Eval.hs b/src/Eval.hs
@@ -93,6 +93,43 @@ evalAST mconn selectedVersions ast = do
resolvedEnv <- resolveTermsFromStore mconn selectedVersions varNames
return $ evalASTSync resolvedEnv ast
+-- | Evaluate a single AST term using a local environment augmented by
+-- lazily-resolved store terms.
+evalASTWithEnv :: Maybe Connection -> Env -> TricuAST -> IO T
+evalASTWithEnv mconn localEnv ast = do
+ let varNames = collectVarNames ast
+ storeEnv <- resolveTermsFromStore mconn Map.empty varNames
+ let combinedEnv = Map.union localEnv storeEnv
+ return $ evalASTSync combinedEnv ast
+
+-- | Store-aware version of 'evalSingle'.
+evalSingleWithStore :: Maybe Connection -> Env -> TricuAST -> IO Env
+evalSingleWithStore mconn env term
+ | SDef name [] body <- term = do
+ res <- evalASTWithEnv mconn env body
+ case Map.lookup name env of
+ Just existingValue
+ | existingValue == res -> return env
+ | otherwise -> return $ Map.insert "!result" res (Map.insert name res env)
+ Nothing -> return $ Map.insert "!result" res (Map.insert name res env)
+ | otherwise = do
+ res <- evalASTWithEnv mconn env term
+ return $ Map.insert "!result" res env
+
+-- | Store-aware version of 'evalTricu'. Does not preload the entire
+-- content store; terms are resolved on demand as variables are
+-- encountered.
+evalTricuWithStore :: Maybe Connection -> Env -> [TricuAST] -> IO Env
+evalTricuWithStore mconn env x = go env (reorderDefs env x)
+ where
+ go env' [] = return env'
+ go env' [def] = do
+ updatedEnv <- evalSingleWithStore mconn env' def
+ return $ Map.insert "!result" (result updatedEnv) updatedEnv
+ go env' (def:xs) = do
+ updatedEnv <- evalSingleWithStore mconn env' def
+ evalTricuWithStore mconn updatedEnv xs
+
collectVarNames :: TricuAST -> [(String, Maybe String)]
collectVarNames = go []
where
diff --git a/src/FileEval.hs b/src/FileEval.hs
@@ -2,21 +2,22 @@ module FileEval
( preprocessFile
, evaluateFile
, evaluateFileWithContext
+ , evaluateFileWithStore
, evaluateFileResult
, compileFile
) where
-import Eval (evalTricu)
+import Eval (evalTricu, evalTricuWithStore)
import Lexer
import Parser
import Research
-import ContentStore (initContentStore, storeTerm, hashTerm)
+import ContentStore (newContentStore, storeTerm, hashTerm)
+import Database.SQLite.Simple (Connection)
import Wire (exportNamedBundle, defaultExportNames)
import Control.Monad (forM_)
import Data.List (partition)
import Data.Maybe (mapMaybe)
-import System.Environment (setEnv)
import System.FilePath (takeDirectory, normalise, (</>))
import System.Exit (die)
import Database.SQLite.Simple (close)
@@ -79,6 +80,18 @@ evaluateFileWithContext env filePath = do
ast <- preprocessFile filePath
pure $ evalTricu env ast
+-- | File evaluation that lazily resolves missing names from the
+-- content store instead of pre-loading the entire store into memory.
+evaluateFileWithStore :: Maybe Connection -> Env -> FilePath -> IO Env
+evaluateFileWithStore mconn env filePath = do
+ contents <- readFile filePath
+ let tokens = lexTricu contents
+ case parseProgram tokens of
+ Left err -> errorWithoutStackTrace (handleParseError err)
+ Right _ast -> do
+ ast <- preprocessFile filePath
+ evalTricuWithStore mconn env ast
+
preprocessFile :: FilePath -> IO [TricuAST]
preprocessFile p = preprocessFile' Set.empty p p
@@ -181,9 +194,8 @@ compileFile inputPath outputPath maybeNames = do
$ map (\(n,t) -> (T.pack n, t)) compiledTerms
compiledNames :: [T.Text] = Map.keys compiledMap
compiledTermsList :: [T] = Map.elems compiledMap
- -- Create a temp content store
- setEnv "TRICU_DB_PATH" "/tmp/tricu-compile.db"
- conn <- initContentStore
+ -- Create a temp in-memory content store
+ conn <- newContentStore
-- Store each term in the temp store under its requested name
forM_ (zip compiledNames compiledTermsList) $ \(n, t) ->
storeTerm conn [T.unpack n] t
diff --git a/src/Main.hs b/src/Main.hs
@@ -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)
+
+-- ---------------------------------------------------------------------------
+-- optparse-applicative parsers
+-- ---------------------------------------------------------------------------
+
+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"
+
+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"
+ ))
-replMode :: TricuArgs
-replMode = Repl
- &= help "Start interactive REPL"
- &= auto
- &= name "repl"
+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"
+ ))
-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"
+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"
+ ))
-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"
+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"
+ )
-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"
+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"
+ ))
-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"
+versionStr :: String
+versionStr = "tricu " ++ showVersion version
-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"
+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"))
+ ]
-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"
+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"))
+ ]
-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"
+-- ---------------------------------------------------------------------------
+-- 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
diff --git a/src/REPL.hs b/src/REPL.hs
@@ -130,7 +130,7 @@ repl = do
handleOutput :: REPLState -> InputT IO ()
handleOutput state = do
- let formats = [Decode, TreeCalculus, FSL, AST, Ternary, Ascii]
+ let formats = [Decode, Tree, FSL, AST, Ternary, Ascii]
outputStrLn "Available output formats:"
mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f)
(zip [1..] formats)
diff --git a/src/Research.hs b/src/Research.hs
@@ -8,8 +8,6 @@ import Data.Map ()
import Data.Text (Text, replace)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Word (Word8)
-import System.Console.CmdArgs (Data, Typeable)
-
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -55,8 +53,8 @@ data LToken
deriving (Eq, Show, Ord)
-- Output formats
-data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
- deriving (Show, Data, Typeable)
+data EvaluatedForm = Tree | FSL | AST | Ternary | Ascii | Decode
+ deriving (Show)
-- Environment containing previously evaluated TC terms
type Env = Map.Map String T
@@ -243,7 +241,7 @@ toList _ = Left "Invalid Tree Calculus list"
-- Outputs
formatT :: EvaluatedForm -> T -> String
-formatT TreeCalculus = toSimpleT . show
+formatT Tree = toSimpleT . show
formatT FSL = show
formatT AST = show . toAST
formatT Ternary = toTernaryString
@@ -289,7 +287,7 @@ decodeResult tc =
(_, _, Right n) -> show n
(_, Right xs@(_:_), _) -> "[" ++ intercalate ", " (map decodeResult xs) ++ "]"
(_, Right [], _) -> "[]"
- _ -> formatT TreeCalculus tc
+ _ -> formatT Tree tc
where
isCommonChar c =
let n = fromEnum c
diff --git a/src/Server.hs b/src/Server.hs
@@ -1,15 +1,15 @@
module Server
( runServer
+ , runServerWithPath
) where
-import ContentStore (initContentStore, nameToTerm, hashToTerm, listStoredTerms,
+import ContentStore (initContentStore, initContentStoreWithPath, nameToTerm, hashToTerm, listStoredTerms,
parseNameList, StoredTerm(..), termHash)
-import Database.SQLite.Simple (close)
+import Database.SQLite.Simple (Connection, close)
import Wire (exportNamedBundle)
-import Control.Monad (when)
+import Control.Monad (when, void)
import Data.Maybe (catMaybes)
-import Control.Monad (void)
import Network.HTTP.Types (Header, Status, status200, status400, status404, status405, hContentType)
import Network.Wai
@@ -25,48 +25,36 @@ import qualified Data.Text as T
-- | Start an HTTP server that serves Arboricx bundles from the
-- local content store.
---
--- This is a read-only export surface. Clients fetch bundle bytes
--- and independently inspect / verify / run them. The server does
--- not execute bundles.
---
--- Bind host defaults to @127.0.0.1@.
---
--- Endpoints
--- ---------
--- GET /health - 200 "ok"
--- GET /bundle/name/:name - export single term by name
--- GET /bundle/hash/:hash - export single term by hash
--- GET /bundle/roots?n=...&h=... - export multiple roots (n=name, h=hash)
--- GET /terms - plain-text listing (debug)
---
runServer :: String -> Int -> IO ()
-runServer hostStr port =
- runSettings settings app
+runServer = runServerWithPath Nothing
+
+-- | Start an HTTP server with an explicit database path.
+runServerWithPath :: Maybe FilePath -> String -> Int -> IO ()
+runServerWithPath mDbPath hostStr port =
+ runSettings settings (app mkConn)
where
+ mkConn = initContentStoreWithPath mDbPath
settings = setPort port $ setHost (fromString hostStr) defaultSettings
-- | WAI application backed by the content store.
--- Uses the same database path as @eval@ mode (env var
--- @TRICU_DB_PATH@ or the default location).
-app :: Application
-app request respond = case (requestMethod request, pathInfo request) of
+app :: IO Connection -> Application
+app mkConn request respond = case (requestMethod request, pathInfo request) of
("GET", ["health"]) ->
respond $ healthResponse
("GET", ["bundle", "roots"]) ->
- rootsHandler request respond
+ rootsHandler mkConn request respond
("GET", ["bundle", "name", nameText]) -> do
- body <- nameHandler nameText
+ body <- nameHandler mkConn nameText
respond body
("GET", ["bundle", "hash", hashText]) -> do
- body <- hashHandler hashText
+ body <- hashHandler mkConn hashText
respond body
("GET", ["terms"]) -> do
- body <- termsResponse
+ body <- termsResponse mkConn
respond body
("POST", _) ->
@@ -85,18 +73,9 @@ healthResponse :: Response
healthResponse = responseLBS status200 [] "ok"
-- | GET /bundle/roots?n=root&n=helper&h=abc123...
--- Resolve multiple named roots (by stored term name or raw hash)
--- and return a single bundle containing all of them.
---
--- Query parameters:
--- - @n=<name>@ — one or more stored term names (resolved via nameToTerm)
--- - @h=<hash>@ — one or more full Merkle hashes (validated as 16-64 hex chars)
---
--- The bundle manifest receives all resolved (name, hash) pairs as roots
--- and exports. The node section is the union of all reachable nodes.
-rootsHandler :: Request -> (Response -> IO a) -> IO a
-rootsHandler request respond = do
- conn <- initContentStore
+rootsHandler :: IO Connection -> Request -> (Response -> IO a) -> IO a
+rootsHandler mkConn request respond = do
+ conn <- mkConn
let qs = queryString request
nParams = catMaybes [v | (k, v) <- qs, map toLower (unpack k) == "n"]
hParams = catMaybes [v | (k, v) <- qs, map toLower (unpack k) == "h"]
@@ -133,14 +112,9 @@ rootsHandler request respond = do
(fromStrict bundleData)
-- | GET /bundle/name/:name
--- Resolve a stored term name, export it as an Arboricx bundle,
--- and return the raw bundle bytes.
---
--- Sets @Content-Type@ and @X-Arboricx-Root-Hash@ headers.
--- Returns 404 when the name does not resolve to any stored term.
-nameHandler :: Text -> IO Response
-nameHandler nameText = do
- conn <- initContentStore
+nameHandler :: IO Connection -> Text -> IO Response
+nameHandler mkConn nameText = do
+ conn <- mkConn
stored <- nameToTerm conn nameText
case stored of
Nothing -> do
@@ -155,19 +129,13 @@ nameHandler nameText = do
return $ responseLBS status200 (bundleHeaders th cd) (fromStrict bundleData)
-- | GET /bundle/hash/:hash
--- Resolve a full Merkle hash and export the root as an Arboricx
--- bundle.
---
--- - Malformed hash (non-hex or < 16 chars): 400
--- - Well-formed but absent: 404
--- - Present: 200 with bundle bytes
-hashHandler :: Text -> IO Response
-hashHandler hashText =
+hashHandler :: IO Connection -> Text -> IO Response
+hashHandler mkConn hashText =
let raw = T.pack (dropWhile (== '#') (T.unpack hashText))
in if not (T.all isHexDigit raw) || T.length raw < 16
then return $ responseLBS status400 [] "400 Bad Request: invalid hash"
else do
- conn <- initContentStore
+ conn <- mkConn
stored <- hashToTerm conn raw
case stored of
Nothing -> do
@@ -183,10 +151,9 @@ hashHandler hashText =
(fromStrict bundleData)
-- | GET /terms
--- Plain-text listing of all stored terms (debugging only).
-termsResponse :: IO Response
-termsResponse = do
- conn <- initContentStore
+termsResponse :: IO Connection -> IO Response
+termsResponse mkConn = do
+ conn <- mkConn
terms <- listStoredTerms conn
close conn
let lines' = [ names <> " " <> hash <> " " <> T.pack (show created)
@@ -212,14 +179,12 @@ bundleHeaders root cd =
, ("Content-Disposition", encodeUtf8 cd)
]
--- | Pick the first stored name, falling back to "root" when names are empty.
firstOrRoot :: Text -> Text
firstOrRoot names =
case parseNameList names of
[] -> "root"
(x:_) -> x
--- | Sanitise a string to a safe filename prefix.
safeFileName :: String -> String
safeFileName = map go
where
diff --git a/tricu.cabal b/tricu.cabal
@@ -17,7 +17,6 @@ executable tricu
hs-source-dirs:
src
default-extensions:
- DeriveDataTypeable
LambdaCase
MultiWayIf
OverloadedStrings
@@ -41,7 +40,7 @@ executable tricu
, base16-bytestring
, base64-bytestring
, bytestring
- , cmdargs
+ , optparse-applicative
, containers
, cryptonite
, directory
@@ -82,7 +81,6 @@ test-suite tricu-tests
main-is: Spec.hs
hs-source-dirs: test, src
default-extensions:
- DeriveDataTypeable
LambdaCase
MultiWayIf
OverloadedStrings
@@ -93,7 +91,7 @@ test-suite tricu-tests
, base16-bytestring
, base64-bytestring
, bytestring
- , cmdargs
+ , optparse-applicative
, containers
, cryptonite
, directory
