commit 38e85b4a5e328be257e4de84a368fa0e643378e6
parent 37e852e6e348fcf4245fa47b4d46879de6dbb63c
Author: James Eversole <james@eversole.co>
Date: Wed, 14 Oct 2026 15:37:01 -0500
Separate source-free runtime from recovery frontend
Diffstat:
20 files changed, 436 insertions(+), 339 deletions(-)
diff --git a/AGENTS.md b/AGENTS.md
@@ -112,3 +112,7 @@ head (map f xs) → From lib/base.tri
-- line comment
```
+
+## Agent Coordination
+
+You are only permitted to use `intercom` or agent orchestration tools available to you with *explicit user approval*.
diff --git a/docs/compiler.md b/docs/compiler.md
@@ -180,7 +180,15 @@ complete-interface cache rules.
## Haskell evaluation boundary
-`Research.T` has lazy constructor fields, and `Research.apply` implements the
+The production host imports `Runtime`, whose implementation is split into
+`Runtime.Tree` (trees/reduction), `Runtime.Value` (canonical values),
+`Runtime.Presentation` (display), and `Runtime.Merkle` (native DAG helpers).
+`Research` is a recovery-only facade containing the historical Haskell frontend
+syntax. Tests and benchmarks still use it; the installed executable does not.
+The `ast` display format renders tree constructors directly, without constructing
+source ASTs.
+
+`Runtime.Tree.T` has lazy constructor fields, and `Runtime.Tree.apply` implements the
kernel rules without an explicit application/thunk node. Pending reductions
live in Haskell thunks. Constructor application returns an outer Stem/Fork without
forcing its children; constant application ignores its discarded argument;
diff --git a/docs/validation.md b/docs/validation.md
@@ -7,6 +7,14 @@ For representation-sensitive work, see [Compiler architecture](compiler.md.html)
## Fast gates
+The normal Nix host package builds from inputs that exclude `Research`, the
+Haskell lexer/parser/compiler/source loader, and recovery workspace resolution.
+This makes accidental production dependencies on the recovery frontend build
+failures. The test and benchmark components retain those inputs during migration.
+The runtime-presentation tests compare constructor display with the recovery AST
+oracle and an independently written golden; runtime demand tests exercise the
+same extracted reducer used by production.
+
```sh
nix flake check
python3 test/unit.py
diff --git a/flake.nix b/flake.nix
@@ -28,6 +28,18 @@
];
};
+ # The installed host must build with recovery frontend files absent.
+ # Tests/benchmarks deliberately retain them until their migration finishes.
+ runtimeSource = pkgs.lib.cleanSourceWith {
+ src = tricuSource;
+ filter = path: type:
+ !(builtins.any (relative: pkgs.lib.hasSuffix "/${relative}" path) [
+ "src/Research.hs" "src/Eval.hs" "src/FileEval.hs"
+ "src/Lexer.hs" "src/Parser.hs" "src/Frontend"
+ "src/Module/Resolver.hs" "src/Module/Workspace.hs"
+ ]);
+ };
+
haskellPackages = pkgs.haskellPackages;
hsLib = pkgs.haskell.lib;
@@ -38,7 +50,7 @@
tricuMuslStatic =
staticHsLib.justStaticExecutables (
staticHsLib.dontCheck (
- staticHaskellPackages.callCabal2nix packageName tricuSource {}
+ staticHaskellPackages.callCabal2nix packageName runtimeSource {}
)
);
@@ -60,7 +72,7 @@
tricuPackage =
hsLib.dontCheck (
- haskellPackages.callCabal2nix packageName tricuSource {}
+ haskellPackages.callCabal2nix packageName runtimeSource {}
);
# Compile once with the packaged stable compiler. Runtime needs neither
@@ -314,6 +326,15 @@
packages.tricu-js = tricuJs;
packages.tricu-js-tests = tricuJsTests;
+ checks.runtimeBoundary = pkgs.runCommand "tricu-runtime-source-boundary" {} ''
+ test -f ${runtimeSource}/src/Runtime/Tree.hs
+ for path in Research.hs Eval.hs FileEval.hs Lexer.hs Parser.hs \
+ Frontend Module/Resolver.hs Module/Workspace.hs; do
+ test ! -e "${runtimeSource}/src/$path"
+ done
+ mkdir -p $out
+ '';
+
checks.${packageName} = tricuPackageTests;
checks.default = tricuPackageTests;
# Fast packaging/filesystem checks only, no compiler or application runs.
diff --git a/src/ContentStore/Arboricx.hs b/src/ContentStore/Arboricx.hs
@@ -16,7 +16,7 @@ module ContentStore.Arboricx
import ContentStore.Filesystem
import ContentStore.Object
-import Research
+import Runtime
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
diff --git a/src/ContentStore/Bundle.hs b/src/ContentStore/Bundle.hs
@@ -18,7 +18,7 @@ import ContentStore.Arboricx
import ContentStore.Alias (ObjectRef(..))
import ContentStore.Object
import ContentStore.Filesystem (putObject, objectPath, getVerifiedObject)
-import Research (T)
+import Runtime (T)
import Wire
import Control.Monad (foldM, forM, forM_, unless)
diff --git a/src/ContentStore/Resolver.hs b/src/ContentStore/Resolver.hs
@@ -12,8 +12,8 @@ import ContentStore.Arboricx
import ContentStore.Filesystem
import ContentStore.Object
import Module.Manifest
-import Research (Node(..), T, deserializeNode)
-import qualified Research
+import Runtime (Node(..), T, deserializeNode)
+import qualified Runtime
import Data.ByteString (ByteString)
import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef')
@@ -104,12 +104,12 @@ resolveTreeFromObjects resolver h = do
Nothing -> return Nothing
Just bytes -> return (Just (deserializeNode bytes))
- hydrate NLeaf = return (Just Research.Leaf)
- hydrate (NStem child) = fmap Research.Stem <$> hydrateHash child
+ hydrate NLeaf = return (Just Runtime.Leaf)
+ hydrate (NStem child) = fmap Runtime.Stem <$> hydrateHash child
hydrate (NFork left right) = do
l <- hydrateHash left
r <- hydrateHash right
- return $ Research.Fork <$> l <*> r
+ return $ Runtime.Fork <$> l <*> r
hydrateHash nodeHash = do
mChild <- resolveNode resolver nodeHash
diff --git a/src/IODriver.hs b/src/IODriver.hs
@@ -13,7 +13,7 @@ module IODriver
, runIOWithYieldStatsHook
) where
-import Research (T(..), EvaluatedForm(Decode), formatT, apply, toString, toNumber, ofString, ofNumber, ofBytes, toBytes, ofList)
+import Runtime (T(..), EvaluatedForm(Decode), formatT, apply, toString, toNumber, ofString, ofNumber, ofBytes, toBytes, ofList)
import ContentStore.Arboricx (treeTermDomain, decodeTreeTermShared, encodeTreeTerm)
import ContentStore.Object (hashObject)
import ContentStore.Bundle (indexedTreeDomain, decodeIndexedTree, encodeIndexedTree)
diff --git a/src/Main.hs b/src/Main.hs
@@ -11,7 +11,7 @@ import Module.Manifest
import System.Exit (die, exitFailure)
import IODriver (IOPermissions(..), runIO, YieldStats(..), runIOWithYieldStatsHook)
import REPL (portableRepl)
-import Research (T(..), EvaluatedForm(..), formatT, exportDag, apply, ofString, ofNumber, toString)
+import Runtime (T(..), EvaluatedForm(..), formatT, exportDag, apply, ofString, ofNumber, toString)
import qualified Wire
import Wire (encodeBundle, buildBundleShared, defaultExportNames, Bundle(..))
import TreeObservation (forceTreeShared)
@@ -974,10 +974,10 @@ loadVerifiedManifest store manifestHash = do
(decodeManifest manifestPayload)
pure manifest
-loadVerifiedExport :: StorePath -> T.Text -> T.Text -> IO (ObjectHash, Research.T)
+loadVerifiedExport :: StorePath -> T.Text -> T.Text -> IO (ObjectHash, Runtime.T)
loadVerifiedExport = loadVerifiedExportWith (const $ pure ())
-loadVerifiedExportWith :: (String -> IO ()) -> StorePath -> T.Text -> T.Text -> IO (ObjectHash, Research.T)
+loadVerifiedExportWith :: (String -> IO ()) -> StorePath -> T.Text -> T.Text -> IO (ObjectHash, Runtime.T)
loadVerifiedExportWith sample store manifestHash name = do
manifest <- loadVerifiedManifest store manifestHash
sample "manifest-verified"
@@ -1027,7 +1027,7 @@ packagedCompiler store = do
[ModuleExport name (ObjectRef (unDomain indexedTreeDomain) root)
"arboricx.abi.tree.v1" | (name, root) <- roots])
-portableExports :: CompilerOptions -> Maybe FilePath -> FilePath -> IO [(String, Research.T)]
+portableExports :: CompilerOptions -> Maybe FilePath -> FilePath -> IO [(String, Runtime.T)]
portableExports options selected path = do
(store, pin) <- buildPortableModule options selected path
manifest <- loadVerifiedManifest store pin
@@ -1138,7 +1138,7 @@ profileSample label counts = do
BL.hPutStr stderr "\n"
-- Presentation of the canonical Result envelope; the underlying tree survives.
-renderInvocationResult :: EvaluatedForm -> Research.T -> Either String String
+renderInvocationResult :: EvaluatedForm -> Runtime.T -> Either String String
renderInvocationResult form (Fork (Stem Leaf) (Fork value _)) =
Right $ "ok: " ++ case (form, value) of
(Decode, Leaf) -> "[]"
@@ -1149,7 +1149,7 @@ renderInvocationResult form (Fork Leaf (Fork problem _)) =
_ -> formatT form problem
renderInvocationResult _ _ = Left "Invalid Result envelope; use the tree view to inspect it"
-storedArgument :: StorePath -> StoredArgument -> IO Research.T
+storedArgument :: StorePath -> StoredArgument -> IO Runtime.T
storedArgument _ (StringArgument value) = pure (ofString value)
storedArgument _ (TreeFileArgument path) = do
payload <- BS.readFile path
@@ -1252,7 +1252,7 @@ runExportDag opts = do
store <- resolveStorePath (exportStore opts)
root <- resolveStoreTarget store target
term <- loadExecutableObject store root
- let (rootIdx, nodes) = Research.exportDag term
+ let (rootIdx, nodes) = Runtime.exportDag term
output = unlines $
show rootIdx :
map (\(tag, refs) -> unwords (tag : map show refs)) nodes
diff --git a/src/REPL.hs b/src/REPL.hs
@@ -2,7 +2,7 @@
-- recovery frontend. Each successful submission is a transaction on source state.
module REPL where
-import Research (EvaluatedForm(..), Env, T, formatT)
+import Runtime (EvaluatedForm(..), Env, T, formatT)
import ContentStore (StorePath(..), AliasKind(..), ObjectRef(..), readAlias, unDomain)
import Module.Manifest (manifestDomain)
import Control.Exception (SomeException, AsyncException, catch, displayException, evaluate, fromException, throwIO)
diff --git a/src/Research.hs b/src/Research.hs
@@ -1,23 +1,7 @@
-{-# LANGUAGE PatternSynonyms #-}
+-- Recovery frontend facade. Production modules must import Runtime instead.
+module Research (module Runtime, module Research) where
-module Research where
-
-import Crypto.Hash (hash, SHA256, Digest)
-import Data.ByteArray (convert)
-import Data.ByteString.Base16 (decode, encode)
-import Data.List (intercalate)
-import Data.Map ()
-import Data.Text (Text, replace)
-import Data.Text.Encoding (decodeUtf8, encodeUtf8)
-import Data.Word (Word8)
-import qualified Data.ByteString as BS
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.Text as T
-
--- Tree Calculus Types
-data T = Leaf | Stem T | Fork T T
- deriving (Show, Eq, Ord)
+import Runtime
-- Contract source annotations for @ and =@ syntax. ViewExpr carries the
-- surface syntax of a contract until Frontend.ContractDesugar turns it into a
@@ -87,293 +71,7 @@ data LToken
| LIndent Int
deriving (Eq, Show, Ord)
--- Output formats
-data EvaluatedForm = Tree | FSL | AST | Ternary | Ascii | Decode | Number | StringLit
- deriving (Show)
-
--- Environment containing previously evaluated TC terms
-type Env = Map.Map String T
-
--- Merkle DAG Node types
--- Each Tree Calculus node becomes a content-addressed object.
-type MerkleHash = Text
-
-data Node
- = NLeaf
- | NStem MerkleHash
- | NFork MerkleHash MerkleHash
- deriving (Show, Eq, Ord)
-
--- | Canonical serialization of a Node for hashing.
--- Leaf: 0x00
--- Stem: 0x01 || child_hash (32 bytes)
--- Fork: 0x02 || left_hash (32 bytes) || right_hash (32 bytes)
-serializeNode :: Node -> BS.ByteString
-serializeNode NLeaf = BS.pack [0x00]
-serializeNode (NStem h) = BS.pack [0x01] <> go (decode (encodeUtf8 h))
- where go (Left _) = error "Research.serializeNode: invalid hex hash"
- go (Right bs) = bs
-serializeNode (NFork l r) = BS.pack [0x02] <> go (decode (encodeUtf8 l)) <> go (decode (encodeUtf8 r))
- where go (Left _) = error "Research.serializeNode: invalid hex hash"
- go (Right bs) = bs
-
--- | Hash a node per the Merkle content-addressing spec.
--- hash = SHA256( "arboricx.merkle.node.v1" <> 0x00 <> node_payload )
-nodeHash :: Node -> MerkleHash
-nodeHash node = decodeUtf8 (encode (sha256WithPrefix (serializeNode node)))
- where sha256WithPrefix payload =
- convert . (hash :: BS.ByteString -> Digest SHA256) $ utf8Tag <> BS.pack [0x00] <> payload
- utf8Tag = BS.pack $ map fromIntegral $ BS.unpack "arboricx.merkle.node.v1"
-
--- | Deserialize a Node from canonical bytes.
-deserializeNode :: BS.ByteString -> Node
-deserializeNode bs =
- case BS.uncons bs of
- Just (0x00, rest)
- | BS.null rest -> NLeaf
-
- Just (0x01, rest)
- | BS.length rest == 32 ->
- NStem $ decodeUtf8 (encode rest)
-
- Just (0x02, rest)
- | BS.length rest == 64 ->
- let (l, r) = BS.splitAt 32 rest
- in NFork (decodeUtf8 (encode l)) (decodeUtf8 (encode r))
-
- _ -> errorWithoutStackTrace "invalid merkle node payload"
-
--- ---------------------------------------------------------------------------
--- ByteString / bytestream marshalling via existing Tree Calculus conventions
--- ---------------------------------------------------------------------------
-
--- | Encode a single byte (Word8) as a Tree Calculus number (0..255).
-ofByte :: Word8 -> T
-ofByte = ofNumber . fromIntegral
-
--- | Decode a Tree Calculus number as a single byte (Word8).
--- Rejects values outside the range 0..255.
-toByte :: T -> Either String Word8
-toByte t = case toNumber t of
- Left err -> Left err
- Right n
- | n >= 0 && n <= 255 -> Right (fromIntegral n)
- | otherwise -> Left ("Byte value out of range: " ++ show n)
-
--- | Encode a ByteString as a Tree Calculus list of Byte trees.
-ofBytes :: BS.ByteString -> T
-ofBytes = ofList . map ofByte . BS.unpack
-
--- | Decode a Tree Calculus list of Byte trees as a ByteString.
--- Rejects non-list trees and elements that are not valid byte values (0..255).
-toBytes :: T -> Either String BS.ByteString
-toBytes t = case toList t of
- Left err -> Left err
- Right bs -> BS.pack <$> mapM toByte bs
-
--- | Convert a canonical Arboricx node payload (ByteString) to a Tree
--- representation (a list of Byte trees).
-nodePayloadToTreeBytes :: BS.ByteString -> T
-nodePayloadToTreeBytes = ofBytes
-
--- | Convert a Tree representation of a node payload back to ByteString.
-treeBytesToNodePayload :: T -> Either String BS.ByteString
-treeBytesToNodePayload = toBytes
-
--- | Convert a MerkleHash (hex-encoded) to a Tree of its 32 raw bytes.
-hashToTreeBytes :: MerkleHash -> Either String T
-hashToTreeBytes h = case decode (encodeUtf8 h) of
- Left _ -> Left "Invalid hex MerkleHash"
- Right raw
- | BS.length raw == 32 -> Right (ofBytes raw)
- | otherwise -> Left "Hash raw bytes must be 32 bytes"
-
--- | Convert a Tree of 32 Byte trees back to a MerkleHash (hex string).
-treeBytesToHash :: T -> Either String MerkleHash
-treeBytesToHash t = case toList t of
- Left err -> Left err
- Right bytes
- | length bytes == 32 -> do
- raw <- BS.pack <$> mapM toByte bytes
- Right $ decodeUtf8 (encode raw)
- | otherwise -> Left "Expected exactly 32 byte elements for hash"
-
--- | Build a Merkle DAG from a Tree Calculus term.
-buildMerkle :: T -> Node
-buildMerkle Leaf = NLeaf
-buildMerkle (Stem t) = NStem (nodeHash child)
- where child = buildMerkle t
-buildMerkle (Fork l r) = NFork (nodeHash left) (nodeHash right)
- where
- left = buildMerkle l
- right = buildMerkle r
-
--- Triage Calculus Reduction Rules
-{-
- The t operator is left associative.
- 1. t t a b -> a
- 2. t (t a) b c -> a c (b c)
- 3a. t (t a b) c t -> a
- 3b. t (t a b) c (t u) -> b u
- 3c. t (t a b) c (t u v) -> c u v
--}
-apply :: T -> T -> T
-apply (Fork Leaf a) _ = a
-apply (Fork (Stem a) b) c = apply (apply a c) (apply b c)
-apply (Fork (Fork _a _b) _c) Leaf = _a
-apply (Fork (Fork _a _b) _c) (Stem u) = apply _b u
-apply (Fork (Fork _a _b) _c) (Fork u v) = apply (apply _c u) v
--- Left associative `t`
-apply Leaf b = Stem b
-apply (Stem a) b = Fork a b
-
--- Booleans
-_false :: T
-_false = Leaf
-
-_true :: T
-_true = Stem Leaf
-
-_not :: T
-_not = Fork (Fork _true (Fork Leaf _false)) Leaf
-
--- Marshalling
-ofString :: String -> T
-ofString str = ofList $ map (ofNumber . toInteger . fromEnum) str
-
-ofNumber :: Integer -> T
-ofNumber 0 = Leaf
-ofNumber n =
- Fork
- (if odd n then Stem Leaf else Leaf)
- (ofNumber (n `div` 2))
-
-ofList :: [T] -> T
-ofList = foldr Fork Leaf
-
-toNumber :: T -> Either String Integer
-toNumber Leaf = Right 0
-toNumber (Fork Leaf rest) = case toNumber rest of
- Right n -> Right (2 * n)
- Left err -> Left err
-toNumber (Fork (Stem Leaf) rest) = case toNumber rest of
- Right n -> Right (1 + 2 * n)
- Left err -> Left err
-toNumber _ = Left "Invalid Tree Calculus number"
-
-toChar :: Integer -> Either String Char
-toChar n
- | n < 0 = Left "Negative character code"
- | n > 0x10FFFF = Left "Character code out of Unicode range"
- | n >= 0xD800 && n <= 0xDFFF = Left "Surrogate character code not allowed"
- | otherwise = Right (toEnum (fromInteger n))
-
-toString :: T -> Either String String
-toString tc = do
- list <- toList tc
- nums <- mapM toNumber list
- mapM toChar nums
-
-toList :: T -> Either String [T]
-toList Leaf = Right []
-toList (Fork x rest) = case toList rest of
- Right xs -> Right (x : xs)
- Left err -> Left err
-toList _ = Left "Invalid Tree Calculus list"
-
--- Outputs
-formatT :: EvaluatedForm -> T -> String
-formatT Tree = toSimpleT . show
-formatT FSL = show
-formatT AST = show . toAST
-formatT Ternary = toTernaryString
-formatT Ascii = toAscii
-formatT Decode = decodeResult
-formatT Number = either (\e -> "<not-number: " ++ e ++ ">") show . toNumber
-formatT StringLit = either (\e -> "<not-string: " ++ e ++ ">") show . toString
-
-toSimpleT :: String -> String
-toSimpleT s = T.unpack
- $ replace "Fork" "t"
- $ replace "Stem" "t"
- $ replace "Leaf" "t"
- $ T.pack s
-
-toTernaryString :: T -> String
-toTernaryString Leaf = "0"
-toTernaryString (Stem t) = "1" ++ toTernaryString t
-toTernaryString (Fork t1 t2) = "2" ++ toTernaryString t1 ++ toTernaryString t2
-
toAST :: T -> TricuAST
toAST Leaf = TLeaf
toAST (Stem a) = TStem (toAST a)
toAST (Fork a b) = TFork (toAST a) (toAST b)
-
-toAscii :: T -> String
-toAscii tree = go tree "" True
- where
- go :: T -> String -> Bool -> String
- go Leaf prefix isLast =
- prefix ++ (if isLast then "`-- " else "|-- ") ++ "Leaf\n"
- go (Stem t) prefix isLast =
- prefix ++ (if isLast then "`-- " else "|-- ") ++ "Stem\n"
- ++ go t (prefix ++ (if isLast then " " else "| ")) True
- go (Fork left right) prefix isLast =
- prefix ++ (if isLast then "`-- " else "|-- ") ++ "Fork\n"
- ++ go left (prefix ++ (if isLast then " " else "| ")) False
- ++ go right (prefix ++ (if isLast then " " else "| ")) True
-
-decodeResult :: T -> String
-decodeResult Leaf = "t"
-decodeResult tc =
- case (toString tc, toList tc, toNumber tc) of
- (Right s, _, _) | all isCommonChar s -> "\"" ++ s ++ "\""
- (_, _, Right n) -> show n
- (_, Right xs@(_:_), _) -> "[" ++ intercalate ", " (map decodeResult xs) ++ "]"
- (_, Right [], _) -> "[]"
- _ -> formatT Tree tc
- where
- isCommonChar c =
- let n = fromEnum c
- in (n >= 32 && n <= 126)
- || n == 9
- || n == 10
- || n == 13
-
--- ---------------------------------------------------------------------------
--- DAG node-table export (for host-language kernel embedding)
--- ---------------------------------------------------------------------------
-
--- | Export a term's Merkle DAG as a topologically-sorted node table.
--- Children appear before parents so all index references are forward.
--- Returns (root index, list of (tag, [child_indices])).
-exportDag :: T -> (Int, [(String, [Int])])
-exportDag term =
- let (root, acc, _) = collectDag term [] Set.empty
- -- acc is in reverse post-order (children first, root last)
- ordered = reverse acc
- idxMap = Map.fromList [(h, i) | (i, (h, _)) <- zip [0..] ordered]
- rootIdx = idxMap Map.! root
- lines_ = map (formatNode idxMap . snd) ordered
- in (rootIdx, lines_)
- where
- collectDag :: T -> [(MerkleHash, Node)] -> Set.Set MerkleHash -> (MerkleHash, [(MerkleHash, Node)], Set.Set MerkleHash)
- collectDag Leaf acc seen =
- let h = nodeHash NLeaf
- in if Set.member h seen then (h, acc, seen) else (h, (h, NLeaf) : acc, Set.insert h seen)
- collectDag (Stem t) acc seen =
- let (ch, acc', seen') = collectDag t acc seen
- node = NStem ch
- h = nodeHash node
- in if Set.member h seen' then (h, acc', seen') else (h, (h, node) : acc', Set.insert h seen')
- collectDag (Fork l r) acc seen =
- let (lh, acc', seen') = collectDag l acc seen
- (rh, acc'', seen'') = collectDag r acc' seen'
- node = NFork lh rh
- h = nodeHash node
- in if Set.member h seen'' then (h, acc'', seen'') else (h, (h, node) : acc'', Set.insert h seen'')
-
- formatNode :: Map.Map MerkleHash Int -> Node -> (String, [Int])
- formatNode _ NLeaf = ("leaf", [])
- formatNode idxMap (NStem ch) = ("stem", [idxMap Map.! ch])
- formatNode idxMap (NFork l r) = ("fork", [idxMap Map.! l, idxMap Map.! r])
diff --git a/src/Runtime.hs b/src/Runtime.hs
@@ -0,0 +1,10 @@
+-- Source-free host API. Recovery syntax must never be reexported here.
+module Runtime
+ ( module Runtime.Tree, module Runtime.Value
+ , module Runtime.Presentation, module Runtime.Merkle
+ ) where
+
+import Runtime.Tree
+import Runtime.Value
+import Runtime.Presentation
+import Runtime.Merkle
diff --git a/src/Runtime/Merkle.hs b/src/Runtime/Merkle.hs
@@ -0,0 +1,137 @@
+-- Native Merkle codecs and DAG export, independent of source compilation.
+module Runtime.Merkle where
+
+import Runtime.Tree
+import Runtime.Value
+import Crypto.Hash (hash, SHA256, Digest)
+import Data.ByteArray (convert)
+import Data.ByteString.Base16 (decode, encode)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import qualified Data.ByteString as BS
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+-- Merkle DAG Node types
+-- Each Tree Calculus node becomes a content-addressed object.
+type MerkleHash = Text
+
+data Node
+ = NLeaf
+ | NStem MerkleHash
+ | NFork MerkleHash MerkleHash
+ deriving (Show, Eq, Ord)
+
+-- | Canonical serialization of a Node for hashing.
+-- Leaf: 0x00
+-- Stem: 0x01 || child_hash (32 bytes)
+-- Fork: 0x02 || left_hash (32 bytes) || right_hash (32 bytes)
+serializeNode :: Node -> BS.ByteString
+serializeNode NLeaf = BS.pack [0x00]
+serializeNode (NStem h) = BS.pack [0x01] <> go (decode (encodeUtf8 h))
+ where go (Left _) = error "Runtime.serializeNode: invalid hex hash"
+ go (Right bs) = bs
+serializeNode (NFork l r) = BS.pack [0x02] <> go (decode (encodeUtf8 l)) <> go (decode (encodeUtf8 r))
+ where go (Left _) = error "Runtime.serializeNode: invalid hex hash"
+ go (Right bs) = bs
+
+-- | Hash a node per the Merkle content-addressing spec.
+-- hash = SHA256( "arboricx.merkle.node.v1" <> 0x00 <> node_payload )
+nodeHash :: Node -> MerkleHash
+nodeHash node = decodeUtf8 (encode (sha256WithPrefix (serializeNode node)))
+ where sha256WithPrefix payload =
+ convert . (hash :: BS.ByteString -> Digest SHA256) $ utf8Tag <> BS.pack [0x00] <> payload
+ utf8Tag = BS.pack $ map fromIntegral $ BS.unpack "arboricx.merkle.node.v1"
+
+-- | Deserialize a Node from canonical bytes.
+deserializeNode :: BS.ByteString -> Node
+deserializeNode bs =
+ case BS.uncons bs of
+ Just (0x00, rest)
+ | BS.null rest -> NLeaf
+
+ Just (0x01, rest)
+ | BS.length rest == 32 ->
+ NStem $ decodeUtf8 (encode rest)
+
+ Just (0x02, rest)
+ | BS.length rest == 64 ->
+ let (l, r) = BS.splitAt 32 rest
+ in NFork (decodeUtf8 (encode l)) (decodeUtf8 (encode r))
+
+ _ -> errorWithoutStackTrace "invalid merkle node payload"
+
+-- | Convert a canonical Arboricx node payload (ByteString) to a Tree
+-- representation (a list of Byte trees).
+nodePayloadToTreeBytes :: BS.ByteString -> T
+nodePayloadToTreeBytes = ofBytes
+
+-- | Convert a Tree representation of a node payload back to ByteString.
+treeBytesToNodePayload :: T -> Either String BS.ByteString
+treeBytesToNodePayload = toBytes
+
+-- | Convert a MerkleHash (hex-encoded) to a Tree of its 32 raw bytes.
+hashToTreeBytes :: MerkleHash -> Either String T
+hashToTreeBytes h = case decode (encodeUtf8 h) of
+ Left _ -> Left "Invalid hex MerkleHash"
+ Right raw
+ | BS.length raw == 32 -> Right (ofBytes raw)
+ | otherwise -> Left "Hash raw bytes must be 32 bytes"
+
+-- | Convert a Tree of 32 Byte trees back to a MerkleHash (hex string).
+treeBytesToHash :: T -> Either String MerkleHash
+treeBytesToHash t = case toList t of
+ Left err -> Left err
+ Right bytes
+ | length bytes == 32 -> do
+ raw <- BS.pack <$> mapM toByte bytes
+ Right $ decodeUtf8 (encode raw)
+ | otherwise -> Left "Expected exactly 32 byte elements for hash"
+
+-- | Build a Merkle DAG from a Tree Calculus term.
+buildMerkle :: T -> Node
+buildMerkle Leaf = NLeaf
+buildMerkle (Stem t) = NStem (nodeHash child)
+ where child = buildMerkle t
+buildMerkle (Fork l r) = NFork (nodeHash left) (nodeHash right)
+ where
+ left = buildMerkle l
+ right = buildMerkle r
+
+-- ---------------------------------------------------------------------------
+-- DAG node-table export (for host-language kernel embedding)
+-- ---------------------------------------------------------------------------
+
+-- | Export a term's Merkle DAG as a topologically-sorted node table.
+-- Children appear before parents so all index references are forward.
+-- Returns (root index, list of (tag, [child_indices])).
+exportDag :: T -> (Int, [(String, [Int])])
+exportDag term =
+ let (root, acc, _) = collectDag term [] Set.empty
+ -- acc is in reverse post-order (children first, root last)
+ ordered = reverse acc
+ idxMap = Map.fromList [(h, i) | (i, (h, _)) <- zip [0..] ordered]
+ rootIdx = idxMap Map.! root
+ lines_ = map (formatNode idxMap . snd) ordered
+ in (rootIdx, lines_)
+ where
+ collectDag :: T -> [(MerkleHash, Node)] -> Set.Set MerkleHash -> (MerkleHash, [(MerkleHash, Node)], Set.Set MerkleHash)
+ collectDag Leaf acc seen =
+ let h = nodeHash NLeaf
+ in if Set.member h seen then (h, acc, seen) else (h, (h, NLeaf) : acc, Set.insert h seen)
+ collectDag (Stem t) acc seen =
+ let (ch, acc', seen') = collectDag t acc seen
+ node = NStem ch
+ h = nodeHash node
+ in if Set.member h seen' then (h, acc', seen') else (h, (h, node) : acc', Set.insert h seen')
+ collectDag (Fork l r) acc seen =
+ let (lh, acc', seen') = collectDag l acc seen
+ (rh, acc'', seen'') = collectDag r acc' seen'
+ node = NFork lh rh
+ h = nodeHash node
+ in if Set.member h seen'' then (h, acc'', seen'') else (h, (h, node) : acc'', Set.insert h seen'')
+
+ formatNode :: Map.Map MerkleHash Int -> Node -> (String, [Int])
+ formatNode _ NLeaf = ("leaf", [])
+ formatNode idxMap (NStem ch) = ("stem", [idxMap Map.! ch])
+ formatNode idxMap (NFork l r) = ("fork", [idxMap Map.! l, idxMap Map.! r])
diff --git a/src/Runtime/Presentation.hs b/src/Runtime/Presentation.hs
@@ -0,0 +1,76 @@
+module Runtime.Presentation where
+
+import Runtime.Tree
+import Runtime.Value
+import Data.List (intercalate)
+import Data.Text (replace)
+import qualified Data.Text as T
+
+-- Output formats
+data EvaluatedForm = Tree | FSL | AST | Ternary | Ascii | Decode | Number | StringLit
+ deriving (Show)
+
+-- Outputs
+formatT :: EvaluatedForm -> T -> String
+formatT Tree = toSimpleT . show
+formatT FSL = show
+formatT AST = renderTreeAST
+formatT Ternary = toTernaryString
+formatT Ascii = toAscii
+formatT Decode = decodeResult
+formatT Number = either (\e -> "<not-number: " ++ e ++ ">") show . toNumber
+formatT StringLit = either (\e -> "<not-string: " ++ e ++ ">") show . toString
+
+toSimpleT :: String -> String
+toSimpleT s = T.unpack
+ $ replace "Fork" "t"
+ $ replace "Stem" "t"
+ $ replace "Leaf" "t"
+ $ T.pack s
+
+toTernaryString :: T -> String
+toTernaryString Leaf = "0"
+toTernaryString (Stem t) = "1" ++ toTernaryString t
+toTernaryString (Fork t1 t2) = "2" ++ toTernaryString t1 ++ toTernaryString t2
+
+-- Preserve the historical constructor display without depending on frontend ASTs.
+renderTreeAST :: T -> String
+renderTreeAST term = go False term
+ where
+ go _ Leaf = "TLeaf"
+ go nested (Stem a) = wrap nested ("TStem " ++ go True a)
+ go nested (Fork a b) = wrap nested ("TFork " ++ go True a ++ " " ++ go True b)
+ wrap True text = "(" ++ text ++ ")"
+ wrap False text = text
+
+toAscii :: T -> String
+toAscii tree = go tree "" True
+ where
+ go :: T -> String -> Bool -> String
+ go Leaf prefix isLast =
+ prefix ++ (if isLast then "`-- " else "|-- ") ++ "Leaf\n"
+ go (Stem t) prefix isLast =
+ prefix ++ (if isLast then "`-- " else "|-- ") ++ "Stem\n"
+ ++ go t (prefix ++ (if isLast then " " else "| ")) True
+ go (Fork left right) prefix isLast =
+ prefix ++ (if isLast then "`-- " else "|-- ") ++ "Fork\n"
+ ++ go left (prefix ++ (if isLast then " " else "| ")) False
+ ++ go right (prefix ++ (if isLast then " " else "| ")) True
+
+decodeResult :: T -> String
+decodeResult Leaf = "t"
+decodeResult tc =
+ case (toString tc, toList tc, toNumber tc) of
+ (Right s, _, _) | all isCommonChar s -> "\"" ++ s ++ "\""
+ (_, _, Right n) -> show n
+ (_, Right xs@(_:_), _) -> "[" ++ intercalate ", " (map decodeResult xs) ++ "]"
+ (_, Right [], _) -> "[]"
+ _ -> formatT Tree tc
+ where
+ isCommonChar c =
+ let n = fromEnum c
+ in (n >= 32 && n <= 126)
+ || n == 9
+ || n == 10
+ || n == 13
+
diff --git a/src/Runtime/Tree.hs b/src/Runtime/Tree.hs
@@ -0,0 +1,41 @@
+-- Lazy runtime trees and kernel reduction; no source-language representation.
+module Runtime.Tree where
+
+import qualified Data.Map as Map
+
+-- Tree Calculus Types
+data T = Leaf | Stem T | Fork T T
+ deriving (Show, Eq, Ord)
+
+-- Environment containing previously evaluated TC terms
+type Env = Map.Map String T
+
+-- Triage Calculus Reduction Rules
+{-
+ The t operator is left associative.
+ 1. t t a b -> a
+ 2. t (t a) b c -> a c (b c)
+ 3a. t (t a b) c t -> a
+ 3b. t (t a b) c (t u) -> b u
+ 3c. t (t a b) c (t u v) -> c u v
+-}
+apply :: T -> T -> T
+apply (Fork Leaf a) _ = a
+apply (Fork (Stem a) b) c = apply (apply a c) (apply b c)
+apply (Fork (Fork _a _b) _c) Leaf = _a
+apply (Fork (Fork _a _b) _c) (Stem u) = apply _b u
+apply (Fork (Fork _a _b) _c) (Fork u v) = apply (apply _c u) v
+-- Left associative `t`
+apply Leaf b = Stem b
+apply (Stem a) b = Fork a b
+
+-- Booleans
+_false :: T
+_false = Leaf
+
+_true :: T
+_true = Stem Leaf
+
+_not :: T
+_not = Fork (Fork _true (Fork Leaf _false)) Leaf
+
diff --git a/src/Runtime/Value.hs b/src/Runtime/Value.hs
@@ -0,0 +1,75 @@
+-- Canonical runtime value encodings. Keep demand behavior explicit.
+module Runtime.Value where
+
+import Runtime.Tree
+import Data.Word (Word8)
+import qualified Data.ByteString as BS
+
+-- | Encode a single byte (Word8) as a Tree Calculus number (0..255).
+ofByte :: Word8 -> T
+ofByte = ofNumber . fromIntegral
+
+-- | Decode a Tree Calculus number as a single byte (Word8).
+-- Rejects values outside the range 0..255.
+toByte :: T -> Either String Word8
+toByte t = case toNumber t of
+ Left err -> Left err
+ Right n
+ | n >= 0 && n <= 255 -> Right (fromIntegral n)
+ | otherwise -> Left ("Byte value out of range: " ++ show n)
+
+-- | Encode a ByteString as a Tree Calculus list of Byte trees.
+ofBytes :: BS.ByteString -> T
+ofBytes = ofList . map ofByte . BS.unpack
+
+-- | Decode a Tree Calculus list of Byte trees as a ByteString.
+-- Rejects non-list trees and elements that are not valid byte values (0..255).
+toBytes :: T -> Either String BS.ByteString
+toBytes t = case toList t of
+ Left err -> Left err
+ Right bs -> BS.pack <$> mapM toByte bs
+
+-- Marshalling
+ofString :: String -> T
+ofString str = ofList $ map (ofNumber . toInteger . fromEnum) str
+
+ofNumber :: Integer -> T
+ofNumber 0 = Leaf
+ofNumber n =
+ Fork
+ (if odd n then Stem Leaf else Leaf)
+ (ofNumber (n `div` 2))
+
+ofList :: [T] -> T
+ofList = foldr Fork Leaf
+
+toNumber :: T -> Either String Integer
+toNumber Leaf = Right 0
+toNumber (Fork Leaf rest) = case toNumber rest of
+ Right n -> Right (2 * n)
+ Left err -> Left err
+toNumber (Fork (Stem Leaf) rest) = case toNumber rest of
+ Right n -> Right (1 + 2 * n)
+ Left err -> Left err
+toNumber _ = Left "Invalid Tree Calculus number"
+
+toChar :: Integer -> Either String Char
+toChar n
+ | n < 0 = Left "Negative character code"
+ | n > 0x10FFFF = Left "Character code out of Unicode range"
+ | n >= 0xD800 && n <= 0xDFFF = Left "Surrogate character code not allowed"
+ | otherwise = Right (toEnum (fromInteger n))
+
+toString :: T -> Either String String
+toString tc = do
+ list <- toList tc
+ nums <- mapM toNumber list
+ mapM toChar nums
+
+toList :: T -> Either String [T]
+toList Leaf = Right []
+toList (Fork x rest) = case toList rest of
+ Right xs -> Right (x : xs)
+ Left err -> Left err
+toList _ = Left "Invalid Tree Calculus list"
+
diff --git a/src/TreeObservation.hs b/src/TreeObservation.hs
@@ -3,7 +3,7 @@ module TreeObservation (forceTreeShared) where
import Control.Exception (evaluate)
import qualified Data.IntMap.Strict as IntMap
-import Research (T(..))
+import Runtime (T(..))
import System.Mem.StableName (StableName, makeStableName, hashStableName)
data Visit = Enter T | Leave (StableName T)
diff --git a/src/Wire.hs b/src/Wire.hs
@@ -30,7 +30,7 @@ module Wire
, defaultExportNames
) where
-import Research hiding (Node)
+import Runtime hiding (Node)
import Control.Monad (foldM, forM_, unless, when)
import Control.Exception (evaluate)
@@ -515,7 +515,7 @@ bundleFromIndexedRoots finalNodes namedRoots =
mkRoot 0 idx = BundleRoot idx "default"
mkRoot _ idx = BundleRoot idx "root"
--- Streaming canonical preorder -> postorder DAG. No expanded Research.T is
+-- Streaming canonical preorder -> postorder DAG. No expanded Runtime.T is
-- constructed. Global interning preserves buildBundle's left-before-right,
-- first-occurrence numbering, including sharing between separate exports.
-- Memory: unique DAG nodes + maximum tree depth + caller's current input chunk.
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -76,7 +76,8 @@ allTestLibsEnv = unsafePerformIO $ do
tests :: TestTree
tests = testGroup "Tricu Tests"
- [ interactionInspectionTests
+ [ runtimePresentationTests
+ , interactionInspectionTests
, packageTests
, lexer
, parser
@@ -128,6 +129,20 @@ tests = testGroup "Tricu Tests"
-- Demand is tested with exceptions rather than unbounded divergent reductions.
-- Physical sharing below is a Haskell implementation check, not a tree ABI promise.
+-- Independent compatibility oracle: production rendering no longer imports ASTs.
+runtimePresentationTests :: TestTree
+runtimePresentationTests = testGroup "Runtime presentation"
+ [ testCase "AST constructor display agrees with recovery oracle" $ do
+ let trees 0 = [Leaf]
+ trees n = let children = trees (n - 1)
+ in Leaf : map Stem children ++ [Fork a b | a <- children, b <- children]
+ forM_ (trees (3 :: Int)) $ \term ->
+ formatT AST term @?= show (toAST term)
+ , testCase "AST nested constructor golden" $
+ formatT AST (Fork (Stem Leaf) (Fork Leaf Leaf)) @?=
+ "TFork (TStem TLeaf) (TFork TLeaf TLeaf)"
+ ]
+
evaluationDemandTests :: TestTree
evaluationDemandTests = localOption (mkTimeout 30000000) $ testGroup "Evaluation demand boundaries"
[ testCase "constant application discards its argument" $
diff --git a/tricu.cabal b/tricu.cabal
@@ -56,14 +56,11 @@ executable tricu
, filepath
, fsnotify
, haskeline
- , megaparsec
, memory
, mtl
, network
, stm
, temporary
- , tasty
- , tasty-hunit
, text
, time
, transformers
@@ -84,18 +81,15 @@ executable tricu
ContentStore.Filesystem
ContentStore.Object
ContentStore.Resolver
- Eval
- FileEval
- Frontend.ContractDesugar
IODriver
- Lexer
Module.Manifest
- Module.Resolver
- Module.Workspace
- Parser
Paths_tricu
REPL
- Research
+ Runtime
+ Runtime.Tree
+ Runtime.Value
+ Runtime.Presentation
+ Runtime.Merkle
TreeObservation
Wire
default-language: Haskell2010
@@ -154,6 +148,11 @@ benchmark tricu-bench
Parser
Paths_tricu
Research
+ Runtime
+ Runtime.Tree
+ Runtime.Value
+ Runtime.Presentation
+ Runtime.Merkle
TreeObservation
Wire
@@ -228,6 +227,11 @@ test-suite tricu-tests
Paths_tricu
REPL
Research
+ Runtime
+ Runtime.Tree
+ Runtime.Value
+ Runtime.Presentation
+ Runtime.Merkle
TreeObservation
Wire
SupportFixture
