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

11
src/ContentStore.hs
View File

@@ -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

37
src/Eval.hs
View File

@@ -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

24
src/FileEval.hs
View File

@@ -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

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

2
src/REPL.hs
View File

@@ -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)

10
src/Research.hs
View File

@@ -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

93
src/Server.hs
View File

@@ -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

6
tricu.cabal
View File

@@ -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