Initial JS runtime and Arborix Implementation

2026-05-06 11:30:31 -05:00
parent fe453b9b96
commit 0cd849447f
24 changed files with 1865 additions and 104 deletions
--- a/src/ContentStore.hs
+++ b/src/ContentStore.hs
@@ -9,6 +9,7 @@ import Data.Maybe                     (catMaybes, fromMaybe)
 import Data.Text                      (Text)
 import Database.SQLite.Simple
 import System.Directory               (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))
+import System.Environment             (getEnv, lookupEnv)
 import System.FilePath                ((</>), takeDirectory)

 import qualified Data.Map             as Map
@@ -71,8 +72,12 @@ newContentStore = do

 getContentStorePath :: IO FilePath
 getContentStorePath = do
-  dataDir <- getXdgDirectory XdgData "tricu"
-  return $ dataDir </> "content-store.db"
+  maybeLocalPath <- lookupEnv "TRICU_DB_PATH"
+  case maybeLocalPath of
+    Just p -> return p
+    Nothing -> do
+      dataDir <- getXdgDirectory XdgData "tricu"
+      return $ dataDir </> "content-store.db"



--- a/src/FileEval.hs
+++ b/src/FileEval.hs
@@ -1,18 +1,32 @@
-module FileEval where
+module FileEval
+  ( preprocessFile
+  , evaluateFile
+  , evaluateFileWithContext
+  , evaluateFileResult
+  , evaluateFile
+  , compileFile
+  ) where

-import Eval
+import Eval (evalTricu)
 import Lexer
 import Parser
 import Research
+import ContentStore (initContentStore, storeTerm, hashTerm)
+import Wire (exportNamedBundle)

 import Control.Monad   ()
 import Data.List       (partition)
-import Data.Maybe      (mapMaybe)
+import Data.Maybe      (fromMaybe, mapMaybe)
+import System.Environment (setEnv)
 import System.FilePath (takeDirectory, normalise, (</>))
-import System.IO ()
+import System.IO (hPutStrLn, stderr)
+import System.Exit (die)
+import Database.SQLite.Simple (Connection, close)

+import qualified Data.ByteString.Lazy as BL
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import qualified Data.Text as T

 extractMain :: Env -> Either String T
 extractMain env =
@@ -152,3 +166,26 @@ isPrefixed name = '.' `elem` name
 nsVariable :: String -> String -> String
 nsVariable "" name = name
 nsVariable moduleName name = moduleName ++ "." ++ name
+
+-- | Compile a tricu source file to a standalone Arborix bundle.
+-- Uses a temp content store so it does not collide with the global one.
+compileFile :: FilePath -> FilePath -> Maybe T.Text -> IO ()
+compileFile inputPath outputPath maybeExportName = do
+  -- Evaluate the file to get the full environment
+  env <- evaluateFile inputPath
+  -- Look up the export name: prefer explicit, then fall back to "main"
+  let name = fromMaybe "main" (T.unpack <$> maybeExportName)
+  case Map.lookup name env of
+    Nothing -> die $ "No definition '" ++ name ++ "' found in " ++ inputPath
+    Just term -> do
+      -- Create a temp content store
+      setEnv "TRICU_DB_PATH" "/tmp/tricu-compile.db"
+      conn <- initContentStore
+      -- Store the term in the temp store
+      _ <- storeTerm conn [name] term
+      -- Export the bundle (exportNamedBundle returns already-encoded bytes)
+      bundleData <- exportNamedBundle conn [(T.pack name, hashTerm term)]
+      BL.writeFile outputPath (BL.fromStrict bundleData)
+      close conn
+      putStrLn $ "Compiled " ++ inputPath ++ " -> " ++ outputPath
+      putStrLn $ "  export: " ++ name
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,6 +1,6 @@
 module Main where

-import ContentStore (initContentStore, termNames, hashToTerm, parseNameList)
+import ContentStore (getContentStorePath, initContentStore, termNames, hashToTerm, loadEnvironment, parseNameList)
 import Eval                   (evalTricu, mainResult, result)
 import FileEval
 import Parser                 (parseTricu)
@@ -16,6 +16,7 @@ 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 System.Exit            (die)
 import Text.Megaparsec        ()
@@ -30,6 +31,7 @@ data TricuArgs
  = Repl
  | Evaluate { file :: [FilePath], form :: EvaluatedForm }
  | TDecode { file :: [FilePath] }
+  | Compile { inputFile :: FilePath, outFile :: FilePath, exportNameOpt :: String }
  | Export { hash :: String, exportNameOpt :: String, outFile :: FilePath }
  | Import { inFile :: FilePath }
  deriving (Show, Data, Typeable)
@@ -86,10 +88,23 @@ importMode = Import
  &= explicit
  &= name "import"

+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"
+  , exportNameOpt = def &= help "Definition name to use as the bundle root. Defaults to 'main'."
+                      &= name "x" &= typ "NAME"
+  }
+  &= help "Compile a tricu source file into a standalone Arborix portable bundle."
+  &= explicit
+  &= name "compile"
+
 main :: IO ()
 main = do
  let versionStr = "tricu Evaluator and REPL " ++ showVersion version
-  cmdArgsParsed <- cmdArgs $ modes [replMode, evaluateMode, decodeMode, exportMode, importMode]
+  cmdArgsParsed <- cmdArgs $ modes [replMode, evaluateMode, decodeMode, compileMode, exportMode, importMode]
    &= help "tricu: Exploring Tree Calculus"
    &= program "tricu"
    &= summary versionStr
@@ -100,10 +115,26 @@ main = do
      putStrLn "You may exit with `CTRL+D` or the `!exit` command."
      repl
    Evaluate { file = filePaths, form = outputForm } -> do
+      maybeDbPath <- lookupEnv "TRICU_DB_PATH"
      evalResult <- case filePaths of
-        [] -> runTricuT <$> getContents
+        [] -> do
+            initialEnv <- case maybeDbPath of
+              Just dbPath -> do
+                conn <- initContentStore
+                env <- loadEnvironment conn
+                close conn
+                return env
+              Nothing -> return Map.empty
+            input <- getContents
+            pure $ runTricuTEnv initialEnv input
        (filePath:restFilePaths) -> do
-            initialEnv <- evaluateFile filePath
+            initialEnv <- case maybeDbPath of
+              Just _ -> do
+                conn <- initContentStore
+                env <- loadEnvironment conn
+                close conn
+                return env
+              Nothing -> return Map.empty
            finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
            pure $ mainResult finalEnv
      let fRes = formatT outputForm evalResult
@@ -128,6 +159,9 @@ main = do
      putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
      mapM_ (\r -> putStrLn $ "  " ++ unpack r) roots
      close conn
+    Compile { inputFile = inputFile', outFile = outFile', exportNameOpt = exportNameArg } ->
+      let exportName = if null exportNameArg then Nothing else Just (T.pack exportNameArg)
+      in compileFile inputFile' outFile' exportName

 runTricu :: String -> String
 runTricu = formatT TreeCalculus . runTricuT
--- a/src/Wire.hs
+++ b/src/Wire.hs
@@ -64,7 +64,7 @@ bundleMinorVersion = 0

 -- | Header magic for the portable executable-object container.
 bundleMagic :: ByteString
-bundleMagic = BS.pack [0x54, 0x52, 0x49, 0x43, 0x55, 0x42, 0x4e, 0x44] -- "TRICUBND"
+bundleMagic = BS.pack [0x41, 0x52, 0x42, 0x4f, 0x52, 0x49, 0x58, 0x00] -- "ARBORIX\0"

 headerLength :: Int
 headerLength = 32
@@ -83,13 +83,6 @@ compressionNone, digestSha256 :: Word16
 compressionNone = 0
 digestSha256 = 1

-- | Backwards compatibility for the original experimental node-list format.
-legacyMagic :: ByteString
-legacyMagic = BS.pack [0x54, 0x52, 0x49, 0x43, 0x55] -- "TRICU"
-
-legacyWireVersion :: Word8
-legacyWireVersion = 0x01
-
 -- | Closure declaration. V1 only accepts complete bundles for import.
 data ClosureMode = ClosureComplete | ClosurePartial
  deriving (Show, Eq, Ord, Generic)
@@ -200,7 +193,7 @@ instance FromJSON BundleExport where
    <$> o .: "name"
    <*> o .: "root"
    <*> o .:? "kind" .!= "term"
-    <*> o .:? "abi" .!= "tricu.abi.tree.v1"
+    <*> o .:? "abi" .!= "arborix.abi.tree.v1"
    <*> o .:? "input"
    <*> o .:? "output"

@@ -302,12 +295,10 @@ encodeBundle bundle =
        (fromIntegral sectionCount) 0 dirOffset
  in header <> manifestEntry <> nodesEntry <> manifestBytes <> nodeSection

-- | Decode portable Bundle v1 bytes, with fallback support for the previous
-- experimental TRICU node-list format.
+-- | Decode portable Bundle v1 bytes.
 decodeBundle :: ByteString -> Either String Bundle
 decodeBundle bs
  | BS.take (BS.length bundleMagic) bs == bundleMagic = decodePortableBundle bs
-  | BS.take (BS.length legacyMagic) bs == legacyMagic = decodeLegacyBundle bs
  | otherwise = Left "invalid magic"

 -- ---------------------------------------------------------------------------
@@ -439,20 +430,20 @@ decodeSectionEntries count bytes = reverse <$> go count bytes []

 defaultManifest :: [(Text, MerkleHash)] -> Int -> BundleManifest
 defaultManifest namedRoots nodeCount = BundleManifest
-  { manifestSchema = "tricu.bundle.manifest.v1"
+  { manifestSchema = "arborix.bundle.manifest.v1"
  , manifestBundleType = "tree-calculus-executable-object"
  , manifestTree = TreeSpec
      { treeCalculus = "tree-calculus.v1"
      , treeNodeHash = NodeHashSpec
          { nodeHashAlgorithm = "sha256"
-          , nodeHashDomain = "tricu.merkle.node.v1"
+          , nodeHashDomain = "arborix.merkle.node.v1"
          }
-      , treeNodePayload = "tricu.merkle.payload.v1"
+      , treeNodePayload = "arborix.merkle.payload.v1"
      }
  , manifestRuntime = RuntimeSpec
      { runtimeSemantics = "tree-calculus.v1"
      , runtimeEvaluation = "normal-order"
-      , runtimeAbi = "tricu.abi.tree.v1"
+      , runtimeAbi = "arborix.abi.tree.v1"
      , runtimeCapabilities = []
      }
  , manifestClosure = ClosureComplete
@@ -462,7 +453,7 @@ defaultManifest namedRoots nodeCount = BundleManifest
  , manifestSections = object
      [ "nodes" .= object
          [ "count" .= nodeCount
-          , "payload" .= ("tricu.merkle.payload.v1" :: Text)
+          , "payload" .= ("arborix.merkle.payload.v1" :: Text)
          ]
      ]
  , manifestMetadata = BundleMetadata
@@ -470,7 +461,7 @@ defaultManifest namedRoots nodeCount = BundleManifest
      , metadataVersion = Nothing
      , metadataDescription = Nothing
      , metadataLicense = Nothing
-      , metadataCreatedBy = Just "tricu"
+      , metadataCreatedBy = Just "arborix"
      }
  }
  where
@@ -480,7 +471,7 @@ defaultManifest namedRoots nodeCount = BundleManifest
      { exportName = name
      , exportRoot = h
      , exportKind = "term"
-      , exportAbi = "tricu.abi.tree.v1"
+      , exportAbi = "arborix.abi.tree.v1"
      , exportInput = Nothing
      , exportOutput = Nothing
      }
@@ -529,59 +520,7 @@ decodeNodeEntries count bs = go count bs Map.empty
                Left $ "duplicate node entry: " ++ unpack h
              go (n - 1) after (Map.insert h payload acc)

-- ---------------------------------------------------------------------------
-- Legacy bundle decoding (read-only compatibility)
-- ---------------------------------------------------------------------------

-decodeLegacyBundle :: ByteString -> Either String Bundle
-decodeLegacyBundle bs
-  | BS.length bs < 14 = Left "bundle too short"
-  | BS.take 5 bs /= legacyMagic = Left "invalid legacy magic"
-  | BS.index bs 5 /= legacyWireVersion =
-      Left $ "unsupported legacy wire version: " ++ show (BS.index bs 5)
-  | otherwise = do
-      (rootCount, rest) <- decode32be "root_count" $ BS.drop 6 bs
-      (nodeCount, rest') <- decode32be "node_count" rest
-      let rootBytesLen = fromIntegral rootCount * 32
-      if BS.length rest' < rootBytesLen
-        then Left "bundle truncated in root hashes"
-        else do
-          let rawRoots = BS.take rootBytesLen rest'
-              afterRoots = BS.drop rootBytesLen rest'
-              roots =
-                [ rawToMerkleHash (BS.take 32 (BS.drop (i * 32) rawRoots))
-                | i <- [0 :: Int .. fromIntegral rootCount - 1]
-                ]
-              namedRoots = zip (defaultExportNames $ length roots) roots
-          nodes <- decodeLegacyNodeEntries nodeCount afterRoots
-          let manifest = defaultManifest namedRoots (Map.size nodes)
-          return Bundle
-            { bundleVersion = 1
-            , bundleRoots = roots
-            , bundleNodes = nodes
-            , bundleManifest = manifest
-            , bundleManifestBytes = BL.toStrict (encode manifest)
-            }
-
-decodeLegacyNodeEntries :: Word32 -> ByteString -> Either String (Map MerkleHash ByteString)
-decodeLegacyNodeEntries count bs = fst <$> go count bs Map.empty
-  where
-    go 0 rest acc = Right (acc, rest)
-    go n bytes acc
-      | BS.length bytes < 36 =
-          Left "not enough bytes for node entry header (hash + length)"
-      | otherwise = do
-          let (hashBytes, rest) = BS.splitAt 32 bytes
-          (plen, rest') <- decode32be "payload_len" rest
-          let payloadLen = fromIntegral plen
-          if BS.length rest' < payloadLen
-            then Left "payload extends beyond legacy bundle end"
-            else do
-              let (payload, after) = BS.splitAt payloadLen rest'
-                  h = rawToMerkleHash hashBytes
-              when (Map.member h acc) $
-                Left $ "duplicate node entry: " ++ unpack h
-              go (n - 1) after (Map.insert h payload acc)

 -- ---------------------------------------------------------------------------
 -- Bundle verification
@@ -611,7 +550,7 @@ verifyBundle bundle = do

 verifyManifest :: BundleManifest -> Either String ()
 verifyManifest manifest = do
-  when (manifestSchema manifest /= "tricu.bundle.manifest.v1") $
+  when (manifestSchema manifest /= "arborix.bundle.manifest.v1") $
    Left $ "unsupported manifest schema: " ++ unpack (manifestSchema manifest)
  when (manifestBundleType manifest /= "tree-calculus-executable-object") $
    Left $ "unsupported bundle type: " ++ unpack (manifestBundleType manifest)
@@ -622,13 +561,13 @@ verifyManifest manifest = do
    Left $ "unsupported calculus: " ++ unpack (treeCalculus treeSpec)
  when (nodeHashAlgorithm hashSpec /= "sha256") $
    Left $ "unsupported node hash algorithm: " ++ unpack (nodeHashAlgorithm hashSpec)
-  when (nodeHashDomain hashSpec /= "tricu.merkle.node.v1") $
+  when (nodeHashDomain hashSpec /= "arborix.merkle.node.v1") $
    Left $ "unsupported node hash domain: " ++ unpack (nodeHashDomain hashSpec)
-  when (treeNodePayload treeSpec /= "tricu.merkle.payload.v1") $
+  when (treeNodePayload treeSpec /= "arborix.merkle.payload.v1") $
    Left $ "unsupported node payload: " ++ unpack (treeNodePayload treeSpec)
  when (runtimeSemantics runtimeSpec /= "tree-calculus.v1") $
    Left $ "unsupported runtime semantics: " ++ unpack (runtimeSemantics runtimeSpec)
-  when (runtimeAbi runtimeSpec /= "tricu.abi.tree.v1") $
+  when (runtimeAbi runtimeSpec /= "arborix.abi.tree.v1") $
    Left $ "unsupported runtime ABI: " ++ unpack (runtimeAbi runtimeSpec)
  unless (null $ runtimeCapabilities runtimeSpec) $
    Left "host/runtime capabilities are not supported by bundle v1"