commit a2dba24c0fa291cceb0b4e7e82ae70fe5afa4a6c
parent cf7839ee92c469c284a7adf7ad192f072aa205f2
Author: James Eversole <james@eversole.co>
Date: Wed, 14 Oct 2026 19:08:29 -0500
Delete the historical Haskell frontend and recovery workspace
Diffstat:
22 files changed, 27 insertions(+), 2488 deletions(-)
diff --git a/AGENTS.md b/AGENTS.md
@@ -77,8 +77,8 @@ observations as historical evidence.
**tricu** (pronounced "tree-shoe") is a programming-language experiment written primarily in Haskell.
Runtime trees and reduction are in `src/Runtime/Tree.hs`; `src/Runtime.hs` is the
-source-free host API. `src/Research.hs` is a recovery-only frontend facade for
-unmigrated tests.
+source-free host API. Source compilation belongs to the portable tricu compiler;
+the historical Haskell frontend has been removed.
### File extensions
diff --git a/docs/compiler-rebuilding.md b/docs/compiler-rebuilding.md
@@ -251,8 +251,8 @@ For a pre-consolidation header parser, explicitly add `--legacy-compiler-header`
to worker preparation. It changes the bridge wrapper's header, not the native
language or failed-compilation behavior. Subsequent generations use the rebuilt
closure directly. Historical custom four-argument adapters are not substitutes
-for the standard adapter. The unit-test recovery-source cohort is separate from
-production artifact preparation.
+for the standard adapter. Test wrappers also use retained portable compilation,
+not a host source frontend.
## Rolling development retention
diff --git a/docs/compiler.md b/docs/compiler.md
@@ -183,8 +183,10 @@ complete-interface cache rules.
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. Unmigrated tests still use it; the installed and benchmark executables do not.
+The historical Haskell frontend and its recovery syntax have been removed.
+Executables, tests and benchmarks all use this source-free host API. Source test
+programs compile through retained authenticated portable compiler artifacts;
+library tests may instead apply published trees directly.
The `ast` display format renders tree constructors directly, without constructing
source ASTs.
diff --git a/docs/contracts.md b/docs/contracts.md
@@ -259,8 +259,8 @@ For example, `idNat 5` is `5`; `idNat "bad"` is
before the final binder produces an absorbing function for the next argument
before returning the failure Result.
-The host desugarer is `src/Frontend/ContractDesugar.hs`; the portable source
-compiler has its own corresponding lowering. The accepted profile is described
+Annotation lowering belongs to the portable source compiler in
+`lib/source/program.tri`; there is no Haskell source desugarer. The accepted profile is described
in [the source profile](language.md.html).
## 7. Modules and content-addressed storage
diff --git a/docs/host-abi.md b/docs/host-abi.md
@@ -213,7 +213,7 @@ The host then:
## Implementation reference
-- Tree constructors, numbers, strings, and lists: `src/Research.hs`
+- Tree constructors, numbers, strings, and lists: `src/Runtime.hs`
- Result protocol: `lib/binary.tri`
- Arboricx parser/executor: `lib/arboricx/arboricx.tri`
- Host ABI implementation: `lib/arboricx/arboricx.tri`
diff --git a/docs/modules.md b/docs/modules.md
@@ -87,8 +87,8 @@ the neutral alias-file format. This is separate from graph workspace resolution.
## Implementations
`lib/source/{module,object,lock,build,map,bundle}.tri` owns native module policy.
-The Haskell host supplies primitive IO and typed tree transport. Its separate
-store and recovery frontend support CLI artifact operations and recovery tools.
+The Haskell host supplies primitive IO and typed tree transport. Its content store
+supports CLI artifact operations; source compilation uses the portable compiler.
[Compiler architecture](compiler.md.html) describes the build boundary;
[Testing](validation.md.html) lists the module and graph probes.
diff --git a/docs/self-hosted-arboricx-host.md b/docs/self-hosted-arboricx-host.md
@@ -24,7 +24,7 @@ has this application structure:
Application is an evaluator operation, distinct from the data constructor
`Fork function argument`. Preserve that distinction in the host representation.
-The Haskell reference is `src/Research.hs`; the browser implementation is under
+The Haskell reference is `src/Runtime.hs`; the browser implementation is under
`ext/demo-site/src/`.
## Select an entrypoint
diff --git a/docs/tri-tools.md b/docs/tri-tools.md
@@ -313,8 +313,8 @@ clears source/imports; `!env` lists local exported definitions. `!format`, `!out
`!store`, `!clear`, `!help`, and `!exit` remain available. Changing `!store` does not
copy pinned dependencies; a subsequent build can fail if the new store lacks them.
The legacy `!name` tree injection operation is retired; import an explicit module
-interface instead. Host recovery modules remain for maintenance tests, but normal
-CLI operations never compile source through them.
+interface instead. The historical host frontend has been removed; CLI operations
+and source tests use the portable compiler.
Focused edited-host coverage (not a generation or fixture publication):
diff --git a/docs/validation.md b/docs/validation.md
@@ -7,11 +7,10 @@ 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 component retains those inputs during migration; the benchmark executable
-also builds without recovery sources.
+The Haskell lexer/parser/compiler/source loader, recovery AST, and recovery
+workspace resolver have been removed. Executables, tests and benchmarks share
+the source-free runtime; the Nix boundary check rejects reintroduction of the
+retired frontend files. `megaparsec` is no longer a host/test dependency.
Runtime-presentation tests use independent constructor-display goldens; runtime
demand tests exercise the same reducer used by production. Historical Haskell
lexer/parser/lambda-elimination tests and self-hosting differential comparisons
@@ -150,7 +149,7 @@ The Haskell gate loads fingerprinted, full compiler/support artifacts. Source
bytes are stored by their existing `arboricx.source.v1` digest under
`test/fixtures/reference-source/`; the `.v1` fixture metadata remains authoritative.
The loader authenticates those bytes, including the headers used for import
-binding and the explicitly scoped recovery foundations. Missing/corrupt snapshots
+binding. Missing/corrupt snapshots
fail: there is no fallback to working-tree library source. Unmapped test programs
remain live test inputs. Bundle, receipt, namespace, kernel, and ABI checks remain.
@@ -782,11 +781,6 @@ or peak residency. The probes characterize these examples, not universal binding
sharing, eager compatibility, or a general compiler speedup. They change no
published compiler/support artifacts.
-The Haskell recovery/shape-test cohort pins six immutable sources through
-`recoveryFoundationSources` in `test/Spec.hs`. It stays separate from current
-portable foundations, whose syntax the recovery parser cannot necessarily read.
-Each snapshot is authenticated before use, with no working-source fallback.
-
## Collections, contracts, and ordinary cleanup candidates (opt-in)
The three library batch runners below require `REFERENCE_FIXTURES`: authenticated
diff --git a/ext/demo-site/README.md b/ext/demo-site/README.md
@@ -606,7 +606,7 @@ before publication. Keep matching site and dependency outputs together for rollb
duplicate node/export/section controls, reserved fields, UTF-8, and trailing
data. The accepted profile requires contiguous sections and rejects unknown
critical sections; noncritical extensions can be skipped.
-- `src/codecs.ts`: canonical codecs corresponding to `src/Research.hs`, including
+- `src/codecs.ts`: canonical codecs corresponding to `src/Runtime.hs`, including
Unicode **scalar** strings (not byte/UTF-16 lists), bounded BigInt naturals,
structured literal validation, and bounded views. Flat ternary expansion exists
only as an explicitly bounded conformance/debug operation, never evaluator
diff --git a/flake.nix b/flake.nix
@@ -24,21 +24,13 @@
top = builtins.head (pkgs.lib.splitString "/" relative);
in pkgs.lib.cleanSourceFilter path type && builtins.elem top [
"src" "lib" "test" "bench" "bootstrap" "demos" "ext"
- "tricu.cabal" "tricu.workspace" "LICENSE" "README.md"
+ "tricu.cabal" "LICENSE" "README.md"
];
};
- # The installed host must build with recovery frontend files absent.
- # Tests 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"
- ]);
- };
+ # All Haskell components now share the source-free runtime. The boundary
+ # check below rejects reintroducing retired frontend files into inputs.
+ runtimeSource = tricuSource;
haskellPackages = pkgs.haskellPackages;
hsLib = pkgs.haskell.lib;
@@ -144,10 +136,6 @@
sha256sum $out/workers.arboricx | cut -d ' ' -f 1 > $out/sha256
'';
- customGHC = haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
- megaparsec
- ]);
-
# ------------------------------------------------------------------
# Zig Arboricx host
# ------------------------------------------------------------------
@@ -437,7 +425,7 @@
haskellPackages.cabal-install
haskellPackages.ghc-events
haskellPackages.ghcid
- customGHC
+ haskellPackages.ghc
upx
gcc
python3
diff --git a/src/Eval.hs b/src/Eval.hs
@@ -1,624 +0,0 @@
-module Eval where
-
-import Frontend.ContractDesugar
-import Parser
-import Research
-
-import Data.List (partition, (\\), elemIndex, foldl')
-import Data.Map ()
-import Data.Set (Set)
-import Debug.Trace (trace)
-
-import qualified Data.Foldable as F ()
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
-data DB
- = BVar Int
- | BFree String
- | BLam DB
- | BApp DB DB
- | BLeaf
- | BStem DB
- | BFork DB DB
- | BStr String
- | BInt Integer
- | BList [DB]
- | BEmpty
- deriving (Eq, Show)
-
-type Uses = [Bool]
-
-evalSingle :: Env -> TricuAST -> Env
-evalSingle env term
- | SDef name params body <- term
- = let res = evalASTSync env (if null params then body else SLambda params body)
- in case Map.lookup name env of
- Just existingValue
- | existingValue == res -> env
- | otherwise
- -> Map.insert "!result" res (Map.insert name res env)
- Nothing
- -> Map.insert "!result" res (Map.insert name res env)
- | SDefAnn name args _ body <- term
- = let params = annotatedBinders args
- res = evalASTSync env (if null params then body else SLambda params body)
- in case Map.lookup name env of
- Just existingValue
- | existingValue == res -> env
- | otherwise
- -> Map.insert "!result" res (Map.insert name res env)
- Nothing
- -> Map.insert "!result" res (Map.insert name res env)
- | SApp func arg <- term
- = let res = apply (evalASTSync env func) (evalASTSync env arg)
- in Map.insert "!result" res env
- | SVar name Nothing <- term
- = case Map.lookup name env of
- Just v -> Map.insert "!result" v env
- Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
- | SVar name (Just hash) <- term
- = errorWithoutStackTrace $ "Hash-specific variable lookup not supported in local evaluation: " ++ name ++ "#" ++ hash
- | otherwise
- = let res = evalASTSync env term
- in Map.insert "!result" res env
-
-evalTricu :: Env -> [TricuAST] -> Env
-evalTricu env x = go env (reorderDefs env (map recoverParams (desugarContracts x)))
- where
- go env' [] = env'
- go env' [def] =
- let updatedEnv = evalSingle env' def
- in Map.insert "!result" (result updatedEnv) updatedEnv
- go env' (def:xs) =
- evalTricu (evalSingle env' def) xs
-
--- | Ensure the contract kernel is bound. If the environment already defines
--- 'kernel', leave it alone. Otherwise, bind 'kernel' to 'defaultKernel' if
--- that is available. This lets the default kernel live in a .tri file while
--- still providing a fallback for code that imports the base library.
-injectKernel :: Env -> Env
-injectKernel env =
- case Map.lookup "kernel" env of
- Just _ -> env
- Nothing ->
- case Map.lookup "defaultKernel" env of
- Just k -> Map.insert "kernel" k env
- Nothing -> env
-
-evalASTSync :: Env -> TricuAST -> T
-evalASTSync env term = case term of
- SLambda _ _ -> evalASTSync env (elimLambda term)
- SLet name val body -> evalASTSync env (SApp (SLambda [name] body) val)
- SVar name Nothing -> case Map.lookup name env of
- Just v -> v
- Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
- SVar name (Just hash) ->
- case Map.lookup (name ++ "#" ++ hash) env of
- Just v -> v
- Nothing -> errorWithoutStackTrace $
- "Variable " ++ name ++ " with hash " ++ hash ++ " not found in environment"
- TLeaf -> Leaf
- TStem t -> Stem (evalASTSync env t)
- TFork t u -> Fork (evalASTSync env t) (evalASTSync env u)
- SApp t u -> apply (evalASTSync env t) (evalASTSync env u)
- SStr s -> ofString s
- SInt n -> ofNumber n
- SList xs -> ofList (map (evalASTSync env) xs)
- SEmpty -> Leaf
- _ -> errorWithoutStackTrace $ "Unexpected AST term: " ++ show term
-
-evalAST :: Env -> TricuAST -> IO T
-evalAST env ast = return $ evalASTSync env ast
-
-recoverParams :: TricuAST -> TricuAST
-recoverParams (SDef name [] (SLambda params body)) = SDef name params body
-recoverParams term = term
-
-annotatedBinders :: [DefArg] -> [String]
-annotatedBinders [] = []
-annotatedBinders (DefBinder name _ : rest) = name : annotatedBinders rest
-annotatedBinders (DefPhantom _ : rest) = annotatedBinders rest
-
-elimLambda :: TricuAST -> TricuAST
-elimLambda = go
- where
- go (SLet name val body) = go (SApp (SLambda [name] body) val)
- go term
- | etaReduction term = go (etaReduceResult term)
- | triagePattern term = _TRI
- | composePattern term = _B
- | lambdaList term = go (lambdaListResult term)
- | nestedLambda term = nestedLambdaResult term
- | application term = applicationResult term
- | isSList term = slistTransform term
- | otherwise = term
-
- etaReduction (SLambda [v] (SVar x Nothing)) = v == x
- etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (usesBinder v f)
- etaReduction _ = False
-
- triagePattern (SLambda [a] (SLambda [b] (SLambda [c] body))) =
- toDB [c,b,a] body == triageBodyDB
- triagePattern _ = False
-
- composePattern (SLambda [f] (SLambda [g] (SLambda [x] body))) =
- toDB [x,g,f] body == composeBodyDB
- composePattern _ = False
-
- lambdaList (SLambda [_] (SList _)) = True
- lambdaList _ = False
-
- nestedLambda (SLambda (_:_) _) = True
- nestedLambda _ = False
-
- application (SApp _ _) = True
- application _ = False
-
- etaReduceResult (SLambda [_] (SVar _ Nothing)) = _I
- etaReduceResult (SLambda [_] (SApp f _)) = f
- etaReduceResult _ = error "etaReduceResult: unexpected shape"
-
- lambdaListResult (SLambda [v] (SList xs)) =
- SLambda [v] (foldr wrapTLeaf TLeaf xs)
- where
- wrapTLeaf m r = SApp (SApp TLeaf m) r
- lambdaListResult _ = error "lambdaListResult: expected SLambda [v] (SList xs)"
-
- nestedLambdaResult (SLambda (v:vs) body)
- | null vs =
- let body' = go body
- db = toDB [v] body'
- in toSKIKiselyov db
- | otherwise = go (SLambda [v] (SLambda vs body))
- nestedLambdaResult _ = error "nestedLambdaResult: expected SLambda (_:_) _"
-
- applicationResult (SApp f g) = SApp (go f) (go g)
- applicationResult _ = error "applicationResult: expected SApp _ _"
-
- isSList (SList _) = True
- isSList _ = False
-
- slistTransform :: TricuAST -> TricuAST
- slistTransform (SList xs) = foldr (\m r -> SApp (SApp TLeaf (go m)) r) TLeaf xs
- slistTransform ast = ast -- Should not be reached
-
-_S, _K, _I, _R, _C, _B, _T, _TRI :: TricuAST
-_S = parseSingle "t (t (t t t)) t"
-_K = parseSingle "t t"
-_I = parseSingle "t (t (t t)) t"
-_R = parseSingle "(t (t (t t (t (t (t (t (t (t (t t (t (t (t t t)) t))) (t (t (t t (t t))) (t (t (t t t)) t)))) (t t (t t))))))) (t t))"
-_C = parseSingle "(t (t (t (t (t t (t (t (t t t)) t))) (t (t (t t (t t))) (t (t (t t t)) t)))) (t t (t t)))"
-_B = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
-_T = SApp _C _I
-_TRI = parseSingle "t (t (t t (t (t (t t t))))) t"
-
-triageBody :: String -> String -> String -> TricuAST
-triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a Nothing)) (SVar b Nothing))) (SVar c Nothing)
-composeBody :: String -> String -> String -> TricuAST
-composeBody f g x = SApp (SVar f Nothing) (SApp (SVar g Nothing) (SVar x Nothing))
-
-isFree :: String -> TricuAST -> Bool
-isFree x t = Set.member x (freeVars t)
-
-freeVars :: TricuAST -> Set String
-freeVars (SVar v Nothing) = Set.singleton v
-freeVars (SVar v (Just _)) = Set.singleton v
-freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
-freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs)
-freeVars (SLet name val body) =
- Set.union (freeVars val) (Set.delete name (freeVars body))
-freeVars (SDef _ params body) = Set.difference (freeVars body) (Set.fromList params)
-freeVars (SDefAnn _ args ret body) =
- Set.difference
- (Set.unions
- [ freeVars body
- , freeVarsDefArgs args
- , maybe Set.empty freeVarsViewExpr ret
- , Set.singleton "withContract"
- ])
- (Set.fromList (annotatedBinders args))
-freeVars (TStem t) = freeVars t
-freeVars (TFork t u) = Set.union (freeVars t) (freeVars u)
-freeVars (SList xs) = foldMap freeVars xs
-freeVars _ = Set.empty
-
-freeVarsViewExpr :: ViewExpr -> Set String
-freeVarsViewExpr (VEName s) = Set.singleton s
-freeVarsViewExpr (VEVar s) = Set.singleton s
-freeVarsViewExpr (VEApp f a) = Set.union (freeVarsViewExpr f) (freeVarsViewExpr a)
-freeVarsViewExpr (VEList es) = Set.unions (map freeVarsViewExpr es)
-freeVarsViewExpr (VEForall _ e) = freeVarsViewExpr e
-freeVarsViewExpr (VEExists _ e) = freeVarsViewExpr e
-freeVarsViewExpr _ = Set.empty
-
-freeVarsDefArgs :: [DefArg] -> Set String
-freeVarsDefArgs = Set.unions . map go
- where
- go (DefBinder _ mAnn) = maybe Set.empty freeVarsViewExpr mAnn
- go (DefPhantom ann) = freeVarsViewExpr ann
-
-reorderDefs :: Env -> [TricuAST] -> [TricuAST]
-reorderDefs env defs
- | not (null missingDeps) =
- errorWithoutStackTrace $
- "Missing dependencies detected: " ++ show missingDeps
- | otherwise = orderedDefs ++ others
- where
- (defsOnly, others) = partition isDef defs
- defNames = [ defName def | def <- defsOnly ]
-
- defsWithFreeVars = [(def, freeVars def) | def <- defsOnly]
-
- graph = buildDepGraph defsOnly
- sortedDefs = sortDeps graph
- defMap = Map.fromList [(defName def, def) | def <- defsOnly]
- orderedDefs = map (defMap Map.!) sortedDefs
-
- freeVarsDefs = foldMap snd defsWithFreeVars
- freeVarsOthers = foldMap freeVars others
- allFreeVars = freeVarsDefs <> freeVarsOthers
- validNames = Set.fromList defNames `Set.union` Set.fromList (Map.keys env)
- missingDeps = Set.toList (allFreeVars `Set.difference` validNames)
-
- isDef SDef {} = True
- isDef SDefAnn {} = True
- isDef _ = False
-
-buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
-buildDepGraph topDefs
- | not (null conflictingDefs) =
- errorWithoutStackTrace $
- "Conflicting definitions detected: " ++ show conflictingDefs
- | otherwise =
- Map.fromList
- [ (defName def, depends topDefs def)
- | def <- topDefs]
- where
- defsMap = Map.fromListWith (++)
- [(defName def, [(defName def, defBody def)]) | def <- topDefs]
-
- conflictingDefs =
- [ name
- | (name, defs) <- Map.toList defsMap
- , let bodies = map snd defs
- , not $ all (== head bodies) (tail bodies)
- ]
-
-sortDeps :: Map.Map String (Set.Set String) -> [String]
-sortDeps graph = go [] Set.empty (Map.keys graph)
- where
- go sorted _sortedSet [] = sorted
- go sorted sortedSet remaining =
- let ready = [ name | name <- remaining
- , let deps = Map.findWithDefault Set.empty name graph
- , Set.isSubsetOf deps sortedSet ]
- notReady = remaining \\ ready
- in if null ready
- then errorWithoutStackTrace
- "ERROR: Cyclic dependency detected and prohibited.\n\
- \RESOLVE: Use nested lambdas."
- else go (sorted ++ ready)
- (Set.union sortedSet (Set.fromList ready))
- notReady
-
-defName :: TricuAST -> String
-defName (SDef name _ _) = name
-defName (SDefAnn name _ _ _) = name
-defName _ = error "defName: expected definition"
-
-defBody :: TricuAST -> TricuAST
-defBody (SDef _ _ body) = body
-defBody (SDefAnn _ _ _ body) = body
-defBody _ = error "defBody: expected definition"
-
-depends :: [TricuAST] -> TricuAST -> Set.Set String
-depends topDefs def@SDef {} =
- Set.intersection
- (Set.fromList [defName d | d <- topDefs])
- (freeVars def)
-depends topDefs def@SDefAnn {} =
- Set.intersection
- (Set.fromList [defName d | d <- topDefs])
- (freeVars def)
-depends _ _ = Set.empty
-
-result :: Env -> T
-result r = case Map.lookup "!result" r of
- Just a -> a
- Nothing -> errorWithoutStackTrace "No !result field found in provided env"
-
-mainResult :: Env -> T
-mainResult r = case Map.lookup "main" r of
- Just a -> a
- Nothing -> errorWithoutStackTrace "No valid definition for `main` found."
-
-findVarNames :: TricuAST -> [String]
-findVarNames ast = case ast of
- SVar name _ -> [name]
- SApp a b -> findVarNames a ++ findVarNames b
- SLambda args body -> findVarNames body \\ args
- SLet name val body -> findVarNames val ++ (findVarNames body \\ [name])
- SDef name args body -> name : (findVarNames body \\ args)
- SDefAnn name args _ body -> name : (findVarNames body \\ annotatedBinders args)
- _ -> []
-
--- Convert named TricuAST to De Bruijn form
-toDB :: [String] -> TricuAST -> DB
-toDB env = \case
- SVar v _ -> maybe (BFree v) BVar (elemIndex v env)
- SLambda vs b ->
- let env' = reverse vs ++ env
- body = toDB env' b
- in foldr (\_ acc -> BLam acc) body vs
- SApp f a -> BApp (toDB env f) (toDB env a)
- TLeaf -> BLeaf
- TStem t -> BStem (toDB env t)
- TFork l r -> BFork (toDB env l) (toDB env r)
- SStr s -> BStr s
- SInt n -> BInt n
- SList xs -> BList (map (toDB env) xs)
- SEmpty -> BEmpty
- SLet name val body -> toDB env (SApp (SLambda [name] body) val)
- SDef{} -> error "toDB: unexpected SDef at this stage"
- SDefAnn{} -> error "toDB: unexpected SDefAnn at this stage"
- SImport _ _ -> BEmpty
-
--- Does a term depend on the current binder (level 0)?
-dependsOnLevel :: Int -> DB -> Bool
-dependsOnLevel lvl = \case
- BVar k -> k == lvl
- BLam t -> dependsOnLevel (lvl + 1) t
- BApp f a -> dependsOnLevel lvl f || dependsOnLevel lvl a
- BStem t -> dependsOnLevel lvl t
- BFork l r -> dependsOnLevel lvl l || dependsOnLevel lvl r
- BList xs -> any (dependsOnLevel lvl) xs
- _ -> False
-
--- Collect free *global* names (i.e., unbound)
-freeDBNames :: DB -> Set String
-freeDBNames = \case
- BFree s -> Set.singleton s
- BVar _ -> mempty
- BLam t -> freeDBNames t
- BApp f a -> freeDBNames f <> freeDBNames a
- BLeaf -> mempty
- BStem t -> freeDBNames t
- BFork l r -> freeDBNames l <> freeDBNames r
- BStr _ -> mempty
- BInt _ -> mempty
- BList xs -> foldMap freeDBNames xs
- BEmpty -> mempty
-
--- Helper: "is the binder named v used in body?"
-usesBinder :: String -> TricuAST -> Bool
-usesBinder v body = dependsOnLevel 0 (toDB [v] body)
-
--- Expected DB bodies for the named special patterns (under env [a,b,c] -> indices 2,1,0)
-triageBodyDB :: DB
-triageBodyDB =
- BApp (BApp BLeaf (BApp (BApp BLeaf (BVar 2)) (BVar 1))) (BVar 0)
-
-composeBodyDB :: DB
-composeBodyDB =
- BApp (BVar 2) (BApp (BVar 1) (BVar 0))
-
--- Convert DB -> TricuAST for subterms that contain NO binders (no BLam, no BVar)
-fromDBClosed :: DB -> TricuAST
-fromDBClosed = \case
- BFree s -> SVar s Nothing
- BApp f a -> SApp (fromDBClosed f) (fromDBClosed a)
- BLeaf -> TLeaf
- BStem t -> TStem (fromDBClosed t)
- BFork l r -> TFork (fromDBClosed l) (fromDBClosed r)
- BStr s -> SStr s
- BInt n -> SInt n
- BList xs -> SList (map fromDBClosed xs)
- BEmpty -> SEmpty
- -- Anything bound would be a logic error if we call this correctly.
- BLam _ -> error "fromDBClosed: unexpected BLam"
- BVar _ -> error "fromDBClosed: unexpected bound variable"
-
--- DB-native bracket abstraction over the innermost binder (level 0).
--- This mirrors your old toSKI, but is purely index-driven.
-toSKIDB :: DB -> TricuAST
-toSKIDB t
- | not (dependsOnLevel 0 t) = SApp _K (fromDBClosed t)
-toSKIDB (BVar 0) = _I
-toSKIDB (BApp n u) = SApp (SApp _S (toSKIDB n)) (toSKIDB u)
-toSKIDB (BStem t) = toSKIDB (BApp BLeaf t)
-toSKIDB (BFork l r) = toSKIDB (BApp (BApp BLeaf l) r)
-toSKIDB (BList xs) = toSKIDB (foldr (\m r -> BApp (BApp BLeaf m) r) BLeaf xs)
-toSKIDB other = error $ "toSKIDB: unsupported DB term: " ++ show other
-
-app2 :: TricuAST -> TricuAST -> TricuAST
-app2 f x = SApp f x
-
-app3 :: TricuAST -> TricuAST -> TricuAST -> TricuAST
-app3 f x y = SApp (SApp f x) y
-
--- Core converter that *does not* perform the λ-step; it just returns (Γ, d).
--- Supported shapes: variables, applications, closed literals (Leaf/Int/Str/Empty),
--- closed lists. For anything where the binder occurs under structural nodes
--- (Stem/Fork/List-with-use), we deliberately bail so the caller can fall back.
-kisConv :: DB -> Either String (Uses, TricuAST)
-kisConv = \case
- BVar 0 -> Right ([True], _I)
- BVar n | n > 0 -> do
- (g,d) <- kisConv (BVar (n - 1))
- Right (False:g, d)
- BVar n -> Right ([], SVar ("BVar" ++ show n) Nothing)
- BFree s -> Right ([], SVar s Nothing)
- BApp e1 e2 -> do
- (g1,d1) <- kisConv e1
- (g2,d2) <- kisConv e2
- let g = zipWithDefault False (||) g1 g2 -- <- propagate Γ outside (#)
- d = kisHash (g1,d1) (g2,d2) -- <- (#) yields only the term
- Right (g, d)
- -- Treat closed constants as free 'combinator leaves' (no binder use).
- BLeaf -> Right ([], TLeaf)
- BStr s -> Right ([], SStr s)
- BInt n -> Right ([], SInt n)
- BEmpty -> Right ([], SEmpty)
- -- Closed list: allowed. If binder is used anywhere, we punt to fallback.
- BList xs
- | any (dependsOnLevel 0) xs -> Left "List with binder use: fallback"
- | otherwise -> Right ([], SList (map fromDBClosed xs))
- -- For structural nodes, only allow if *closed* wrt the binder.
- BStem t
- | dependsOnLevel 0 t -> Left "Stem with binder use: fallback"
- | otherwise -> Right ([], TStem (fromDBClosed t))
- BFork l r
- | dependsOnLevel 0 l || dependsOnLevel 0 r -> Left "Fork with binder use: fallback"
- | otherwise -> Right ([], TFork (fromDBClosed l) (fromDBClosed r))
- -- We shouldn't see BLam under elim; treat as unsupported so we fallback.
- BLam _ -> Left "Nested lambda under body: fallback"
-
--- Application combiner with K-optimization (lazy weakening).
--- Mirrors Lynn's 'optK' rules: choose among S, B, C, R based on leading flags.
--- η-aware (#) with K-optimization (adapted from TS kiselyov_eta)
-kisHash :: (Uses, TricuAST) -> (Uses, TricuAST) -> TricuAST
-kisHash (g1, d1) (g2, d2) =
- case g1 of
- [] -> case g2 of
- [] -> SApp d1 d2
- True:gs2 -> if isId2 (g2, d2)
- then d1
- else kisHash ([], SApp _B d1) (gs2, d2)
- False:gs2 -> kisHash ([], d1) (gs2, d2)
-
- True:gs1 -> case g2 of
- [] -> if isId2 (g1, d1)
- then SApp _T d2
- else kisHash ([], SApp _R d2) (gs1, d1)
- _ ->
- if isId2 (g1, d1) && case g2 of { False:_ -> True; _ -> False }
- then kisHash ([], _T) (drop1 g2, d2)
- else
- -- NEW: coalesce the longest run of identical head pairs and apply bulk op once
- let ((h1, h2), count) = headPairRun g1 g2
- g1' = drop count g1
- g2' = drop count g2
- in case (h1, h2) of
- (False, False) ->
- kisHash (g1', d1) (g2', d2)
- (False, True) ->
- let d1' = kisHash ([], bulkB count) (g1', d1)
- in kisHash (g1', d1') (g2', d2)
- (True, False) ->
- let d1' = kisHash ([], bulkC count) (g1', d1)
- in kisHash (g1', d1') (g2', d2)
- (True, True) ->
- let d1' = kisHash ([], bulkS count) (g1', d1)
- in kisHash (g1', d1') (g2', d2)
-
- False:gs1 -> case g2 of
- [] -> kisHash (gs1, d1) ([], d2)
- _ ->
- if isId2 (g1, d1) && case g2 of { False:_ -> True; _ -> False }
- then kisHash ([], _T) (drop1 g2, d2)
- else case g2 of
- True:gs2 ->
- let d1' = kisHash ([], _B) (gs1, d1)
- in kisHash (gs1, d1') (gs2, d2)
- False:gs2 ->
- kisHash (gs1, d1) (gs2, d2)
- where
- drop1 (_:xs) = xs
- drop1 [] = []
-
-
-toSKIKiselyov :: DB -> TricuAST
-toSKIKiselyov body =
- case kisConv body of
- Right ([], d) -> SApp _K d
- Right (True:_ , d) -> d
- Right (False:g, d) -> kisHash ([], _K) (g, d) -- no snd
- Left _ -> starSKIBCOpEtaDB body -- was: toSKIDB body
-
-zipWithDefault :: a -> (a -> a -> a) -> [a] -> [a] -> [a]
-zipWithDefault d f [] ys = map (f d) ys
-zipWithDefault d f xs [] = map (\x -> f x d) xs
-zipWithDefault d f (x:xs) (y:ys) = f x y : zipWithDefault d f xs ys
-
-isNode :: TricuAST -> Bool
-isNode t = case t of
- TLeaf -> True
- _ -> False
-
-isApp2 :: TricuAST -> Maybe (TricuAST, TricuAST)
-isApp2 (SApp a b) = Just (a, b)
-isApp2 _ = Nothing
-
-isKop :: TricuAST -> Bool
-isKop t = case isApp2 t of
- Just (a,b) -> isNode a && isNode b
- _ -> False
-
--- detects the two canonical I-shapes in the tree calculus:
--- △ (△ (△ △)) x OR △ (△ △ △) △
-isId :: TricuAST -> Bool
-isId t = case isApp2 t of
- Just (ab, c) -> case isApp2 ab of
- Just (a, b) | isNode a ->
- case isApp2 b of
- Just (b1, b2) ->
- (isNode b1 && isKop b2) ||
- (isKop b1 && isNode b2 && isNode c)
- _ -> False
- _ -> False
- _ -> False
-
--- head-True only, tail empty, and term is identity
-isId2 :: (Uses, TricuAST) -> Bool
-isId2 (True:[], t) = isId t
-isId2 _ = False
-
--- Bulk helpers built from SKI (no new primitives)
-bPrime :: TricuAST
-bPrime = SApp _B _B -- B' = B B
-
-cPrime :: TricuAST
-cPrime = SApp (SApp _B (SApp _B _C)) _B -- C' = B (B C) B
-
-sPrime :: TricuAST
-sPrime = SApp (SApp _B (SApp _B _S)) _B -- S' = B (B S) B
-
-bulkB :: Int -> TricuAST
-bulkB n | n <= 1 = _B
- | otherwise = SApp bPrime (bulkB (n - 1))
-
-bulkC :: Int -> TricuAST
-bulkC n | n <= 1 = _C
- | otherwise = SApp cPrime (bulkC (n - 1))
-
-bulkS :: Int -> TricuAST
-bulkS n | n <= 1 = _S
- | otherwise = SApp sPrime (bulkS (n - 1))
-
-headPairRun :: [Bool] -> [Bool] -> ((Bool, Bool), Int)
-headPairRun g1 g2 =
- case zip g1 g2 of
- [] -> ((False, False), 0)
- (h:rest) -> (h, 1 + length (takeWhile (== h) rest))
-
--- DB-native star_skibc_op_eta (adapted from strategies.mts), binder = level 0
-starSKIBCOpEtaDB :: DB -> TricuAST
-starSKIBCOpEtaDB t
- | not (dependsOnLevel 0 t) = SApp _K (fromDBClosed t)
-starSKIBCOpEtaDB (BVar 0) = _I
-starSKIBCOpEtaDB (BApp e1 e2)
- -- if binder not in right: use C
- | not (dependsOnLevel 0 e2)
- = SApp (SApp _C (starSKIBCOpEtaDB e1)) (fromDBClosed e2)
- -- if binder not in left:
- | not (dependsOnLevel 0 e1)
- = case e2 of
- -- η case: \x. f x ==> f
- BVar 0 -> fromDBClosed e1
- _ -> SApp (SApp _B (fromDBClosed e1)) (starSKIBCOpEtaDB e2)
- -- otherwise: S
- | otherwise
- = SApp (SApp _S (starSKIBCOpEtaDB e1)) (starSKIBCOpEtaDB e2)
--- Structural nodes with binder underneath: fall back to plain SKI (rare)
-starSKIBCOpEtaDB other = toSKIDB other
diff --git a/src/FileEval.hs b/src/FileEval.hs
@@ -1,253 +0,0 @@
-module FileEval
- ( LoadedSource(..)
- , preprocessFile
- , preprocessFileWithStore
- , preprocessFileWithResolver
- , evaluateFile
- , evaluateFileWithStore
- , evaluateFileWithContext
- , evaluateFileWithContextWithStore
- , evaluateFileResult
- , compileFile
- , compileFileWithStore
- , loadFileWithStore
- , loadFileWithResolver
- , loadWorkspaceExportWithStore
- , defaultStorePath
- ) where
-
-import ContentStore
-import Eval (evalTricu, freeVars, result, injectKernel)
-import Frontend.ContractDesugar (desugarContracts)
-import Lexer
-import Module.Manifest
-import Module.Resolver
-import Module.Workspace
-import Parser
-import Research
-import Wire (buildBundle, encodeBundle, decodeBundle, verifyBundle, Bundle(..))
-
-import Data.List (partition, isPrefixOf)
-import Data.Maybe (mapMaybe)
-import System.Directory (getHomeDirectory, getTemporaryDirectory)
-import System.FilePath ((</>))
-import System.Exit (die)
-
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.Sequence as Seq
-import qualified Data.Text as T
-
-extractMain :: Env -> Either String T
-extractMain env =
- case Map.lookup "main" env of
- Just evalResult -> Right evalResult
- Nothing -> Left "No `main` function detected"
-
-data LoadedSource = LoadedSource
- { loadedImports :: Env
- , loadedAst :: [TricuAST]
- , loadedModules :: [ResolvedModule]
- }
-
-data LoadContext = LoadContext
- { loadResolver :: ObjectResolver
- , loadStore :: Maybe StorePath
- , loadWorkspace :: Workspace
- }
-
-processImports :: [TricuAST] -> ([TricuAST], [(String, String)])
-processImports asts =
- let (imports, nonImports) = partition isImp asts
- importTargets = mapMaybe getImportInfo imports
- in (nonImports, importTargets)
- where
- isImp (SImport _ _) = True
- isImp _ = False
- getImportInfo (SImport p n) = Just (p, n)
- getImportInfo _ = Nothing
-
-evaluateFileResult :: FilePath -> IO T
-evaluateFileResult filePath = do
- env <- evaluateFile filePath
- case extractMain env of
- Right evalResult -> return evalResult
- Left err -> errorWithoutStackTrace err
-
-evaluateFile :: FilePath -> IO Env
-evaluateFile = evaluateFileWithStore Nothing
-
-evaluateFileWithStore :: Maybe StorePath -> FilePath -> IO Env
-evaluateFileWithStore mStore filePath = do
- loaded <- maybe loadFile loadFileWithStore mStore filePath
- pure $ evalTricu (injectKernel (loadedImports loaded)) (loadedAst loaded)
-
-evaluateFileWithContext :: Env -> FilePath -> IO Env
-evaluateFileWithContext = evaluateFileWithContextWithStore Nothing
-
-evaluateFileWithContextWithStore :: Maybe StorePath -> Env -> FilePath -> IO Env
-evaluateFileWithContextWithStore mStore env filePath = do
- loaded <- case mStore of
- Nothing -> loadFile filePath
- Just store -> loadFileWithStore store filePath
- pure $ evalTricu (injectKernel (Map.union (loadedImports loaded) env)) (loadedAst loaded)
-
-preprocessFile :: FilePath -> IO [TricuAST]
-preprocessFile p = loadedAst <$> loadFile p
-
-preprocessFileWithStore :: StorePath -> FilePath -> IO [TricuAST]
-preprocessFileWithStore store p = loadedAst <$> loadFileWithStore store p
-
-preprocessFileWithResolver :: ObjectResolver -> FilePath -> IO [TricuAST]
-preprocessFileWithResolver resolver p = loadedAst <$> loadFileWithResolver resolver p
-
-loadFile :: FilePath -> IO LoadedSource
-loadFile p = do
- store <- defaultStorePath
- loadFileWithStore store p
-
-loadFileWithStore :: StorePath -> FilePath -> IO LoadedSource
-loadFileWithStore store p = do
- workspace <- findWorkspaceFor p
- resolver <- cachedFilesystemResolver store
- let ctx = LoadContext resolver (Just store) workspace
- loadFile' ctx p
-
-loadFileWithResolver :: ObjectResolver -> FilePath -> IO LoadedSource
-loadFileWithResolver resolver p = do
- let ctx = LoadContext resolver Nothing emptyWorkspace
- loadFile' ctx p
-
--- Load a library entry through the same workspace/bootstrap boundary as an
--- authored import, without a generated source file or source interpolation.
-loadWorkspaceExportWithStore :: StorePath -> FilePath -> String -> String -> IO T
-loadWorkspaceExportWithStore store contextPath target exportName = do
- workspace <- findWorkspaceFor contextPath
- resolver <- cachedFilesystemResolver store
- let ctx = LoadContext resolver (Just store) workspace
- ensureWorkspaceModule ctx target
- resolved <- resolveModuleImportSelecting resolver
- (Just $ Set.singleton $ T.pack exportName) target "!Local"
- case Map.lookup exportName (resolvedModulesEnv [resolved]) of
- Just term -> pure term
- Nothing -> die $ "Module export not found: " ++ target ++ "." ++ exportName
-
-loadFile' :: LoadContext -> FilePath -> IO LoadedSource
-loadFile' ctx currentPath = do
- contents <- readFile currentPath
- let tokens = lexTricu contents
- case parseProgram tokens of
- Left err -> errorWithoutStackTrace (handleParseError tokens err)
- Right ast ->
- let (nonImports, importTargets) = processImports ast
- desugaredNonImports = desugarContracts nonImports
- in do
- let reexportOnlyModule = null desugaredNonImports && not (null importTargets)
- resolvedModules <- mapM (\(target, name) -> do
- ensureWorkspaceModule ctx target
- resolveModuleImportSelecting (loadResolver ctx) (selectedExportsForImport reexportOnlyModule target name desugaredNonImports) target name) importTargets
- let moduleEnv = resolvedModulesEnv resolvedModules
- pure LoadedSource
- { loadedImports = moduleEnv
- , loadedAst = desugaredNonImports
- , loadedModules = resolvedModules
- }
-
-ensureWorkspaceModule :: LoadContext -> String -> IO ()
-ensureWorkspaceModule ctx moduleTarget = do
- existing <- resolverAlias (loadResolver ctx) ModuleAlias (T.pack moduleTarget)
- case existing of
- Just _ -> return ()
- Nothing -> do
- mSource <- resolveSourceModulePath ctx moduleTarget
- case (loadStore ctx, mSource) of
- (Just store, Just sourcePath) -> buildWorkspaceModule ctx store moduleTarget sourcePath
- _ -> return ()
-
-resolveSourceModulePath :: LoadContext -> String -> IO (Maybe FilePath)
-resolveSourceModulePath ctx moduleTarget =
- return (lookupWorkspaceModule (loadWorkspace ctx) (T.pack moduleTarget))
-
-buildWorkspaceModule :: LoadContext -> StorePath -> String -> FilePath -> IO ()
-buildWorkspaceModule ctx store moduleName sourcePath = do
- loaded <- loadFile' ctx sourcePath
- let asts = loadedAst loaded
- env = evalTricu (loadedImports loaded) asts
- localNames = topLevelDefinitions asts
- names = if null localNames
- then filter (/= "!result") (Map.keys env)
- else localNames
- exports <- mapM (buildExport env) names
- manifestHash <- putManifest store (ModuleManifest [] exports)
- writeAlias store ModuleAlias (T.pack moduleName) (ObjectRef (unDomain manifestDomain) manifestHash)
- where
- buildExport env name = case Map.lookup name env of
- Nothing -> errorWithoutStackTrace $
- "Workspace module export not found after evaluation: " ++ name
- Just term -> do
- rootRef <- putTreeTerm store term
- return ModuleExport
- { moduleExportName = T.pack name
- , moduleExportObject = ObjectRef (unDomain treeTermDomain) rootRef
- , moduleExportAbi = "arboricx.abi.tree.v1"
- }
-
-topLevelDefinitions :: [TricuAST] -> [String]
-topLevelDefinitions = mapMaybe go
- where
- go (SDef name _ _) = Just name
- go (SDefAnn name _ _ _) = Just name
- go _ = Nothing
-
-defaultStorePath :: IO StorePath
-defaultStorePath = do
- home <- getHomeDirectory
- if home == "/homeless-shelter"
- then do
- tmp <- getTemporaryDirectory
- return (StorePath (tmp </> "tricu" </> "store"))
- else return (StorePath (home </> ".tricu" </> "store"))
-
-selectedExportsForImport :: Bool -> String -> String -> [TricuAST] -> Maybe (Set.Set T.Text)
-selectedExportsForImport True _ _ _ = Nothing
-selectedExportsForImport False _moduleTarget importNamespace asts =
- Just $ Set.fromList directSelections
- where
- directSelections = mapMaybe select (Set.toList used)
- used = foldMap freeVars asts
- prefix = importNamespace ++ "."
- select name
- | importNamespace == "!Local" = Just (T.pack name)
- | prefix `isPrefixOf` name = Just (T.pack (drop (length prefix) name))
- | otherwise = Nothing
-
--- | Compile a tricu source file to a standalone Arboricx bundle.
--- Emits a canonical indexed bundle with no SHA-256 hashing.
-compileFile :: FilePath -> FilePath -> [T.Text] -> IO ()
-compileFile = compileFileWithStore Nothing
-
-compileFileWithStore :: Maybe StorePath -> FilePath -> FilePath -> [T.Text] -> IO ()
-compileFileWithStore mStore inputPath outputPath maybeNames = do
- env <- evaluateFileWithStore mStore inputPath
- let defaultNames = ["main"]
- wantedNames = if null maybeNames then defaultNames else maybeNames
- wantedNamesUnpacked = map T.unpack wantedNames
- compiledTerms <- mapM (\n -> case Map.lookup n env of
- Nothing -> die $ "No definition '" ++ n ++ "' found in " ++ inputPath
- Just t -> return (T.pack n, t)) wantedNamesUnpacked
- let bundle = buildBundle compiledTerms
- bundleData = encodeBundle bundle
- nodeCount = Seq.length (bundleNodes bundle)
- bundleSize = BS.length bundleData
- BL.writeFile outputPath (BL.fromStrict bundleData)
- putStrLn $ "Compiled " ++ inputPath ++ " -> " ++ outputPath
- putStrLn $ " exports: " ++ T.unpack (T.intercalate ", " (map fst compiledTerms))
- putStrLn $ " nodes: " ++ show nodeCount
- putStrLn $ " size: " ++ show bundleSize ++ " bytes"
- case decodeBundle bundleData of
- Left err -> putStrLn $ " round-trip decode failed: " ++ err
- Right decoded -> case verifyBundle decoded of
- Left err -> putStrLn $ " round-trip verify failed: " ++ err
- Right () -> putStrLn $ " round-trip: OK"
diff --git a/src/Frontend/ContractDesugar.hs b/src/Frontend/ContractDesugar.hs
@@ -1,118 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module Frontend.ContractDesugar
- ( desugarContracts
- , viewExprToAst
- ) where
-
-import Research
-
--- | Convert source-level contract annotations into runtime boundary checks.
---
--- Named binder annotations (e.g. @x@nat?) wrap each argument as it is
--- received and the result before it is returned.
---
--- Phantom annotations (e.g. @nat? on a point-free definition) are turned
--- into a fresh local raw value plus a wrapper definition that uses named
--- binder annotations. The raw value is bound with a local 'let' so that
--- fixed points (such as definitions built with 'y') are shared rather than
--- recreated on every call. The wrapper only needs 'withContract' and
--- 'matchResult' from the contract library.
-desugarContracts :: [TricuAST] -> [TricuAST]
-desugarContracts asts = concatMap desugarTopItem asts
- where
- desugarTopItem (SDefAnn name args ret body) = desugarDefAnn name args ret body
- desugarTopItem other = [other]
-
--- | Fresh internal name for the raw, contract-free helper introduced by
--- phantom annotations. It is bound locally with 'SLet' so it never escapes
--- into the final environment.
-rawNameFor :: String -> String
-rawNameFor name = "_" ++ name ++ "_raw"
-
-desugarDefAnn :: String -> [DefArg] -> Maybe ViewExpr -> TricuAST -> [TricuAST]
-desugarDefAnn name args ret body
- | all isPhantom args =
- let argContracts = map getPhantom args
- rawNm = rawNameFor name
- rawVar = SVar rawNm Nothing
- argNames = take (length args) ["x","y","z"]
- newArgs = zipWith DefBinder argNames (map Just argContracts)
- wrappedBody = foldl SApp rawVar (map (\n -> SVar n Nothing) argNames)
- wrapper = wrapArgs newArgs (wrapReturn ret wrappedBody)
- in [ SDef name [] (SLet rawNm body wrapper) ]
- | otherwise = [ SDef name [] (wrapArgs args body') ]
- where
- body' = wrapReturn ret body
-
- isPhantom (DefPhantom _) = True
- isPhantom _ = False
-
- getPhantom (DefPhantom c) = c
- getPhantom _ = error "expected phantom annotation"
-
- -- | Build: matchResult onFail (\value _ -> body) result
- bindResult result valueName body onFail =
- matchResultE
- onFail
- (SLambda [valueName, "_"] body)
- result
-
- -- | Build: matchResult (\msg _ -> err msg t) (\r _ -> r) result
- returnResult result =
- matchResultE
- (SLambda ["msg", "_"] errResult)
- (SLambda ["r", "_"] (SVar "r" Nothing))
- result
-
- -- | Build: \msg _ -> \_ -> err msg t
- absorbErr =
- SLambda ["msg", "_"] (SLambda ["_"] errResult)
-
- errResult = SApp (SApp (SVar "err" Nothing) (SVar "msg" Nothing)) TLeaf
-
- wrapReturn Nothing b = b
- wrapReturn (Just c) b = returnResult (withContractE (viewExprToAst c) b)
-
- wrapArgs [] b = b
- wrapArgs (DefBinder nm Nothing : rest) b = SLambda [nm] (wrapArgs rest b)
- wrapArgs (DefBinder nm (Just c) : rest) b =
- let onFail = if null rest then SLambda ["msg", "_"] errResult else absorbErr
- in SLambda [nm] $
- bindResult
- (withContractE (viewExprToAst c) (SVar nm Nothing))
- nm
- (wrapArgs rest b)
- onFail
- wrapArgs (DefPhantom _ : _) _ =
- error "phantom contract arguments are not yet supported by the frontend"
-
--- | Turn a source annotation expression into an ordinary AST expression.
--- Contract annotations are written with the same surface syntax as terms,
--- so the mapping is mostly structural.
-viewExprToAst :: ViewExpr -> TricuAST
-viewExprToAst = \case
- VEName s -> SVar s Nothing
- VEVar s -> SVar s Nothing
- VEInt i -> SInt i
- VEString s -> SStr s
- VEList es -> SList (map viewExprToAst es)
- VEApp f a -> SApp (viewExprToAst f) (viewExprToAst a)
- VERaw s -> SStr s
- VEVarId _ -> error "view variable ids are not supported by the frontend"
- VEForall _ _ -> error "forall annotations are not supported by the frontend"
- VEExists _ _ -> error "exists annotations are not supported by the frontend"
-
--- | Build an application of 'withContract' from the contract library.
-withContractE :: TricuAST -> TricuAST -> TricuAST
-withContractE contract value =
- SApp (SApp (SVar "withContract" Nothing) contract) value
-
--- | Build an application of 'matchResult' from the contract library.
-matchResultE :: TricuAST -> TricuAST -> TricuAST -> TricuAST
-matchResultE errCase okCase result =
- SApp
- (SApp
- (SApp (SVar "matchResult" Nothing) errCase)
- okCase)
- result
diff --git a/src/Lexer.hs b/src/Lexer.hs
@@ -1,217 +0,0 @@
-module Lexer where
-
-import Research
-
-import Control.Monad (void)
-import Data.Functor (($>))
-import Data.Set ()
-import Data.Void
-import Text.Megaparsec
-import Text.Megaparsec.Char hiding (space)
-import Text.Megaparsec.Char.Lexer
-
-type Lexer = Parsec Void String
-
-tricuLexer :: Lexer [LToken]
-tricuLexer = do
- sc
- header <- many $ do
- tok <- choice
- [ try lImport
- , lnewline
- ]
- sc
- pure tok
- toks <- many $ do
- tok <- choice tricuLexer'
- sc
- pure tok
- sc
- eof
- pure (header ++ toks)
- where
- tricuLexer' =
- [ try lnewline
- , try indentMarker
- , try dot
- , try identifierWithHash
- , try keywordT
- , try identifier
- , try namespace
- , try integerLiteral
- , try stringLiteral
- , try assignAt
- , assign
- , atSign
- , colon
- , openParen
- , closeParen
- , openBracket
- , closeBracket
- , try bindArrow
- , try arrowLeft
- , try arrowRight
- ]
-
-lexTricu :: String -> [LToken]
-lexTricu input = case runParser tricuLexer "" (insertIndentMarkers input) of
- Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
- Right toks -> toks
-
-insertIndentMarkers :: String -> String
-insertIndentMarkers = go False False
- where
- marker n = '\v' : show n ++ " "
-
- go _ _ [] = []
- go inString escaped (c:cs)
- | inString =
- c : go (not (c == '"' && not escaped)) (c == '\\' && not escaped) cs
- | c == '"' = c : go True False cs
- | c == '\n' =
- let (spaces, rest) = span (== ' ') cs
- n = length spaces
- in if n == 0
- then '\n' : go False False rest
- else '\n' : marker n ++ go False False rest
- | c == '\t' = errorWithoutStackTrace "Tabs are not allowed for indentation; use two spaces per indent level"
- | otherwise = c : go False False cs
-
-
-keywordT :: Lexer LToken
-keywordT = string "t" *> notFollowedBy alphaNumChar $> LKeywordT
-
-identifierWithHash :: Lexer LToken
-identifierWithHash = do
- first <- letterChar <|> char '_'
- rest <- many $ letterChar
- <|> digitChar <|> char '_' <|> char '-' <|> char '?'
- <|> char '$' <|> char '%'
- <|> char '\''
- _ <- char '#' -- Consume '#'
- hashString <- some (alphaNumChar <|> char '-') -- Ensures at least one char for hash
- <?> "hash characters (alphanumeric or hyphen)"
-
- let name = first : rest
- let hashLen = length hashString
- if name == "t" || name == "!result"
- then fail "Keywords (`t`, `!result`) cannot be used with a hash suffix."
- else if hashLen < 16 then
- fail $ "Hash suffix for '" ++ name ++ "' must be at least 16 characters long. Got " ++ show hashLen ++ " ('" ++ hashString ++ "')."
- else if hashLen > 64 then -- Assuming SHA256, max 64
- fail $ "Hash suffix for '" ++ name ++ "' cannot be longer than 64 characters (SHA256). Got " ++ show hashLen ++ " ('" ++ hashString ++ "')."
- else
- return (LIdentifierWithHash name hashString)
-
-identifier :: Lexer LToken
-identifier = do
- first <- letterChar <|> char '_'
- rest <- many $ letterChar
- <|> digitChar <|> char '_' <|> char '-' <|> char '?'
- <|> char '$' <|> char '%'
- <|> char '\''
- let name = first : rest
- if name == "t" || name == "!result"
- then fail "Keywords (`t`, `!result`) cannot be used as an identifier"
- else return (LIdentifier name)
-
-namespace :: Lexer LToken
-namespace = LNamespace <$> string "!Local"
-
-dot :: Lexer LToken
-dot = char '.' $> LDot
-
-lImport :: Lexer LToken
-lImport = do
- _ <- string "!import"
- space1
- LStringLiteral path <- stringLiteral
- space1
- name <- importAlias
- return (LImport path name)
-
-importAlias :: Lexer String
-importAlias = string "!Local" <|> do
- first <- letterChar <|> char '_'
- rest <- many (letterChar <|> digitChar <|> char '_' <|> char '-' <|> char '?' <|> char '$' <|> char '%' <|> char '\'' <|> char '.')
- let name = first : rest
- if name == "t" || name == "!result"
- then fail "Keywords (`t`, `!result`) cannot be used as an import alias"
- else pure name
-
-assignAt :: Lexer LToken
-assignAt = string "=@" $> LAssignAt
-
-assign :: Lexer LToken
-assign = char '=' $> LAssign
-
-atSign :: Lexer LToken
-atSign = char '@' $> LAt
-
-colon :: Lexer LToken
-colon = char ':' $> LColon
-
-openParen :: Lexer LToken
-openParen = char '(' $> LOpenParen
-
-closeParen :: Lexer LToken
-closeParen = char ')' $> LCloseParen
-
-openBracket :: Lexer LToken
-openBracket = char '[' $> LOpenBracket
-
-closeBracket :: Lexer LToken
-closeBracket = char ']' $> LCloseBracket
-
-arrowLeft :: Lexer LToken
-arrowLeft = string "<|" $> LArrowLeft
-
-arrowRight :: Lexer LToken
-arrowRight = string "|>" $> LArrowRight
-
-bindArrow :: Lexer LToken
-bindArrow = string "<-" $> LBindArrow
-
-lnewline :: Lexer LToken
-lnewline = char '\n' $> LNewline
-
-indentMarker :: Lexer LToken
-indentMarker = do
- void (char '\v')
- n <- some digitChar
- pure (LIndent (read n))
-
-sc :: Lexer ()
-sc = space
- (void $ takeWhile1P (Just "space") (\c -> c == ' ' || c == '\t'))
- (skipLineComment "--")
- (skipBlockComment "|-" "-|")
-
-integerLiteral :: Lexer LToken
-integerLiteral = do
- num <- some digitChar
- return (LIntegerLiteral (read num))
-
-stringLiteral :: Lexer LToken
-stringLiteral = do
- void (char '"')
- content <- manyTill Lexer.charLiteral (void (char '"'))
- return (LStringLiteral content)
-
-charLiteral :: Lexer Char
-charLiteral = escapedChar <|> normalChar
- where
- normalChar = noneOf ['"', '\\']
- escapedChar = do
- void $ char '\\'
- c <- oneOf ['n', 't', 'r', 'f', 'b', '\\', '"', '\'']
- return $ case c of
- 'n' -> '\n'
- 't' -> '\t'
- 'r' -> '\r'
- 'f' -> '\f'
- 'b' -> '\b'
- '\\' -> '\\'
- '"' -> '"'
- '\'' -> '\''
- _ -> c
diff --git a/src/Module/Resolver.hs b/src/Module/Resolver.hs
@@ -1,146 +0,0 @@
-module Module.Resolver
- ( ResolvedExport(..)
- , ResolvedModule(..)
- , resolveModuleImport
- , resolveModuleImportSelecting
- , resolveModuleImports
- , resolvedModulesEnv
- ) where
-
-import ContentStore.Alias
-import ContentStore.Arboricx (decodeTreeTerm, treeTermDomain)
-import ContentStore.Object
-import ContentStore.Resolver
-import Module.Manifest
-import Research
-
-import Control.Monad (unless)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.Text as T
-
--- | A manifest export resolved into the importing source's local lexical scope.
--- The executable term is loaded directly; contract terms are not interpreted by
--- the resolver.
-data ResolvedExport = ResolvedExport
- { resolvedExportSourceName :: T.Text
- , resolvedExportLocalName :: String
- , resolvedExportObject :: ObjectRef
- , resolvedExportAbi :: T.Text
- , resolvedExportContract :: Maybe ObjectRef
- , resolvedExportTerm :: T
- } deriving (Show, Eq)
-
-data ResolvedModule = ResolvedModule
- { resolvedModuleTarget :: String
- , resolvedModuleNamespace :: String
- , resolvedModuleManifest :: ObjectHash
- , resolvedModuleExports :: [ResolvedExport]
- } deriving (Show, Eq)
-
-resolveModuleImports :: ObjectResolver -> [TricuAST] -> IO ([ResolvedModule], [TricuAST])
-resolveModuleImports resolver asts = do
- let (imports, nonImports) = foldr splitImport ([], []) asts
- modules <- mapM (uncurry (resolveModuleImport resolver)) imports
- return (modules, nonImports)
- where
- splitImport (SImport target namespace) (is, rest) = ((target, namespace) : is, rest)
- splitImport ast (is, rest) = (is, ast : rest)
-
-resolveModuleImport :: ObjectResolver -> String -> String -> IO ResolvedModule
-resolveModuleImport resolver moduleTarget namespace =
- resolveModuleImportSelecting resolver Nothing moduleTarget namespace
-
-resolveModuleImportSelecting :: ObjectResolver -> Maybe (Set.Set T.Text) -> String -> String -> IO ResolvedModule
-resolveModuleImportSelecting resolver selected moduleTarget namespace = do
- manifestHash <- resolveModuleManifestHash resolver moduleTarget
- mManifest <- resolveManifest resolver manifestHash
- manifest <- case mManifest of
- Nothing -> errorWithoutStackTrace $
- "Module import failed for " ++ show moduleTarget
- ++ " as " ++ show namespace
- ++ ": manifest object not found (kind " ++ T.unpack (unDomain manifestDomain)
- ++ ", hash " ++ T.unpack manifestHash ++ ")"
- Just value -> return value
- let wantedExports = case selected of
- Nothing -> moduleManifestExports manifest
- Just names -> filter (\ex -> moduleExportName ex `Set.member` names) (moduleManifestExports manifest)
- exports <- mapM (resolveModuleExport resolver localNamespace) wantedExports
- return ResolvedModule
- { resolvedModuleTarget = moduleTarget
- , resolvedModuleNamespace = namespace
- , resolvedModuleManifest = manifestHash
- , resolvedModuleExports = exports
- }
- where
- localNamespace = if namespace == "!Local" then "" else namespace
-
-resolveModuleExport :: ObjectResolver -> String -> ModuleExport -> IO ResolvedExport
-resolveModuleExport resolver namespace ex = do
- unless (moduleExportAbi ex == "arboricx.abi.tree.v1") $
- fail $ "Module export " ++ show (moduleExportName ex)
- ++ " has unsupported export ABI: " ++ show (moduleExportAbi ex)
- let ref = moduleExportObject ex
- sourceName = moduleExportName ex
- term <- resolveExportTerm resolver sourceName ref
- return ResolvedExport
- { resolvedExportSourceName = sourceName
- , resolvedExportLocalName = nsVariable namespace (T.unpack sourceName)
- , resolvedExportObject = ref
- , resolvedExportAbi = moduleExportAbi ex
- , resolvedExportTerm = term
- }
-
-resolveExportTerm :: ObjectResolver -> T.Text -> ObjectRef -> IO T
-resolveExportTerm resolver sourceName ref
- | objectRefKind ref == unDomain treeTermDomain = do
- bytes <- requireObject
- case decodeTreeTerm bytes of
- Left err -> errorWithoutStackTrace $
- "Module export " ++ show (T.unpack sourceName)
- ++ " references invalid tree term " ++ T.unpack (objectRefHash ref)
- ++ ": " ++ err
- Right term -> return term
- | otherwise = errorWithoutStackTrace $
- "Module export " ++ show (T.unpack sourceName)
- ++ " has unsupported object kind " ++ show (T.unpack (objectRefKind ref))
- ++ "; expected " ++ show (T.unpack (unDomain treeTermDomain))
- where
- requireObject = do
- mBytes <- resolveObjectByHash resolver (objectRefKind ref) (objectRefHash ref)
- case mBytes of
- Just bytes -> return bytes
- Nothing -> errorWithoutStackTrace $
- "Module export " ++ show (T.unpack sourceName)
- ++ " references missing tree term " ++ T.unpack (objectRefHash ref)
- ++ " (kind " ++ T.unpack (objectRefKind ref) ++ ")"
-
-resolvedModulesEnv :: [ResolvedModule] -> Env
-resolvedModulesEnv modules = Map.fromList
- [ (resolvedExportLocalName ex, resolvedExportTerm ex)
- | m <- modules
- , ex <- resolvedModuleExports m
- ]
-
-resolveModuleManifestHash :: ObjectResolver -> String -> IO ObjectHash
-resolveModuleManifestHash resolver moduleTarget = do
- mAlias <- resolverAlias resolver ModuleAlias (T.pack moduleTarget)
- case mAlias of
- Just ref ->
- if objectRefKind ref == unDomain manifestDomain
- then return (objectRefHash ref)
- else errorWithoutStackTrace $
- "Module alias " ++ show moduleTarget
- ++ " points at unsupported object kind " ++ show (T.unpack (objectRefKind ref))
- ++ "; expected " ++ show (T.unpack (unDomain manifestDomain))
- ++ " (hash " ++ T.unpack (objectRefHash ref) ++ ")"
- Nothing ->
- case textToHashBytes (T.pack moduleTarget) of
- Right _ -> return (T.pack moduleTarget)
- Left _ -> errorWithoutStackTrace $
- "Module alias not found: " ++ show moduleTarget
- ++ "; add it to tricu.workspace or write a ModuleAlias, or import by manifest hash"
-
-nsVariable :: String -> String -> String
-nsVariable "" name = name
-nsVariable moduleName name = moduleName ++ "." ++ name
diff --git a/src/Module/Workspace.hs b/src/Module/Workspace.hs
@@ -1,66 +0,0 @@
-module Module.Workspace
- ( Workspace(..)
- , emptyWorkspace
- , lookupWorkspaceModule
- , findWorkspaceFor
- , parseWorkspace
- ) where
-
-import Data.Char (isSpace)
-import qualified Data.Map as Map
-import qualified Data.Text as T
-import System.Directory (doesDirectoryExist, doesFileExist)
-import System.FilePath (takeDirectory, (</>))
-
-data Workspace = Workspace
- { workspaceRoot :: FilePath
- , workspaceModules :: Map.Map T.Text FilePath
- } deriving (Show, Eq)
-
-emptyWorkspace :: Workspace
-emptyWorkspace = Workspace "" Map.empty
-
-lookupWorkspaceModule :: Workspace -> T.Text -> Maybe FilePath
-lookupWorkspaceModule (Workspace root modules) name = (root </>) <$> Map.lookup name modules
-
-findWorkspaceFor :: FilePath -> IO Workspace
-findWorkspaceFor sourcePath = search (takeDirectory sourcePath)
- where
- search dir = do
- let path = dir </> "tricu.workspace"
- exists <- doesFileExist path
- if exists
- then parseWorkspaceAt dir <$> readFile path
- else do
- let parent = takeDirectory dir
- if parent == dir
- then return emptyWorkspace
- else do
- parentExists <- doesDirectoryExist parent
- if parentExists then search parent else return emptyWorkspace
-
-parseWorkspace :: String -> Workspace
-parseWorkspace = parseWorkspaceAt ""
-
-parseWorkspaceAt :: FilePath -> String -> Workspace
-parseWorkspaceAt root input = Workspace root $ Map.fromList
- [ (T.pack name, path)
- | raw <- lines input
- , Just (name, path) <- [parseLine raw]
- ]
-
-parseLine :: String -> Maybe (String, FilePath)
-parseLine raw =
- let line = trim (takeWhile (/= '#') raw)
- in case words line of
- [] -> Nothing
- ["module", name, "=", path] -> Just (name, stripQuotes path)
- _ -> Nothing
-
-trim :: String -> String
-trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
-
-stripQuotes :: String -> String
-stripQuotes s = case s of
- ('"':rest) | not (null rest) && last rest == '"' -> init rest
- _ -> s
diff --git a/src/Parser.hs b/src/Parser.hs
@@ -1,758 +0,0 @@
-module Parser where
-
-import Lexer
-import Research
-
-import Control.Monad (void)
-import Data.Void (Void)
-import Text.Megaparsec
-
-import qualified Data.List.NonEmpty as NE
-import qualified Data.Set as Set
-
-type TokParser = Parsec Void [LToken]
-
-data Context = Top | Nested
- deriving (Eq, Show)
-
-reservedNames :: Set.Set String
-reservedNames = Set.fromList ["t", "!result", "let", "in", "where", "do"]
-
-parseTricu :: String -> [TricuAST]
-parseTricu input =
- let toks = lexTricu input
- in case runParser programP "" toks of
- Left err -> errorWithoutStackTrace (handleParseError toks err)
- Right asts -> asts
-
-parseSingle :: String -> TricuAST
-parseSingle input =
- let toks = lexTricu input
- in case parseSingleExpr toks of
- Left err -> errorWithoutStackTrace (handleParseError toks err)
- Right ast -> ast
-
-parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
-parseProgram = runParser programP ""
-
-parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
-parseSingleExpr = runParser singleP ""
-
-programP :: TokParser [TricuAST]
-programP = do
- skipTopNewlines
- imports <- many (importP <* skipTopNewlines)
- items <- manyItemsP
- eof
- pure (imports ++ items)
-
-singleP :: TokParser TricuAST
-singleP = do
- skipTopNewlines
- item <- topItemP
- skipTopNewlines
- eof
- pure item
-
-manyItemsP :: TokParser [TricuAST]
-manyItemsP = do
- skipTopNewlines
- done <- atEndP
- if done
- then pure []
- else do
- item <- topItemP
- skipTopNewlines
- rest <- manyItemsP
- pure (item : rest)
-
-topItemP :: TokParser TricuAST
-topItemP = do
- toks <- getInput
- case definitionHeadTop toks of
- Just _ -> definitionP
- Nothing -> exprTopP
-
-definitionHeadTop :: [LToken] -> Maybe (String, [String])
-definitionHeadTop toks =
- case toks of
- LIdentifier name : rest
- | name `Set.notMember` reservedNames
- , definitionAssignOnLine rest -> Just (name, [])
- _ -> Nothing
-
--- A top-level definition head is any identifier-led line containing `=` or `=@`.
--- Detailed validation happens in definitionP.
-definitionAssignOnLine :: [LToken] -> Bool
-definitionAssignOnLine [] = False
-definitionAssignOnLine (LNewline : _) = False
-definitionAssignOnLine (LAssign : _) = True
-definitionAssignOnLine (LAssignAt : _) = True
-definitionAssignOnLine (LIdentifier "where" : _) = False
-definitionAssignOnLine (LIdentifier "in" : _) = False
-definitionAssignOnLine (_ : rest) = definitionAssignOnLine rest
-
-definitionP :: TokParser TricuAST
-definitionP = do
- name <- identifierNameP
- (args, annotated) <- definitionArgsP False
- ret <- optional returnAnnotationP
- bodyIndent <- skipNestedNewlinesGetIndent
- body <- exprAtIndentP bodyIndent
- if annotated || ret /= Nothing
- then pure (SDefAnn name args ret body)
- else pure (SDef name (binderNames args) body)
-
-binderNames :: [DefArg] -> [String]
-binderNames [] = []
-binderNames (DefBinder name _ : rest) = name : binderNames rest
-binderNames (DefPhantom _ : rest) = binderNames rest
-
-definitionArgsP :: Bool -> TokParser ([DefArg], Bool)
-definitionArgsP seenPhantom = do
- mt <- peekP
- case mt of
- Just LAssign -> do
- void (tok (== LAssign) "=")
- pure ([], False)
- Just LAssignAt -> pure ([], False)
- Just (LIdentifier _) | not seenPhantom -> do
- name <- identifierNameP
- mAnn <- optional (try (tok (== LAt) "@" *> annotationTypeP))
- (rest, ann) <- definitionArgsP seenPhantom
- pure (DefBinder name mAnn : rest, ann || mAnn /= Nothing)
- Just LAt -> do
- void (tok (== LAt) "@")
- ty <- annotationTypeP
- (rest, ann) <- definitionArgsP True
- pure (DefPhantom ty : rest, True || ann)
- Just (LIdentifier _) -> fail "named binders cannot appear after phantom type annotations"
- _ -> fail "expected definition argument or assignment"
-
-returnAnnotationP :: TokParser ViewExpr
-returnAnnotationP = do
- void (tok (== LAssignAt) "=@")
- annotationTypeP
-
-annotationTypeP :: TokParser ViewExpr
-annotationTypeP =
- atomicTypeP
- <|> parenTypeP
-
-parenTypeP :: TokParser ViewExpr
-parenTypeP = do
- void (tok (== LOpenParen) "(")
- ty <- typeP
- void (tok (== LCloseParen) ")")
- pure ty
-
-typeP :: TokParser ViewExpr
-typeP = appTypeP
-
-appTypeP :: TokParser ViewExpr
-appTypeP = do
- first <- typeAtomP
- rest <- many typeAtomP
- pure (foldl VEApp first rest)
-
-typeAtomP :: TokParser ViewExpr
-typeAtomP =
- typeListP
- <|> typeStringP
- <|> typeIntP
- <|> atomicTypeP
- <|> parenTypeP
-
-typeListP :: TokParser ViewExpr
-typeListP = do
- void (tok (== LOpenBracket) "[")
- args <- many typeP
- void (tok (== LCloseBracket) "]")
- pure (VEList args)
-
-typeIntP :: TokParser ViewExpr
-typeIntP = do
- n <- tok isInt "integer"
- case n of
- LIntegerLiteral i -> pure (VEInt (fromIntegral i))
- _ -> fail "internal parser error: expected integer"
- where
- isInt (LIntegerLiteral _) = True
- isInt _ = False
-
-typeStringP :: TokParser ViewExpr
-typeStringP = do
- s <- tok isString "string"
- case s of
- LStringLiteral value -> pure (VEString value)
- _ -> fail "internal parser error: expected string"
- where
- isString (LStringLiteral _) = True
- isString _ = False
-
-atomicTypeP :: TokParser ViewExpr
-atomicTypeP = do
- t <- tok isTypeName "type name"
- case t of
- LNamespace name -> pure (VEName name)
- LIdentifier name
- | isViewVarName name -> pure (VEVar name)
- | otherwise -> pure (VEName name)
- _ -> fail "internal parser error: expected type name"
- where
- isViewVarName ('_' : rest) = not (null rest)
- isViewVarName _ = False
-
-isTypeName :: LToken -> Bool
-isTypeName (LNamespace _) = True
-isTypeName (LIdentifier _) = True
-isTypeName _ = False
-
-importP :: TokParser TricuAST
-importP = do
- t <- tok isImport "import"
- case t of
- LImport path ns -> pure (SImport path ns)
- _ -> fail "internal parser error: expected import token"
- where
- isImport (LImport _ _) = True
- isImport _ = False
-
-exprTopP :: TokParser TricuAST
-exprTopP = do
- toks <- getInput
- case lambdaHeadTop toks of
- Just params -> lambdaP Top params
- Nothing -> whereChainP pipeTopP
-
-exprNestedP :: TokParser TricuAST
-exprNestedP = do
- skipNestedNewlines
- toks <- getInput
- case lambdaHeadNested toks of
- Just params -> lambdaP Nested params
- Nothing -> whereChainP pipeNestedP
-
-exprAtIndentP :: Int -> TokParser TricuAST
-exprAtIndentP n = do
- toks <- getInput
- case lambdaHeadTop toks of
- Just params -> lambdaP Top params
- Nothing -> whereChainP (pipeAtIndentP n)
-
-lambdaP :: Context -> [String] -> TokParser TricuAST
-lambdaP ctx params = do
- consumeLambdaHead ctx params
- body <- case ctx of
- Top -> exprTopP
- Nested -> exprNestedP
- pure (foldr (\p acc -> SLambda [p] acc) body params)
-
-lambdaHeadTop :: [LToken] -> Maybe [String]
-lambdaHeadTop toks =
- case collectIdentifiersNoNewlines toks of
- (params@(_:_), LColon : _) -> Just params
- _ -> Nothing
-
-lambdaHeadNested :: [LToken] -> Maybe [String]
-lambdaHeadNested toks =
- case collectIdentifiersWithNewlines (dropNewlines toks) of
- (params@(_:_), rest) ->
- case dropNewlines rest of
- LColon : _ -> Just params
- _ -> Nothing
- _ -> Nothing
-
-collectIdentifiersNoNewlines :: [LToken] -> ([String], [LToken])
-collectIdentifiersNoNewlines (LIdentifier name : rest)
- | name `Set.notMember` reservedNames =
- let (names, final) = collectIdentifiersNoNewlines rest
- in (name : names, final)
-collectIdentifiersNoNewlines rest = ([], rest)
-
-collectIdentifiersWithNewlines :: [LToken] -> ([String], [LToken])
-collectIdentifiersWithNewlines (LIdentifier name : rest)
- | name `Set.notMember` reservedNames =
- let (names, final) = collectIdentifiersWithNewlines (dropNewlines rest)
- in (name : names, final)
-collectIdentifiersWithNewlines rest = ([], rest)
-
-consumeLambdaHead :: Context -> [String] -> TokParser ()
-consumeLambdaHead ctx params = do
- case ctx of
- Top -> pure ()
- Nested -> skipNestedNewlines
-
- mapM_ consumeParam params
-
- case ctx of
- Top -> pure ()
- Nested -> skipNestedNewlines
-
- void (tok (== LColon) ":")
- skipNestedNewlines
- where
- consumeParam _ = do
- void identifierNameP
- case ctx of
- Top -> pure ()
- Nested -> skipNestedNewlines
-
-data PipeOp = PipeBackward | PipeForward
- deriving (Eq, Show)
-
-applyPipe :: TricuAST -> (PipeOp, TricuAST) -> TricuAST
-applyPipe acc (PipeBackward, rhs) =
- SApp acc rhs
-
-applyPipe acc (PipeForward, rhs) =
- SApp rhs acc
-
-pipeTopP :: TokParser TricuAST
-pipeTopP =
- pipeAtIndentP 0
-
-pipeAtIndentP :: Int -> TokParser TricuAST
-pipeAtIndentP n =
- pipeChainP (appAtIndentP n) (appAtIndentP n)
-
-pipeNestedP :: TokParser TricuAST
-pipeNestedP =
- pipeChainP appNestedP appNestedP
-
-pipeChainP :: TokParser TricuAST -> TokParser TricuAST -> TokParser TricuAST
-pipeChainP parseFirst parseOperand = do
- first <- parseFirst
- rest <- many (try pipeSegmentP)
- pure (foldl applyPipe first rest)
- where
- pipeSegmentP = do
- skipNestedNewlines
- op <- pipeOpP
- skipNestedNewlines
- rhs <- parseOperand
- pure (op, rhs)
-
-pipeOpP :: TokParser PipeOp
-pipeOpP =
- (tok (== LArrowLeft) "<|" *> pure PipeBackward)
- <|> (tok (== LArrowRight) "|>" *> pure PipeForward)
-
-appTopP :: TokParser TricuAST
-appTopP = appAtIndentP 0
-
-appAtIndentP :: Int -> TokParser TricuAST
-appAtIndentP n = do
- first <- atomTopP
- appRestAtIndentP n first
-
-appRestAtIndentP :: Int -> TricuAST -> TokParser TricuAST
-appRestAtIndentP currentIndent acc = do
- toks <- getInput
- let shouldContinue = case toks of
- LNewline : LIndent n : rest
- | currentIndent > 0
- , n > currentIndent
- , not (isIndentedTerminator rest)
- , Just t <- firstNonLayout rest -> startsAtom t && not (isExprTerminator t)
- _ -> False
- if shouldContinue
- then do
- indentedNewlineP
- arg <- atomTopP
- appRestAtIndentP currentIndent (SApp acc arg)
- else do
- mt <- peekP
- case mt of
- Just t | startsAtom t && not (isExprTerminator t) -> do
- arg <- atomTopP
- appRestAtIndentP currentIndent (SApp acc arg)
- _ -> pure acc
-
-isIndentedTerminator :: [LToken] -> Bool
-isIndentedTerminator toks =
- case dropLayout toks of
- LIdentifier "where" : _ -> True
- rest -> definitionHeadTop rest /= Nothing
-
-firstNonLayout :: [LToken] -> Maybe LToken
-firstNonLayout toks =
- case dropLayout toks of
- [] -> Nothing
- x : _ -> Just x
-
-dropLayout :: [LToken] -> [LToken]
-dropLayout (LNewline : rest) = dropLayout rest
-dropLayout (LIndent _ : rest) = dropLayout rest
-dropLayout rest = rest
-
-appNestedP :: TokParser TricuAST
-appNestedP = do
- first <- atomNestedP
- appRestNestedP first
-
-appRestNestedP :: TricuAST -> TokParser TricuAST
-appRestNestedP acc = do
- skipNestedNewlines
- mt <- peekP
- case mt of
- Just t | startsAtom t && not (isExprTerminator t) -> do
- arg <- atomNestedP
- appRestNestedP (SApp acc arg)
- _ -> pure acc
-
-startsAtom :: LToken -> Bool
-startsAtom LOpenParen = True
-startsAtom LOpenBracket = True
-startsAtom (LIdentifier _) = True
-startsAtom (LIdentifierWithHash _ _) = True
-startsAtom (LNamespace _) = True
-startsAtom LKeywordT = True
-startsAtom (LIntegerLiteral _) = True
-startsAtom (LStringLiteral _) = True
-startsAtom _ = False
-
-isExprTerminator :: LToken -> Bool
-isExprTerminator (LIdentifier "in") = True
-isExprTerminator (LIdentifier "where") = True
-isExprTerminator _ = False
-
-atomTopP :: TokParser TricuAST
-atomTopP = do
- toks <- getInput
- case toks of
- LOpenParen : _ -> groupedP
- LOpenBracket : _ -> listP
- LIdentifier _ : LDot : _ -> namespacedVarP
- LNamespace _ : LDot : _ -> namespacedVarP
- LIdentifier "let" : _ -> letP
- LIdentifier "do" : _ -> doP
- LIdentifier name : _
- | name == "in" || name == "where" -> fail ("unexpected reserved word: " ++ name)
- | otherwise -> plainVarP
- LIdentifierWithHash _ _ : _ -> plainVarP
- LKeywordT : _ -> leafP
- LIntegerLiteral _ : _ -> intP
- LStringLiteral _ : _ -> strP
- _ -> fail "expected expression atom"
-
-atomNestedP :: TokParser TricuAST
-atomNestedP = skipNestedNewlines *> atomTopP
-
-groupedP :: TokParser TricuAST
-groupedP = do
- void (tok (== LOpenParen) "(")
- skipNestedNewlines
- expr <- exprNestedP
- skipNestedNewlines
- void (tok (== LCloseParen) ")")
- pure expr
-
-listP :: TokParser TricuAST
-listP = do
- void (tok (== LOpenBracket) "[")
- skipNestedNewlines
- xs <- listElementsP
- skipNestedNewlines
- void (tok (== LCloseBracket) "]")
- pure (SList xs)
-
-listElementsP :: TokParser [TricuAST]
-listElementsP = do
- skipNestedNewlines
- mt <- peekP
- case mt of
- Just LCloseBracket -> pure []
- Just t | startsAtom t -> do
- x <- listElementP
- xs <- listElementsP
- pure (x : xs)
- _ -> pure []
-
-listElementP :: TokParser TricuAST
-listElementP = do
- toks <- getInput
- case toks of
- LOpenParen : _ -> groupedP
- LOpenBracket : _ -> listP
- LIdentifier _ : LDot : _ -> namespacedVarP
- LNamespace _ : LDot : _ -> namespacedVarP
- LIdentifier "let" : _ -> letP
- LIdentifier "do" : _ -> doP
- LIdentifier name : _
- | name == "in" || name == "where" -> fail ("unexpected reserved word: " ++ name)
- | otherwise -> plainVarP
- LIdentifierWithHash _ _ : _ -> plainVarP
- LKeywordT : _ -> leafP
- LIntegerLiteral _ : _ -> intP
- LStringLiteral _ : _ -> strP
- _ -> fail "expected list element"
-
-whereChainP :: TokParser TricuAST -> TokParser TricuAST
-whereChainP parseBody = do
- body <- parseBody
- mWhere <- optional (try whereBindingP)
- case mWhere of
- Nothing -> pure body
- Just (name, args, value) ->
- let boundValue = foldr (\p acc -> SLambda [p] acc) value args
- in pure (SLet name boundValue body)
-
-whereBindingP :: TokParser (String, [String], TricuAST)
-whereBindingP = do
- skipNestedNewlines
- void (keywordIdentifierP "where")
- skipNestedNewlines
- name <- identifierNameP
- args <- many identifierNameP
- void (tok (== LAssign) "=")
- valueIndent <- skipNestedNewlinesGetIndent
- value <- exprAtIndentP valueIndent
- pure (name, args, value)
-
-letP :: TokParser TricuAST
-letP = do
- void (keywordIdentifierP "let")
- skipNestedNewlines
- name <- identifierNameP
- args <- many identifierNameP
- void (tok (== LAssign) "=")
- valueIndent <- skipNestedNewlinesGetIndent
- value <- exprAtIndentP valueIndent
- skipNestedNewlines
- void (keywordIdentifierP "in")
- bodyIndent <- skipNestedNewlinesGetIndent
- body <- exprAtIndentP bodyIndent
- let boundValue = foldr (\p acc -> SLambda [p] acc) value args
- pure (SLet name boundValue body)
-
-data DoStmt
- = DoBind String TricuAST
- | DoExpr TricuAST
- deriving (Eq, Show)
-
-doP :: TokParser TricuAST
-doP = do
- void (keywordIdentifierP "do")
- skipNestedNewlines
- bindOp <- atomTopP
- blockIndent <- requireIndentedBlockP
- stmts <- doBlockP blockIndent
- lowerDo bindOp stmts
-
-doBlockP :: Int -> TokParser [DoStmt]
-doBlockP blockIndent = do
- first <- doStmtP blockIndent
- rest <- many (try (sameIndentP blockIndent *> doStmtP blockIndent))
- pure (first : rest)
-
-doStmtP :: Int -> TokParser DoStmt
-doStmtP blockIndent = do
- toks <- getInput
- case toks of
- LIdentifier name : LBindArrow : _ -> do
- void identifierNameP
- void (tok (== LBindArrow) "<-")
- exprIndent <- skipNestedNewlinesGetIndent
- DoBind name <$> exprAtIndentP (max blockIndent exprIndent)
- _ -> DoExpr <$> exprAtIndentP blockIndent
-
-lowerDo :: TricuAST -> [DoStmt] -> TokParser TricuAST
-lowerDo _ [] = fail "do block must contain at least one statement"
-lowerDo _ [DoExpr expr] = pure expr
-lowerDo bindOp [DoBind _ _] = fail "last do statement must be an expression"
-lowerDo bindOp (DoBind name action : rest) = do
- body <- lowerDo bindOp rest
- pure (SApp (SApp bindOp action) (SLambda [name] body))
-lowerDo bindOp (DoExpr action : rest) = do
- body <- lowerDo bindOp rest
- pure (SApp (SApp bindOp action) (SLambda ["_"] body))
-
-requireIndentedBlockP :: TokParser Int
-requireIndentedBlockP = do
- void (tok (== LNewline) "newline")
- t <- tok isIndent "indent"
- case t of
- LIndent n | n > 0 -> pure n
- _ -> fail "expected indented do block"
-
-sameIndentP :: Int -> TokParser ()
-sameIndentP n = do
- void (tok (== LNewline) "newline")
- t <- tok isIndent "indent"
- case t of
- LIndent m | m == n -> pure ()
- _ -> fail "expected do statement at same indentation"
-
-keywordIdentifierP :: String -> TokParser LToken
-keywordIdentifierP name = tok (== LIdentifier name) name
-
-leafP :: TokParser TricuAST
-leafP = tok (== LKeywordT) "t" *> pure TLeaf
-
-plainVarP :: TokParser TricuAST
-plainVarP = do
- t <- tok isVar "identifier"
- case t of
- LIdentifier name -> pure (SVar name Nothing)
- LIdentifierWithHash name hash -> pure (SVar name (Just hash))
- _ -> fail "internal parser error: expected identifier"
- where
- isVar (LIdentifier _) = True
- isVar (LIdentifierWithHash _ _) = True
- isVar _ = False
-
-namespacedVarP :: TokParser TricuAST
-namespacedVarP = do
- nsTok <- tok isNamespace "namespace"
- void (tok (== LDot) ".")
- nameTok <- tok isVar "identifier"
- case (nsTok, nameTok) of
- (LIdentifier ns, LIdentifier name) ->
- pure (SVar (ns ++ "." ++ name) Nothing)
- (LIdentifier ns, LIdentifierWithHash name hash) ->
- pure (SVar (ns ++ "." ++ name) (Just hash))
- (LNamespace ns, LIdentifier name) ->
- pure (SVar (ns ++ "." ++ name) Nothing)
- (LNamespace ns, LIdentifierWithHash name hash) ->
- pure (SVar (ns ++ "." ++ name) (Just hash))
- _ -> fail "internal parser error: expected namespaced identifier"
- where
- isNamespace (LIdentifier name) = name `Set.notMember` reservedNames
- isNamespace (LNamespace _) = True
- isNamespace _ = False
-
- isVar (LIdentifier _) = True
- isVar (LIdentifierWithHash _ _) = True
- isVar _ = False
-
-intP :: TokParser TricuAST
-intP = do
- t <- tok isInt "integer"
- case t of
- LIntegerLiteral n -> pure (SInt (fromIntegral n))
- _ -> fail "internal parser error: expected integer"
- where
- isInt (LIntegerLiteral _) = True
- isInt _ = False
-
-strP :: TokParser TricuAST
-strP = do
- t <- tok isStr "string"
- case t of
- LStringLiteral s -> pure (SStr s)
- _ -> fail "internal parser error: expected string"
- where
- isStr (LStringLiteral _) = True
- isStr _ = False
-
-identifierNameP :: TokParser String
-identifierNameP = do
- t <- tok isIdentifier "identifier"
- case t of
- LIdentifier name
- | name `Set.member` reservedNames ->
- fail ("reserved name cannot be used as identifier: " ++ name)
- | otherwise ->
- pure name
- _ -> fail "internal parser error: expected identifier"
- where
- isIdentifier (LIdentifier _) = True
- isIdentifier _ = False
-
-tok :: (LToken -> Bool) -> String -> TokParser LToken
-tok predicate expected = satisfy predicate <?> expected
-
-peekP :: TokParser (Maybe LToken)
-peekP = do
- toks <- getInput
- pure $ case toks of
- [] -> Nothing
- x : _ -> Just x
-
-atEndP :: TokParser Bool
-atEndP = null <$> getInput
-
-skipTopNewlines :: TokParser ()
-skipTopNewlines = skipMany newlineWithOptionalIndentP
-
-skipNestedNewlines :: TokParser ()
-skipNestedNewlines = void skipNestedNewlinesGetIndent
-
-skipNestedNewlinesGetIndent :: TokParser Int
-skipNestedNewlinesGetIndent = go 0
- where
- go lastIndent = do
- mt <- optional (try newlineWithOptionalIndentValueP)
- case mt of
- Nothing -> pure lastIndent
- Just n -> go n
-
-newlineWithOptionalIndentP :: TokParser ()
-newlineWithOptionalIndentP = void newlineWithOptionalIndentValueP
-
-newlineWithOptionalIndentValueP :: TokParser Int
-newlineWithOptionalIndentValueP = do
- void (tok (== LNewline) "newline")
- mt <- optional indentP
- pure $ case mt of
- Just (LIndent n) -> n
- _ -> 0
-
-indentedNewlineP :: TokParser ()
-indentedNewlineP = do
- void (tok (== LNewline) "newline")
- t <- tok isIndent "indent"
- case t of
- LIndent n | n > 0 -> pure ()
- _ -> fail "expected indented continuation"
-
-indentP :: TokParser LToken
-indentP = tok isIndent "indent"
-
-isIndent :: LToken -> Bool
-isIndent (LIndent _) = True
-isIndent _ = False
-
-dropNewlines :: [LToken] -> [LToken]
-dropNewlines (LNewline : LIndent _ : rest) = dropNewlines rest
-dropNewlines (LNewline : rest) = dropNewlines rest
-dropNewlines rest = rest
-
-handleParseError :: [LToken] -> ParseErrorBundle [LToken] Void -> String
-handleParseError toks bundle =
- unlines
- ( "Parse error(s) encountered:"
- : map (formatError toks) (NE.toList (bundleErrors bundle))
- )
-
-formatError :: [LToken] -> ParseError [LToken] Void -> String
-formatError toks err =
- case err of
- TrivialError offset unexpected expected ->
- let unexpectedMsg =
- case unexpected of
- Nothing -> "unexpected end of input"
- Just x -> "unexpected " ++ show x
- expectedMsg =
- if Set.null expected
- then ""
- else "; expected one of " ++ show (Set.toList expected)
- in
- "Parse error at token offset " ++ show offset ++ ": " ++ unexpectedMsg ++ expectedMsg
- ++ "\nToken context:\n" ++ tokenContext toks offset
-
- FancyError offset fancy ->
- "Parse error at token offset " ++ show offset ++ ": " ++ show (Set.toList fancy)
- ++ "\nToken context:\n" ++ tokenContext toks offset
-
-tokenContext :: [LToken] -> Int -> String
-tokenContext toks off =
- let start = max 0 (off - 5)
- end = min (length toks) (off + 6)
- rows = zip [start ..] (take (end - start) (drop start toks))
- in unlines (map render rows)
- where
- render (i, token)
- | i == off = ">>> " ++ show i ++ ": " ++ show token
- | otherwise = " " ++ show i ++ ": " ++ show token
diff --git a/src/Research.hs b/src/Research.hs
@@ -1,77 +0,0 @@
--- Recovery frontend facade. Production modules must import Runtime instead.
-module Research (module Runtime, module Research) where
-
-import Runtime
-
--- Contract source annotations for @ and =@ syntax. ViewExpr carries the
--- surface syntax of a contract until Frontend.ContractDesugar turns it into a
--- runtime contract application.
-data ViewExpr
- = VEName String
- | VEVar String
- | VEVarId Integer
- | VEInt Integer
- | VEString String
- | VEList [ViewExpr]
- | VEApp ViewExpr ViewExpr
- | VEForall [Integer] ViewExpr
- | VEExists [Integer] ViewExpr
- | VERaw String
- deriving (Show, Eq, Ord)
-
-data DefArg
- = DefBinder String (Maybe ViewExpr)
- | DefPhantom ViewExpr
- deriving (Show, Eq, Ord)
-
--- Abstract Syntax Tree for tricu
-data TricuAST
- = SVar String (Maybe String)
- | SInt Integer
- | SStr String
- | SList [TricuAST]
- | SDef String [String] TricuAST
- | SDefAnn String [DefArg] (Maybe ViewExpr) TricuAST
- | SApp TricuAST TricuAST
- | TLeaf
- | TStem TricuAST
- | TFork TricuAST TricuAST
- | SLambda [String] TricuAST
- -- Non-recursive local binding: `name = boundValue` scoped over `body`.
- -- Produced by let/where desugaring. `boundValue` already folds any binding
- -- arguments into nested SLambda. Semantically equal to
- -- SApp (SLambda [name] body) boundValue
- | SLet String TricuAST TricuAST
- | SEmpty
- | SImport String String
- deriving (Show, Eq, Ord)
-
--- Lexer Tokens
-data LToken
- = LIdentifier String
- | LIdentifierWithHash String String
- | LKeywordT
- | LNamespace String
- | LImport String String
- | LAssign
- | LAssignAt
- | LAt
- | LColon
- | LDot
- | LOpenParen
- | LCloseParen
- | LOpenBracket
- | LCloseBracket
- | LStringLiteral String
- | LIntegerLiteral Int
- | LArrowLeft
- | LArrowRight
- | LBindArrow
- | LNewline
- | LIndent Int
- deriving (Eq, Show, Ord)
-
-toAST :: T -> TricuAST
-toAST Leaf = TLeaf
-toAST (Stem a) = TStem (toAST a)
-toAST (Fork a b) = TFork (toAST a) (toAST b)
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -33,7 +33,6 @@ import qualified System.Timeout as Timeout
import System.Directory (createDirectory, createFileLink, doesFileExist, doesDirectoryExist, listDirectory)
import System.FilePath ((</>))
import Data.Bits (xor)
-import Data.Char (digitToInt)
import Data.List (find, isInfixOf, isPrefixOf, stripPrefix)
import Data.Text (Text, unpack, pack)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
@@ -54,10 +53,6 @@ main = do
putStrLn "Reference-artifact tests: authenticated compiler/support snapshots, not working-tree candidate coverage."
defaultMain tests
-testStore :: StorePath
-testStore = StorePath "/tmp/tricu-test-store"
-{-# NOINLINE testStore #-}
-
tests :: TestTree
tests = testGroup "Tricu Tests"
[ runtimePresentationTests
@@ -1327,127 +1322,9 @@ trueT = Stem Leaf
falseT :: T
falseT = Leaf
-nothingT :: T
-nothingT = Leaf
-
-justT :: T -> T
-justT = Stem
-
pairT :: T -> T -> T
pairT = Fork
-byteT :: Integer -> T
-byteT = ofNumber
-
-bytesT :: [Integer] -> T
-bytesT = ofList . fmap byteT
-
-bytesExpr :: [Integer] -> String
-bytesExpr xs = "[" ++ unwords (map (\n -> "(" ++ show n ++ ")") xs) ++ "]"
-
-u16 :: Integer -> [Integer]
-u16 n = [0,n]
-
-u32 :: Integer -> [Integer]
-u32 n = [0,0,0,n]
-
-u64 :: Integer -> [Integer]
-u64 n = [0,0,0,0,0,0,0,n]
-
-arboricxHeaderBytes :: Integer -> [Integer]
-arboricxHeaderBytes sectionCount =
- [65,82,66,79,82,73,67,88]
- ++ u16 1
- ++ u16 0
- ++ u32 sectionCount
- ++ u64 0
- ++ u64 32
-
-sectionEntryBytes :: [Integer] -> Integer -> Integer -> [Integer]
-sectionEntryBytes sectionType offset lengthBytes =
- sectionType
- ++ u16 1
- ++ u16 1
- ++ u16 0
- ++ u16 1
- ++ u64 offset
- ++ u64 lengthBytes
- ++ replicate 32 0
-
-manifestSectionIdBytes :: [Integer]
-manifestSectionIdBytes = [0,0,0,1]
-
-nodesSectionIdBytes :: [Integer]
-nodesSectionIdBytes = [0,0,0,2]
-
-hexTextBytes :: Text -> [Integer]
-hexTextBytes h = go (unpack h)
- where
- go [] = []
- go (a:b:rest) = toInteger (digitToInt a * 16 + digitToInt b) : go rest
- go _ = error "odd-length hex text"
-
-manifestEntryBytes :: Integer -> Integer -> [Integer]
-manifestEntryBytes = sectionEntryBytes manifestSectionIdBytes
-
-nodesEntryBytes :: Integer -> Integer -> [Integer]
-nodesEntryBytes = sectionEntryBytes nodesSectionIdBytes
-
-simpleContainerBytes :: [Integer] -> [Integer] -> [Integer]
-simpleContainerBytes manifestBytes nodesBytes =
- let manifestOffset = 152
- nodesOffset = manifestOffset + fromIntegral (length manifestBytes)
- in arboricxHeaderBytes 2
- ++ manifestEntryBytes manifestOffset (fromIntegral $ length manifestBytes)
- ++ nodesEntryBytes nodesOffset (fromIntegral $ length nodesBytes)
- ++ manifestBytes
- ++ nodesBytes
-
-singleSectionContainerBytes :: [Integer] -> [Integer] -> [Integer]
-singleSectionContainerBytes sectionType sectionBytes =
- arboricxHeaderBytes 1
- ++ sectionEntryBytes sectionType 92 (fromIntegral $ length sectionBytes)
- ++ sectionBytes
-
-arboricxHeaderT :: Integer -> T
-arboricxHeaderT sectionCount =
- pairT (bytesT [0,1])
- (pairT (bytesT [0,0])
- (pairT (bytesT $ u32 sectionCount)
- (pairT (bytesT $ u64 0)
- (bytesT $ u64 32))))
-
-sectionRecordT :: [Integer] -> Integer -> Integer -> T
-sectionRecordT sectionType offset lengthBytes =
- pairT (bytesT sectionType)
- (pairT (bytesT [0,1])
- (pairT (bytesT [0,1])
- (pairT (bytesT [0,0])
- (pairT (bytesT [0,1])
- (pairT (bytesT $ u64 offset)
- (pairT (bytesT $ u64 lengthBytes)
- (bytesT $ replicate 32 0)))))))
-
-sectionRecordExpr :: [Integer] -> Integer -> Integer -> String
-sectionRecordExpr sectionType offset lengthBytes =
- "(pair " ++ bytesExpr sectionType
- ++ " (pair " ++ bytesExpr [0,1]
- ++ " (pair " ++ bytesExpr [0,1]
- ++ " (pair " ++ bytesExpr [0,0]
- ++ " (pair " ++ bytesExpr [0,1]
- ++ " (pair " ++ bytesExpr (u64 offset)
- ++ " (pair " ++ bytesExpr (u64 lengthBytes)
- ++ " " ++ bytesExpr (replicate 32 0)
- ++ ")))))))"
-
--- --------------------------------------------------------------------------
--- Portable finite-stream parser protocol
--- --------------------------------------------------------------------------
-
-portableParserEnv :: Env
-portableParserEnv = unsafePerformIO $ evaluateCompilerFile "./lib/parser.tri"
-{-# NOINLINE portableParserEnv #-}
-
portableReply :: Bool -> T -> T -> Bool -> Bool -> T
portableReply success payload rest consumed committed =
pairT (if success then trueT else falseT)
@@ -1459,13 +1336,6 @@ portableDiagnostic :: T -> T -> T -> T -> T -> T
portableDiagnostic code expected found location contexts =
pairT code (pairT expected (pairT found (pairT location contexts)))
-portableCode :: Integer -> T
-portableCode code = portableDiagnostic (ofNumber code) Leaf Leaf Leaf Leaf
-
-portableFound :: Integer -> T -> T -> T
-portableFound code expected found =
- portableDiagnostic (ofNumber code) expected found Leaf Leaf
-
-- --------------------------------------------------------------------------
-- Reusable, located character-scanning primitives
-- --------------------------------------------------------------------------
diff --git a/tricu.cabal b/tricu.cabal
@@ -11,7 +11,6 @@ license-file: LICENSE
build-type: Simple
extra-source-files:
README.md
- tricu.workspace
data-files: bootstrap/build-stable.arboricx
@@ -155,7 +154,6 @@ test-suite tricu-tests
, filepath
, fsnotify
, haskeline
- , megaparsec
, memory
, mtl
, network
@@ -186,18 +184,10 @@ test-suite tricu-tests
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
diff --git a/tricu.workspace b/tricu.workspace
@@ -1,46 +0,0 @@
-# tricu workspace module source map
-# Semantic module aliases are independent of physical library directories.
-
-# General-purpose Tree Calculus libraries
-module base = lib/base.tri
-module binary = lib/binary.tri
-module bytes = lib/bytes.tri
-module conversions = lib/conversions.tri
-module graph = lib/graph.tri
-module http = lib/http.tri
-module intensional = lib/intensionalContracts.tri
-module io = lib/io.tri
-module lexer = lib/lexer.tri
-module parser = lib/parser.tri
-module patterns = lib/patterns.tri
-module prelude = lib/prelude.tri
-module socket = lib/socket.tri
-
-# tricu source compiler and shared module/CAS infrastructure
-module source.ast = lib/source/ast.tri
-module source.build = lib/source/build.tri
-module source.bundle = lib/source/bundle.tri
-module source.compile = lib/source/compile.tri
-module source.core = lib/source/core.tri
-module source.equations = lib/source/equations.tri
-module source.export-cache = lib/source/export-cache.tri
-module source.lexer = lib/source/lexer.tri
-module source.lock = lib/source/lock.tri
-module source.map = lib/source/map.tri
-module source.module = lib/source/module.tri
-module source.object = lib/source/object.tri
-module source.order = lib/source/order.tri
-module source.parser = lib/source/parser.tri
-module source.pattern = lib/source/pattern.tri
-module source.program = lib/source/program.tri
-module source.resolve = lib/source/resolve.tri
-module source.stable = lib/source/stable.tri
-module source.unit = lib/source/unit.tri
-
-# Arboricx formats and services
-module arboricx = lib/arboricx/arboricx.tri
-module arboricx.common = lib/arboricx/common.tri
-module arboricx.dispatch = lib/arboricx/dispatch.tri
-module arboricx.manifest = lib/arboricx/manifest.tri
-module arboricx.nodes = lib/arboricx/nodes.tri
-module arboricx.server = lib/arboricx/server.tri
