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

Tricu 2.0.0

Browse Source 
Sorry for squashing all of this but 🤷
This commit is contained in:
James Eversole
2026-05-25 12:43:15 -05:00
parent 2e2db07bd6
commit fdebb6c13d
105 changed files with 10139 additions and 1938 deletions
Download Patch File Download Diff File Expand all files Collapse all files

353
src/Main.hs
View File

@@ -1,17 +1,27 @@
module Main where
import ContentStore (initContentStoreWithPath, loadEnvironment, loadTerm, loadTree, resolveExportTarget)
import Check (checkFile, checkFileWithStore, instrumentIOContinuations)
import ContentStore
import ContentStore.Bundle
import Module.Manifest
import System.Exit (die)
import Eval (evalTricu, evalTricuWithStore, mainResult, result)
import FileEval (evaluateFileWithContext, evaluateFileWithStore, compileFile)
import Eval (evalTricu, mainResult, result)
import FileEval
( ContractMode(..)
, LoadedSource(..)
, defaultStorePath
, evaluateFileWithContextWithStoreAndMode
, evaluateFileWithStore
, loadFileWithStoreMode
, compileFileWithStore
)
import IODriver (IOPermissions(..), runIO)
import Parser (parseTricu)
import REPL (repl)
import Research (T, EvaluatedForm(..), Env, formatT, exportDag)
import Wire (buildBundle, encodeBundle, importBundle, defaultExportNames, Bundle(..))
import Wire (encodeBundle, defaultExportNames, Bundle(..))
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)
@@ -20,10 +30,9 @@ import Options.Applicative
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Sequence as Seq
import Database.SQLite.Simple (Connection, close)
import qualified Data.Map as Map
import System.Environment (lookupEnv)
import System.Directory (getHomeDirectory)
import System.FilePath (takeBaseName, (</>))
-- ---------------------------------------------------------------------------
-- CLI argument types
@@ -31,11 +40,16 @@ import System.Environment (lookupEnv)
data TricuArgs
= Repl
| Check
{ checkInput :: FilePath
, checkStore :: Maybe FilePath
}
| Eval
{ evalFiles :: [FilePath]
, evalStore :: Maybe FilePath
, evalFormat :: EvaluatedForm
, evalOutput :: FilePath
, evalDb :: Maybe FilePath
, evalUnchecked :: Bool
, evalIo :: Bool
, evalAllowRead :: [FilePath]
, evalAllowWrite :: [FilePath]
@@ -45,21 +59,32 @@ data TricuArgs
}
| ArboricxCompile
{ compileInput :: FilePath
, compileStore :: Maybe FilePath
, compileOutput :: FilePath
, compileNames :: [String]
, compileDb :: Maybe FilePath
}
| ArboricxImport
{ importFile :: FilePath
, importDb :: Maybe FilePath
{ importFile :: FilePath
, importStore :: Maybe FilePath
, importModule :: Maybe String
}
| ArboricxExport
{ exportTargets :: [String]
, exportModules :: [String]
, exportOutput :: FilePath
, exportNames :: [String]
, exportDb :: Maybe FilePath
, exportStore :: Maybe FilePath
, dag :: Bool
}
| StoreAliasList
{ storeAliasKind :: AliasKind
, storePathOpt :: Maybe FilePath
}
| StoreAliasGet
{ storeAliasKind :: AliasKind
, storeAliasName :: String
, storePathOpt :: Maybe FilePath
}
deriving (Show)
-- ---------------------------------------------------------------------------
@@ -78,9 +103,25 @@ readEvaluatedForm = eitherReader $ \s -> case s of
"string" -> Right StringLit
_ -> Left $ "Unknown format: " ++ s ++ ". Expected: tree, fsl, ast, ternary, ascii, decode, number, string"
checkParser :: Parser TricuArgs
checkParser = Check
<$> argument str (metavar "FILE")
<*> optional (option str
( long "store"
<> short 's'
<> metavar "PATH"
<> help "Content-addressed store path for module import resolution"
))
evalParser :: Parser TricuArgs
evalParser = Eval
<$> many (argument str (metavar "FILE..."))
<*> optional (option str
( long "store"
<> short 's'
<> metavar "PATH"
<> help "Content-addressed store path for module import resolution"
))
<*> option readEvaluatedForm
( long "format"
<> short 'f'
@@ -95,12 +136,10 @@ evalParser = Eval
<> value ""
<> help "Write output to file instead of stdout"
)
<*> optional (option str
( long "db"
<> short 'd'
<> metavar "PATH"
<> help "Content store database path"
))
<*> switch
( long "unchecked"
<> help "Evaluate as untyped code: ignore View Contract annotations and do not publish unchecked view refs"
)
<*> switch
( long "io"
<> help "Interpret the result as an IO action tree and execute it"
@@ -137,6 +176,12 @@ compileParser = ArboricxCompile
<> value ""
<> help "Input .tri source file"
)
<*> optional (option str
( long "store"
<> short 's'
<> metavar "PATH"
<> help "Content-addressed store path for module import resolution"
))
<*> option str
( long "output"
<> short 'o'
@@ -150,12 +195,6 @@ compileParser = ArboricxCompile
<> 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"
))
importParser :: Parser TricuArgs
importParser = ArboricxImport
@@ -167,10 +206,16 @@ importParser = ArboricxImport
<> help "Bundle file to import"
)
<*> optional (option str
( long "db"
<> short 'd'
( long "store"
<> short 's'
<> metavar "PATH"
<> help "Content store database path"
<> help "Content-addressed store path"
))
<*> optional (option str
( long "module"
<> short 'm'
<> metavar "NAME"
<> help "Module alias to create for the imported bundle (defaults to bundle file basename)"
))
exportParser :: Parser TricuArgs
@@ -181,6 +226,12 @@ exportParser = ArboricxExport
<> metavar "TARGET"
<> help "Target hash or name (repeatable)"
))
<*> many (option str
( long "module"
<> short 'm'
<> metavar "MODULE"
<> help "Module alias or manifest hash to export (repeatable; bundle export only)"
))
<*> option str
( long "output"
<> short 'o'
@@ -195,16 +246,54 @@ exportParser = ArboricxExport
<> help "Export name(s) for the bundle manifest (repeatable)"
))
<*> optional (option str
( long "db"
<> short 'd'
( long "store"
<> short 's'
<> metavar "PATH"
<> help "Content store database path"
<> help "Content-addressed store path"
))
<*> switch
( long "dag"
<> help "Export as a topologically-sorted DAG node table instead of a bundle"
)
aliasKindReader :: ReadM AliasKind
aliasKindReader = eitherReader $ \s -> case s of
"names" -> Right NameAlias
"name" -> Right NameAlias
"modules" -> Right ModuleAlias
"module" -> Right ModuleAlias
"packages" -> Right PackageAlias
"package" -> Right PackageAlias
_ -> Left "alias kind must be one of: names, modules, packages"
storePathParser :: Parser (Maybe FilePath)
storePathParser = optional (option str
( long "store"
<> short 's'
<> metavar "PATH"
<> help "Content-addressed store path"
))
aliasKindParser :: Parser AliasKind
aliasKindParser = option aliasKindReader
( long "kind"
<> short 'k'
<> metavar "KIND"
<> value NameAlias
<> help "Alias kind: names, modules, packages (default: names)"
)
storeAliasListParser :: Parser TricuArgs
storeAliasListParser = StoreAliasList
<$> aliasKindParser
<*> storePathParser
storeAliasGetParser :: Parser TricuArgs
storeAliasGetParser = StoreAliasGet
<$> aliasKindParser
<*> argument str (metavar "NAME")
<*> storePathParser
versionStr :: String
versionStr = "tricu " ++ showVersion version
@@ -213,10 +302,14 @@ tricuParser = (subparser topCommands <|> pure Repl)
<**> infoOption versionStr (long "version" <> help "Show version")
where
topCommands = mconcat
[ command "eval" (info (evalParser <**> helper)
[ command "check" (info (checkParser <**> helper)
(progDesc "Check View Contract annotations and report ok or diagnostics"))
, 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"))
, command "store" (info (storeParser <**> helper)
(progDesc "Inspect and manage the content-addressed store"))
]
arboricxParser :: Parser TricuArgs
@@ -229,6 +322,20 @@ arboricxParser = subparser $ mconcat
(progDesc "Export one or more terms from the content store"))
]
storeParser :: Parser TricuArgs
storeParser = subparser $ mconcat
[ command "alias" (info (storeAliasParser <**> helper)
(progDesc "Inspect workspace aliases"))
]
storeAliasParser :: Parser TricuArgs
storeAliasParser = subparser $ mconcat
[ command "list" (info (storeAliasListParser <**> helper)
(progDesc "List aliases by kind"))
, command "get" (info (storeAliasGetParser <**> helper)
(progDesc "Resolve an alias by kind and name"))
]
-- ---------------------------------------------------------------------------
-- Entry point
-- ---------------------------------------------------------------------------
@@ -242,10 +349,13 @@ main = do
)
case args of
Repl -> runRepl
Check {} -> runCheck args
Eval {} -> runEval args
ArboricxCompile {} -> runCompile args
ArboricxImport {} -> runImport args
ArboricxExport {} -> runExport args
StoreAliasList {} -> runStoreAliasList args
StoreAliasGet {} -> runStoreAliasGet args
-- ---------------------------------------------------------------------------
@@ -258,25 +368,40 @@ runRepl = do
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
repl
runCheck :: TricuArgs -> IO ()
runCheck opts = do
output <- case checkStore opts of
Nothing -> checkFile (checkInput opts)
Just storePath -> checkFileWithStore (StorePath storePath) (checkInput opts)
putStrLn output
evaluateCheckedIOFile :: StorePath -> ContractMode -> Env -> FilePath -> IO Env
evaluateCheckedIOFile store mode env filePath = do
loaded <- loadFileWithStoreMode mode store filePath
checkedAst <- case instrumentIOContinuations (loadedAst loaded) of
Left err -> die err
Right asts -> pure asts
viewEnv <- evaluateFileWithStore (Just store) "./lib/view.tri"
pure $ evalTricu (Map.unions [viewEnv, loadedImports loaded, env]) checkedAst
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)
let env = evalTricu Map.empty (parseTricu input)
return $ result env
_ -> do
finalEnv <- foldM (evaluateFileWithStore mconn) Map.empty files
mStoreOpt <- traverse (pure . StorePath) (evalStore opts)
let contractMode = if evalUnchecked opts then IgnoreContracts else EnforceContracts
finalEnv <- if evalIo opts && contractMode == EnforceContracts
then do
store <- maybe defaultStorePath pure mStoreOpt
foldM (evaluateCheckedIOFile store contractMode) Map.empty files
else foldM (evaluateFileWithContextWithStoreAndMode contractMode mStoreOpt) Map.empty files
return $ mainResult finalEnv
finalT <- if evalIo opts
then do
@@ -291,9 +416,6 @@ runEval opts = do
Left err -> die $ "IO error: " ++ err
Right val -> pure val
else return resultT
case mconn of
Just conn -> close conn
Nothing -> return ()
writeOutput out (formatT form finalT)
runCompile :: TricuArgs -> IO ()
@@ -301,20 +423,35 @@ runCompile opts = do
let input = compileInput opts
out = compileOutput opts
names = compileNames opts
mStore = StorePath <$> compileStore 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
compileFileWithStore mStore 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 <- map T.unpack <$> importBundle conn (BL.toStrict bundleData)
putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
mapM_ (\r -> putStrLn $ " " ++ r) roots
store <- resolveStorePath (importStore opts)
bundleData <- BL.readFile file
roots <- unpackBundleToStore store (BL.toStrict bundleData)
mapM_ (\(name, root) ->
writeAlias store NameAlias name (treeTermRef root)) roots
let manifest = ModuleManifest []
[ ModuleExport
name
(treeTermRef root)
"arboricx.abi.tree.v1"
Nothing
| (name, root) <- roots
]
moduleName = T.pack $ maybe (takeBaseName file) id (importModule opts)
manifestHash <- putManifest store manifest
writeAlias store ModuleAlias moduleName (ObjectRef (unDomain manifestDomain) manifestHash)
putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
mapM_ (\(name, root) -> putStrLn $ " " ++ T.unpack name ++ " -> " ++ T.unpack root) roots
putStrLn $ "Created module alias " ++ T.unpack moduleName ++ " -> " ++ T.unpack manifestHash
runExport :: TricuArgs -> IO ()
runExport opts =
@@ -325,37 +462,53 @@ runExport opts =
runExportBundle :: TricuArgs -> IO ()
runExportBundle opts = do
let targets = exportTargets opts
modules = exportModules 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
terms <- mapM (\t -> do
(h, _) <- resolveExportTarget conn t
maybeTree <- loadTree conn h
case maybeTree of
Nothing -> die $ "Term not found in store: " ++ t
Just tree -> return tree) targets
let expNames = if null names
then defaultExportNames (length terms)
else map T.pack names
when (length expNames /= length terms) $
die "tricu arboricx export: number of --name values must match number of TARGETs"
let namedTerms = zip expNames terms
bundle = buildBundle namedTerms
bundleData = encodeBundle bundle
BL.writeFile out (BL.fromStrict bundleData)
putStrLn $ "Exported bundle with " ++ show (length namedTerms) ++ " export(s) to " ++ out
putStrLn $ " nodes: " ++ show (Seq.length (bundleNodes bundle))
putStrLn $ " size: " ++ show (BS.length bundleData) ++ " bytes"
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"
store <- resolveStorePath (exportStore opts)
targetRoots <- mapM (resolveStoreTarget store) targets
moduleRoots <- concat <$> mapM (resolveModuleExports store) modules
let targetEntries = zip (defaultExportNames (length targetRoots)) targetRoots
entries = targetEntries ++ moduleRoots
expNames = if null names then map fst entries else map T.pack names
when (length expNames /= length entries) $
die "tricu arboricx export: number of --name values must match number of exported roots"
bundle <- packBundleFromStore store (zip expNames (map snd entries))
let bundleData = encodeBundle bundle
BL.writeFile out (BL.fromStrict bundleData)
putStrLn $ "Exported bundle with " ++ show (length entries) ++ " export(s) to " ++ out
putStrLn $ " nodes: " ++ show (Seq.length (bundleNodes bundle))
putStrLn $ " size: " ++ show (BS.length bundleData) ++ " bytes"
runStoreAliasList :: TricuArgs -> IO ()
runStoreAliasList opts = do
store <- resolveStorePath (storePathOpt opts)
aliases <- listAliases store (storeAliasKind opts)
mapM_ (\(name, ref) -> putStrLn $ T.unpack name ++ " -> " ++ formatObjectRef ref) aliases
runStoreAliasGet :: TricuArgs -> IO ()
runStoreAliasGet opts = do
store <- resolveStorePath (storePathOpt opts)
mRef <- readAlias store (storeAliasKind opts) (T.pack $ storeAliasName opts)
case mRef of
Nothing -> die $ "alias not found: " ++ storeAliasName opts
Just ref -> putStrLn $ storeAliasName opts ++ " -> " ++ formatObjectRef ref
runExportDag :: TricuArgs -> IO ()
runExportDag opts = do
let targets = exportTargets opts
modules = exportModules opts
out = exportOutput opts
unless (null modules) $
die "tricu arboricx export --dag: --module is only supported for bundle export"
case targets of
[target] -> withContentStore (exportDb opts) $ \conn -> do
maybeTerm <- loadTerm conn target
[target] -> do
store <- resolveStorePath (exportStore opts)
root <- resolveStoreTarget store target
maybeTerm <- getTreeTerm store root
case maybeTerm of
Nothing -> die $ "Term not found: " ++ target
Just term -> do
@@ -371,12 +524,54 @@ runExportDag opts = do
-- Helpers
-- ---------------------------------------------------------------------------
withContentStore :: Maybe FilePath -> (Connection -> IO a) -> IO a
withContentStore mPath act = do
conn <- initContentStoreWithPath mPath
result <- act conn
close conn
return result
resolveStorePath :: Maybe FilePath -> IO StorePath
resolveStorePath (Just path) = return (StorePath path)
resolveStorePath Nothing = do
home <- getHomeDirectory
return (StorePath (home </> ".tricu" </> "store"))
treeTermRef :: ObjectHash -> ObjectRef
treeTermRef = ObjectRef (unDomain treeTermDomain)
resolveStoreTarget :: StorePath -> String -> IO ObjectHash
resolveStoreTarget store target = do
mAlias <- readAlias store NameAlias (T.pack target)
let root = maybe (T.pack target) objectRefHash mAlias
mTree <- getTreeTerm store root
case mTree of
Just _ -> return root
Nothing -> die $ "Term not found in store: " ++ target
resolveModuleExports :: StorePath -> String -> IO [(T.Text, ObjectHash)]
resolveModuleExports store moduleTarget = do
manifestHash <- resolveModuleManifestHash store moduleTarget
mManifest <- getManifest store manifestHash
manifest <- case mManifest of
Nothing -> die $ "Module manifest not found in store: " ++ moduleTarget
Just value -> return value
mapM exportEntry (moduleManifestExports manifest)
where
exportEntry ex = do
let ref = moduleExportObject ex
unless (objectRefKind ref == unDomain treeTermDomain) $
die $ "Unsupported module export object kind for " ++ T.unpack (moduleExportName ex) ++ ": " ++ T.unpack (objectRefKind ref)
mTree <- getTreeTerm store (objectRefHash ref)
case mTree of
Nothing -> die $ "Module export tree term not found: " ++ T.unpack (moduleExportName ex)
Just _ -> return (moduleExportName ex, objectRefHash ref)
resolveModuleManifestHash :: StorePath -> String -> IO ObjectHash
resolveModuleManifestHash store moduleTarget = do
mAlias <- readAlias store ModuleAlias (T.pack moduleTarget)
case mAlias of
Just ref -> do
unless (objectRefKind ref == unDomain manifestDomain) $
die $ "Module alias does not point at a module manifest: " ++ moduleTarget
return (objectRefHash ref)
Nothing -> return (T.pack moduleTarget)
formatObjectRef :: ObjectRef -> String
formatObjectRef ref = T.unpack (objectRefKind ref) ++ " " ++ T.unpack (objectRefHash ref)
writeOutput :: FilePath -> String -> IO ()
writeOutput path content