6 Commits

Author SHA1 Message Date
efbe9350ed Zero Warnings Plan
Zero GHC warnings with new opts. General cleanup and updates.
2026-05-05 18:32:11 -05:00
2627627493 Picking development back up
Merge Kiselyov optimizations and De Bruijn indices
General clean up
2026-05-05 15:56:23 -05:00
c008126b14 Merge branch 'contentstore' 2026-05-05 14:09:42 -05:00
James Eversole
71653311ce Documentation updates 2026-05-05 10:03:15 -05:00
0cdc0bfc34 "size" function nodes down from 454 to 321 2025-08-07 20:08:59 -05:00
c36d963640 Update README to reflect completion of experiment 2025-05-29 13:39:44 -05:00
13 changed files with 806 additions and 258 deletions

177
AGENTS.md Normal file
View File

@@ -0,0 +1,177 @@
# AGENTS.md — tricu Project Guide
> For AI agents and contributors working in this repository.
## 1. Build & Test
**`nix build .#` always runs tests.** This is the primary and only way to build and validate.
```bash
# Full build + tests (this is the default)
nix build .#
# Build only (skip tests)
nix build .#package
# Build the test-specific variant with doCheck enforced
nix build .#test
nix flake check
# Dev shell (includes ghcid, cabal-install, ghc, upx)
nix develop .#
```
### ⚠️ Never call `cabal` directly
This project uses a Nix flake that wraps `callCabal2nix` to produce the cabal package. All compilation, linking, and test execution are driven through Nix. Running `cabal build`, `cabal test`, `cabal repl`, or `cabal install` directly will use the system GHC (or `.stack-work`) and can produce artifacts that differ from the Nix-built ones — especially regarding `megaparsec` which is a project dependency.
> **Rule of thumb:** if it builds, links, or tests, it goes through `nix`.
## 2. Project Overview
**tricu** (pronounced "tree-shoe") is a programming-language experiment written in Haskell. It implements [Triage Calculus](https://olydis.medium.com/a-visual-introduction-to-tree-calculus-2f4a34ceffc2), an extension of Barry Jay's Tree Calculus, with lambda-abstraction sugar that gets eliminated back to pure tree calculus terms.
tricu is Lojban for "tree".
### Core types (in `src/Research.hs`)
| Type | Description |
|------|-------------|
| `T = Leaf \| Stem T \| Fork T T` | Tree Calculus term (the runtime value) |
| `TricuAST` | Parsed AST with `SDef`, `SApp`, `SLambda`, etc. |
| `LToken` | Lexer tokens |
| `Node` / `MerkleHash` | Content-addressed Merkle DAG nodes |
### Source modules
| Module | Purpose |
|--------|---------|
| `Main.hs` | CLI entry point (`cmdargs`), three modes: `repl`, `eval`, `decode` |
| `Eval.hs` | Interpreter: `evalTricu`, `result`, `evalSingle` |
| `Parser.hs` | Megaparsec parser → `TricuAST` |
| `Lexer.hs` | Megaparsec lexer → `LToken` |
| `FileEval.hs` | File loading, module imports, `!import` |
| `REPL.hs` | Interactive Read-Eval-Print Loop (haskeline) |
| `Research.hs` | Core types, `apply` reduction, booleans, marshalling (`ofString`, `ofNumber`), output formatters (`toAscii`, `toTernaryString`, `decodeResult`) |
| `ContentStore.hs` | SQLite-backed term persistence |
### File extensions
- `.hs` — Haskell source
- `.tri` — tricu language source (used in `lib/`, `test/`, `demos/`)
## 3. Test Suite
Tests live in `test/Spec.hs` and use **Tasty** + **HUnit**.
```bash
nix flake check # or: nix build .#test
```
### Test groups
| Group | What it covers |
|-------|----------------|
| `lexer` | Megaparsec lexer — identifiers, keywords, strings, escapes, invalid tokens |
| `parser` | Parser — defs, lambda, applications, lists, comments, parentheses |
| `simpleEvaluation` | Core `apply` reduction rules, variable substitution, immutability |
| `lambdas` | Lambda elimination, SKI calculus, higher-order functions, currying, shadowing, free vars |
| `providedLibraries` | `lib/list.tri` — triage, booleans, list ops (`head`, `tail`, `map`, `emptyList?`, `append`, `equal?`) |
| `fileEval` | Loading `.tri` files, multi-file context, decode |
| `modules` | `!import`, cyclic deps, namespacing, multi-level imports, unresolved vars, local namespaces |
| `demos` | `demos/*.tri` — structural equality, `toSource`, `size`, level-order traversal |
| `decoding` | `decodeResult` — Leaf, numbers, strings, lists, mixed |
| `elimLambdaSingle` | Lambda elimination: eta reduction, SDef binding, semantics preservation |
| `stressElimLambda` | Lambda elimination stress test: 200 vars, 800-body curried lambda |
### Adding tests
1. Append a `testCase "Description" $ do ...` block to the appropriate test group in `test/Spec.hs`.
2. Import any modules you need (lexer/parser are available via `runParser` from `Text.Megapparsec`; evaluation via `evalTricu`, `parseTricu`, `result`).
3. Run `nix flake check` to verify.
> The test-suite in `tricu.cabal` pulls in `src/` as `hs-source-dirs`, so tests import modules directly (e.g., `import Eval`, `import Lexer`). This is intentional — tests exercise the full pipeline end-to-end.
## 4. tricu Language Quick Reference
```
t → Leaf (the base term)
t t → Stem Leaf
t t t → Fork Leaf Leaf
x = t → Define term x = Leaf
id = (a : a) → Lambda identity (eliminates to tree calculus)
head (map f xs) → From lib/list.tri
!import "./path.tri" NS → Import file under namespace
-- line comment
|- block comment -|
```
## 5. Output Formats
The `eval` command accepts `--form` (shorthand `-t`):
| Format | Value | Description |
|--------|-------|-------------|
| `tree` | `TreeCalculus` | Simple `t` form (default) |
| `fsl` | `FSL` | Full show representation |
| `ast` | `AST` | Parsed AST representation |
| `ternary` | `Ternary` | Ternary string encoding |
| `ascii` | `Ascii` | ASCII-art tree diagram |
| `decode` | `Decode` | Human-readable (strings, numbers, lists) |
## 6. Content Addressing
Each `T` term is content-addressed via a Merkle DAG:
```
NLeaf → 0x00
NStem(h) → 0x01 || h (32 bytes)
NFork(l,r) → 0x02 || l (32 bytes) || r (32 bytes)
hash = SHA256("tricu.merkle.node.v1" <> 0x00 <> serialized_node)
```
This is stored in SQLite via `ContentStore.hs`. Hash suffixes on identifiers (e.g., `foo_abc123...`) are validated: 1664 hex characters (SHA256).
## 7. Directory Layout
```
tricu/
├── flake.nix # Nix flake: packages, tests, devShell
├── tricu.cabal # Cabal package (used via callCabal2nix)
├── src/ # Haskell modules
│ ├── Main.hs
│ ├── Eval.hs
│ ├── Parser.hs
│ ├── Lexer.hs
│ ├── FileEval.hs
│ ├── REPL.hs
│ ├── Research.hs
│ └── ContentStore.hs
├── test/
│ ├── Spec.hs # Tasty + HUnit tests
│ ├── *.tri # tricu test programs
│ └── local-ns/ # Module namespace test files
├── lib/
│ ├── base.tri
│ ├── list.tri
│ └── patterns.tri
├── demos/
│ ├── equality.tri
│ ├── size.tri
│ ├── toSource.tri
│ ├── levelOrderTraversal.tri
│ └── patternMatching.tri
└── AGENTS.md # This file
```
## 8. Development Tips
- **Quick iteration:** `nix develop` then `ghcid` (provided in the devShell) watches files and re-runs.
- **REPL:** `nix run .#` starts the interactive REPL.
- **Evaluate files:** `nix run .# -- eval -f demos/equality.tri`
- **GHC options:** `-threaded -rtsopts -with-rtsopts=-N` for parallel runtime. Use `-N` RTS flag for multi-core.
- **Upx** is in the devShell for binary compression if needed.

View File

@@ -10,6 +10,10 @@ tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)
Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog). The addition of Triage rules were suggested by [Johannes Bader](https://johannes-bader.com/). Johannes is also the creator of [treecalcul.us](https://treecalcul.us) which has a great intuitive code playground using his language LambAda.
## Versioning
This really is a repo for experimentation so I'm not doing anything sane with the versioning for now. If I decide to stabilize the project we'll start anew at 2.0.
## REPL examples
```
@@ -32,15 +36,21 @@ tricu < -- or calculate its size (/demos/size.tri)
tricu < size not?
tricu > 12
tricu < -- REPL Commands:
tricu < !definitions -- Lists all available definitions
tricu < !output -- Change output format (Tree, FSL, AST, etc.)
tricu < !import -- Import definitions from a file
tricu < !exit -- Exit the REPL
tricu < !clear -- ANSI screen clear
tricu < !save -- Save all REPL definitions to a file that you can !import
tricu < !reset -- Clear all REPL definitions
tricu < !version -- Print tricu version
tricu < !help
tricu version 1.1.0
Available commands:
!exit - Exit the REPL
!clear - Clear the screen
!reset - Reset preferences for selected versions
!help - Show tricu version and available commands
!output - Change output format (tree|fsl|ast|ternary|ascii|decode)
!definitions - List all defined terms in the content store
!import - Import definitions from file to the content store
!watch - Watch a file for changes, evaluate terms, and store them
!refresh - Refresh environment from content store (definitions are live)
!versions - Show all versions of a term by name
!select - Select a specific version of a term for subsequent lookups
!tag - Add or update a tag for a term by hash or name
```
## Installation and Use

View File

@@ -9,26 +9,42 @@
outputs = { self, nixpkgs, flake-utils }:
flake-utils.lib.eachDefaultSystem (system:
let
pkgs = nixpkgs.legacyPackages.${system};
packageName = "tricu";
containerPackageName = "${packageName}-container";
customGHC = pkgs.haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
megaparsec
]);
pkgs = nixpkgs.legacyPackages.${system};
packageName = "tricu";
haskellPackages = pkgs.haskellPackages;
hsLib = pkgs.haskell.lib;
enableSharedExecutables = false;
enableSharedLibraries = false;
tricuPackage =
haskellPackages.callCabal2nix packageName self {};
tricu = pkgs.haskell.lib.justStaticExecutables self.packages.${system}.default;
tricuTests =
hsLib.overrideCabal tricuPackage (old: {
doCheck = true;
configureFlags = (old.configureFlags or []) ++ [
"--enable-tests"
];
checkPhase = ''
runHook preCheck
./Setup test tricu-tests --show-details=direct
runHook postCheck
'';
});
customGHC = haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
megaparsec
]);
in {
packages.${packageName} = tricuPackage;
packages.default = tricuPackage;
packages.${packageName} =
haskellPackages.callCabal2nix packageName self rec {};
packages.test = tricuTests;
checks.${packageName} = tricuTests;
checks.default = tricuTests;
packages.default = self.packages.${system}.${packageName};
defaultPackage = self.packages.${system}.default;
devShells.default = pkgs.mkShell {
@@ -39,9 +55,10 @@
customGHC
upx
];
inputsFrom = builtins.attrValues self.packages.${system};
};
devShell = self.devShells.${system}.default;
inputsFrom = [
tricuPackage
];
};
});
}

View File

@@ -1,19 +1,16 @@
module ContentStore where
import Research
import Parser
import Control.Monad (foldM, forM)
import Control.Monad (foldM, forM_, void)
import Data.ByteString (ByteString)
import Data.List (nub, sort)
import Data.Maybe (catMaybes, fromJust)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow (FromRow(..), field)
import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))
import System.FilePath ((</>), takeDirectory)
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.Text as T
@@ -47,7 +44,6 @@ initContentStore = do
execute_ conn "CREATE TABLE IF NOT EXISTS terms (\
\hash TEXT PRIMARY KEY, \
\names TEXT, \
\term_data BLOB, \
\metadata TEXT, \
\created_at INTEGER DEFAULT (strftime('%s','now')), \
\tags TEXT DEFAULT '')"
@@ -83,8 +79,8 @@ storeTerm conn newNamesStrList term = do
[] -> do
let allNamesToStore = serializeNameList newNamesTextList
execute conn
"INSERT INTO terms (hash, names, term_data, metadata, tags) VALUES (?, ?, ?, ?, ?)"
(termHashText, allNamesToStore, BS.pack [], metadataText, T.pack "")
"INSERT INTO terms (hash, names, metadata, tags) VALUES (?, ?, ?, ?)"
(termHashText, allNamesToStore, metadataText, T.pack "")
[(Only currentNamesText)] -> do
let currentNamesList = parseNameList currentNamesText
let combinedNamesList = currentNamesList ++ newNamesTextList
@@ -92,12 +88,13 @@ storeTerm conn newNamesStrList term = do
execute conn
"UPDATE terms SET names = ?, metadata = ? WHERE hash = ?"
(allNamesToStore, metadataText, termHashText)
_ -> error $ "Multiple terms with same hash? " ++ show (length existingNamesQuery)
_ -> errorWithoutStackTrace $ "Multiple terms with same hash? " ++ show (length existingNamesQuery)
return termHashText
-- | Reconstruct a Tree Calculus term from its Merkle root hash.
-- Recursively loads nodes and rebuilds the T structure.
loadTree :: Connection -> MerkleHash -> IO (Maybe T)
loadTree conn h
| h == nodeHash NLeaf = return (Just Leaf) -- NLeaf is implicit, not stored
| otherwise = do
@@ -107,12 +104,13 @@ loadTree conn h
Just node -> Just <$> buildTree node
where
buildTree :: Node -> IO T
buildTree NLeaf = return Leaf
buildTree (NStem childHash) = do
child <- fromJust <$> loadTree conn childHash
child <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn childHash
return (Stem child)
buildTree (NFork lHash rHash) = do
left <- fromJust <$> loadTree conn lHash
right <- fromJust <$> loadTree conn rHash
left <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn lHash
right <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn rHash
return (Fork left right)
-- | Store all nodes of a Merkle DAG by traversing the Term and building/storing nodes.
@@ -161,14 +159,14 @@ listStoredTerms :: Connection -> IO [StoredTerm]
listStoredTerms conn =
query_ conn (selectStoredTermFields <> " ORDER BY created_at DESC")
storeEnvironment :: Connection -> Env -> IO [(String, Text)]
storeEnvironment :: Connection -> Env -> IO ()
storeEnvironment conn env = do
let defs = Map.toList $ Map.delete "!result" env
let groupedDefs = Map.toList $ Map.fromListWith (++) [(term, [name]) | (name, term) <- defs]
forM groupedDefs $ \(term, namesList) -> do
hashVal <- storeTerm conn namesList term
return (head namesList, hashVal)
forM_ groupedDefs $ \(term, namesList) -> case namesList of
_:_ -> void $ storeTerm conn namesList term
_ -> errorWithoutStackTrace "storeEnvironment: empty names list"
loadTerm :: Connection -> String -> IO (Maybe T)
loadTerm conn identifier = do

View File

@@ -4,14 +4,32 @@ import ContentStore
import Parser
import Research
import Control.Monad (forM_, foldM)
import Data.List (partition, (\\))
import Data.Map (Map)
import Control.Monad (foldM)
import Data.List (partition, (\\), elemIndex, foldl')
import Data.Map ()
import Data.Set (Set)
import Database.SQLite.Simple
import qualified Data.Foldable as F ()
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.List (foldl')
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
@@ -41,12 +59,12 @@ evalSingle env term
evalTricu :: Env -> [TricuAST] -> Env
evalTricu env x = go env (reorderDefs env x)
where
go env [] = env
go env [x] =
let updatedEnv = evalSingle env x
go env' [] = env'
go env' [def] =
let updatedEnv = evalSingle env' def
in Map.insert "!result" (result updatedEnv) updatedEnv
go env (x:xs) =
evalTricu (evalSingle env x) xs
go env' (def:xs) =
evalTricu (evalSingle env' def) xs
evalASTSync :: Env -> TricuAST -> T
evalASTSync env term = case term of
@@ -111,7 +129,7 @@ resolveTermFromStore conn selectedVersions name mhash = case mhash of
case matchingVersions of
[] -> return Nothing
[(_, term, _)] -> return $ Just term
_ -> return Nothing -- Ambiguous or too many matches
_ -> return Nothing
Nothing -> case Map.lookup name selectedVersions of
Just hash -> loadTree conn hash
Nothing -> do
@@ -119,74 +137,88 @@ resolveTermFromStore conn selectedVersions name mhash = case mhash of
case versions of
[] -> return Nothing
[(_, term, _)] -> return $ Just term
_ -> return $ Just $ (\(_, t, _) -> t) $ head versions
_ -> return $ Just (head (map (\(_, t, _) -> t) versions))
elimLambda :: TricuAST -> TricuAST
elimLambda = go
where
go term
| etaReduction term = elimLambda $ etaReduceResult term
| etaReduction term = go (etaReduceResult term)
| triagePattern term = _TRI
| composePattern term = _B
| lambdaList term = elimLambda $ lambdaListResult term
| lambdaList term = go (lambdaListResult term)
| nestedLambda term = nestedLambdaResult term
| application term = applicationResult term
| isSList term = slistTransform term
| otherwise = term
etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (isFree v f)
etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (usesBinder v f)
etaReduction _ = False
etaReduceResult (SLambda [_] (SApp f _)) = f
triagePattern (SLambda [a] (SLambda [b] (SLambda [c] body))) = body == triageBody a b c
triagePattern (SLambda [a] (SLambda [b] (SLambda [c] body))) =
toDB [c,b,a] body == triageBodyDB
triagePattern _ = False
composePattern (SLambda [f] (SLambda [g] (SLambda [x] body))) = body == composeBody f g x
composePattern (SLambda [f] (SLambda [g] (SLambda [x] body))) =
toDB [x,g,f] body == composeBodyDB
composePattern _ = False
lambdaList (SLambda [_] (SList _)) = True
lambdaList _ = False
lambdaListResult (SLambda [v] (SList xs)) = SLambda [v] (foldr wrapTLeaf TLeaf xs)
wrapTLeaf m r = SApp (SApp TLeaf m) r
nestedLambda (SLambda (_:_) _) = True
nestedLambda _ = False
nestedLambdaResult (SLambda (v:vs) body)
| null vs = toSKI v (go body) -- Changed elimLambda to go
| otherwise = go (SLambda [v] (SLambda vs body)) -- Changed elimLambda to go
application (SApp _ _) = True
application _ = False
applicationResult (SApp f g) = SApp (go f) (go g) -- Changed elimLambda to go
etaReduceResult (SLambda [_] (SApp f _)) = f
etaReduceResult _ = error "etaReduceResult: expected SLambda [v] (SApp f _)"
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 if isSList is the guard
slistTransform ast = ast -- Should not be reached
toSKI x (SVar y Nothing)
| x == y = _I
| otherwise = SApp _K (SVar y Nothing)
toSKI x (SApp m n) = SApp (SApp _S (toSKI x m)) (toSKI x n)
toSKI x (SLambda [y] body) = toSKI x (toSKI y body) -- This should ideally not happen if lambdas are fully eliminated first
toSKI _ sl@(SList _) = SApp _K (go sl) -- Ensure SList itself is transformed if somehow passed to toSKI directly
toSKI _ term = SApp _K term
_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"
_S = parseSingle "t (t (t t t)) t"
_K = parseSingle "t t"
_I = parseSingle "t (t (t t)) t"
_B = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
_TRI = parseSingle "t (t (t t (t (t (t t t))))) t"
triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a Nothing)) (SVar b Nothing))) (SVar c Nothing)
composeBody f g x = SApp (SVar f Nothing) (SVar g Nothing) -- Note: This might not be the standard B combinator body f(g x)
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 = Set.member x . freeVars
isFree x t = Set.member x (freeVars t)
freeVars :: TricuAST -> Set.Set String
-- Keep old freeVars for compatibility with reorderDefs which still uses TricuAST
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)
@@ -242,7 +274,7 @@ buildDepGraph topDefs
sortDeps :: Map.Map String (Set.Set String) -> [String]
sortDeps graph = go [] Set.empty (Map.keys graph)
where
go sorted sortedSet [] = sorted
go sorted _sortedSet [] = sorted
go sorted sortedSet remaining =
let ready = [ name | name <- remaining
, let deps = Map.findWithDefault Set.empty name graph
@@ -273,22 +305,6 @@ mainResult r = case Map.lookup "main" r of
Just a -> a
Nothing -> errorWithoutStackTrace "No valid definition for `main` found."
evalWithEnv :: Env -> Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T
evalWithEnv env mconn selectedVersions ast = do
let varNames = findVarNames ast
resolvedEnv <- case mconn of
Just conn -> foldM (\e name ->
if Map.member name e
then return e
else do
mterm <- resolveTermFromStore conn selectedVersions name Nothing
case mterm of
Just term -> return $ Map.insert name term e
Nothing -> return e
) env varNames
Nothing -> return env
return $ evalASTSync resolvedEnv ast
findVarNames :: TricuAST -> [String]
findVarNames ast = case ast of
SVar name _ -> [name]
@@ -296,3 +312,283 @@ findVarNames ast = case ast of
SLambda args body -> findVarNames body \\ args
SDef name args body -> name : (findVarNames body \\ 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
SDef{} -> error "toDB: unexpected SDef 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 (BList xs) =
let anyUses = any (dependsOnLevel 0) xs
in if not anyUses
then SApp _K (SList (map fromDBClosed xs))
else SList (map toSKIDB xs)
toSKIDB _other = _K `SApp` TLeaf
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

View File

@@ -5,11 +5,11 @@ import Lexer
import Parser
import Research
import Control.Monad ()
import Data.List (partition)
import Data.Maybe (mapMaybe)
import Control.Monad (foldM)
import System.IO
import System.FilePath (takeDirectory, normalise, (</>))
import System.IO ()
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -17,12 +17,12 @@ import qualified Data.Set as Set
extractMain :: Env -> Either String T
extractMain env =
case Map.lookup "main" env of
Just result -> Right result
Just evalResult -> Right evalResult
Nothing -> Left "No `main` function detected"
processImports :: Set.Set FilePath -> FilePath -> FilePath -> [TricuAST]
-> Either String ([TricuAST], [(FilePath, String, FilePath)])
processImports seen base currentPath asts =
processImports seen _base currentPath asts =
let (imports, nonImports) = partition isImp asts
importPaths = mapMaybe getImportInfo imports
in if currentPath `Set.member` seen
@@ -40,11 +40,11 @@ evaluateFileResult filePath = do
let tokens = lexTricu contents
case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError err)
Right ast -> do
Right _ast -> do
processedAst <- preprocessFile filePath
let finalEnv = evalTricu Map.empty processedAst
case extractMain finalEnv of
Right result -> return result
Right evalResult -> return evalResult
Left err -> errorWithoutStackTrace err
evaluateFile :: FilePath -> IO Env
@@ -53,7 +53,7 @@ evaluateFile filePath = do
let tokens = lexTricu contents
case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError err)
Right ast -> do
Right _ast -> do
ast <- preprocessFile filePath
pure $ evalTricu Map.empty ast
@@ -63,7 +63,7 @@ evaluateFileWithContext env filePath = do
let tokens = lexTricu contents
case parseProgram tokens of
Left err -> errorWithoutStackTrace (handleParseError err)
Right ast -> do
Right _ast -> do
ast <- preprocessFile filePath
pure $ evalTricu env ast
@@ -84,8 +84,8 @@ preprocessFile' seen base currentPath = do
imported <- concat <$> mapM (processImportPath seen' base) importPaths
pure $ imported ++ nonImports
where
processImportPath seen base (path, name, importPath) = do
ast <- preprocessFile' seen base importPath
processImportPath _seen _base (_path, name, importPath) = do
ast <- preprocessFile' _seen _base importPath
pure $ map (nsDefinition (if name == "!Local" then "" else name))
$ filter (not . isImp) ast
isImp (SImport _ _) = True

View File

@@ -4,13 +4,12 @@ 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
import qualified Data.Set as Set
type Lexer = Parsec Void String
tricuLexer :: Lexer [LToken]
@@ -23,13 +22,13 @@ tricuLexer = do
]
sc
pure tok
tokens <- many $ do
toks <- many $ do
tok <- choice tricuLexer'
sc
pure tok
sc
eof
pure (header ++ tokens)
pure (header ++ toks)
where
tricuLexer' =
[ try lnewline
@@ -51,7 +50,7 @@ tricuLexer = do
lexTricu :: String -> [LToken]
lexTricu input = case runParser tricuLexer "" input of
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
Right tokens -> tokens
Right toks -> toks
keywordT :: Lexer LToken
@@ -143,8 +142,8 @@ integerLiteral = do
stringLiteral :: Lexer LToken
stringLiteral = do
char '"'
content <- manyTill Lexer.charLiteral (char '"')
void (char '"')
content <- manyTill Lexer.charLiteral (void (char '"'))
return (LStringLiteral content)
charLiteral :: Lexer Char
@@ -163,3 +162,4 @@ charLiteral = escapedChar <|> normalChar
'\\' -> '\\'
'"' -> '"'
'\'' -> '\''
_ -> c

View File

@@ -1,18 +1,18 @@
module Main where
import ContentStore ()
import Eval (evalTricu, mainResult, result)
import FileEval
import Parser (parseTricu)
import REPL
import Research
import ContentStore
import Control.Monad (foldM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.IO.Class ()
import Data.Version (showVersion)
import Text.Megaparsec (runParser)
import Paths_tricu (version)
import System.Console.CmdArgs
import Text.Megaparsec ()
import qualified Data.Map as Map
@@ -56,24 +56,24 @@ decodeMode = TDecode
main :: IO ()
main = do
let versionStr = "tricu Evaluator and REPL " ++ showVersion version
args <- cmdArgs $ modes [replMode, evaluateMode, decodeMode]
cmdArgsParsed <- cmdArgs $ modes [replMode, evaluateMode, decodeMode]
&= help "tricu: Exploring Tree Calculus"
&= program "tricu"
&= summary versionStr
&= versionArg [explicit, name "version", summary versionStr]
case args of
case cmdArgsParsed of
Repl -> do
putStrLn "Welcome to the tricu REPL"
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
repl
Evaluate { file = filePaths, form = form } -> do
result <- case filePaths of
Evaluate { file = filePaths, form = outputForm } -> do
evalResult <- case filePaths of
[] -> runTricuT <$> getContents
(filePath:restFilePaths) -> do
initialEnv <- evaluateFile filePath
finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
pure $ mainResult finalEnv
let fRes = formatT form result
let fRes = formatT outputForm evalResult
putStr fRes
TDecode { file = filePaths } -> do
value <- case filePaths of

View File

@@ -8,7 +8,7 @@ import Control.Monad.State
import Data.List.NonEmpty (toList)
import Data.Void (Void)
import Text.Megaparsec
import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
import qualified Data.Set as Set
data PState = PState
@@ -20,9 +20,9 @@ type ParserM = StateT PState (Parsec Void [LToken])
satisfyM :: (LToken -> Bool) -> ParserM LToken
satisfyM f = do
token <- lift (satisfy f)
modify' (updateDepth token)
return token
tok <- lift (satisfy f)
modify' (updateDepth tok)
return tok
updateDepth :: LToken -> PState -> PState
updateDepth LOpenParen st = st { parenDepth = parenDepth st + 1 }
@@ -39,12 +39,12 @@ topLevelNewline = do
else fail "Top-level exit in nested context (paren or bracket)"
parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
parseProgram tokens =
runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
parseProgram toks =
runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" toks
parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
parseSingleExpr tokens =
runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
parseSingleExpr toks =
runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" toks
finalizeDepth :: ParserM ()
finalizeDepth = do
@@ -195,6 +195,7 @@ parseTreeTermM = do
| TLeaf <- acc = TStem next
| TStem t <- acc = TFork t next
| TFork _ _ <- acc = TFork acc next
| otherwise = SApp acc next
parseTreeLeafOrParenthesizedM :: ParserM TricuAST
parseTreeLeafOrParenthesizedM = choice
@@ -248,20 +249,20 @@ parseGroupedItemM = do
parseSingleItemM :: ParserM TricuAST
parseSingleItemM = do
token <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
if | LIdentifier name <- token -> pure (SVar name Nothing)
| token == LKeywordT -> pure TLeaf
tok <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
if | LIdentifier name <- tok -> pure (SVar name Nothing)
| tok == LKeywordT -> pure TLeaf
| otherwise -> fail "Unexpected token in list item"
parseVarM :: ParserM TricuAST
parseVarM = do
token <- satisfyM (\case
tok <- satisfyM (\case
LNamespace _ -> True
LIdentifier _ -> True
LIdentifierWithHash _ _ -> True
_ -> False)
case token of
case tok of
LNamespace ns -> do
_ <- satisfyM (== LDot)
LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False)
@@ -282,8 +283,8 @@ parseVarM = do
parseIntLiteralM :: ParserM TricuAST
parseIntLiteralM = do
let intL = (\case LIntegerLiteral _ -> True; _ -> False)
token <- satisfyM intL
if | LIntegerLiteral value <- token ->
tok <- satisfyM intL
if | LIntegerLiteral value <- tok ->
pure (SInt (fromIntegral value))
| otherwise ->
fail "Unexpected token while parsing integer literal"
@@ -291,8 +292,8 @@ parseIntLiteralM = do
parseStrLiteralM :: ParserM TricuAST
parseStrLiteralM = do
let strL = (\case LStringLiteral _ -> True; _ -> False)
token <- satisfyM strL
if | LStringLiteral value <- token ->
tok <- satisfyM strL
if | LStringLiteral value <- tok ->
pure (SStr value)
| otherwise ->
fail "Unexpected token while parsing string literal"
@@ -308,8 +309,8 @@ handleParseError bundle =
in unlines ("Parse error(s) encountered:" : formattedErrors)
formatError :: ParseError [LToken] Void -> String
formatError (TrivialError offset unexpected expected) =
let unexpectedMsg = case unexpected of
formatError (TrivialError offset msgUnexpected expected) =
let unexpectedMsg = case msgUnexpected of
Just x -> "unexpected token " ++ show x
Nothing -> "unexpected end of input"
expectedMsg = if null expected

View File

@@ -1,48 +1,41 @@
module REPL where
import ContentStore
import Eval
import FileEval
import Lexer
import Lexer ()
import Parser
import Research
import ContentStore
import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
import Control.Monad (forever, void, when, forM, forM_, foldM, unless)
import Data.ByteString (ByteString)
import Data.Maybe (isNothing, isJust, fromJust, catMaybes)
import Database.SQLite.Simple (Connection, Only(..), query, query_, execute, execute_, open)
import Control.Exception (SomeException, catch, displayException)
import Control.Monad ()
import Control.Monad (forever, when, forM_, foldM, unless)
import Control.Monad.Catch (handle)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class ()
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Data.ByteString ()
import Data.Char (isSpace)
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.List (dropWhileEnd, isPrefixOf, find)
import Data.Maybe (isJust, fromJust)
import Data.Time (getCurrentTime, diffUTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
import Data.Version (showVersion)
import Database.SQLite.Simple (Connection, Only(..), query)
import Paths_tricu (version)
import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..), Color(..))
import System.Console.Haskeline
import System.Directory (doesFileExist, createDirectoryIfMissing)
import System.FSNotify
import System.FilePath (takeDirectory, (</>))
import Text.Read (readMaybe)
import Control.Exception (IOException, SomeException, catch
, displayException)
import Control.Monad (forM_)
import Control.Monad.Catch (handle, MonadCatch)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Data.Char (isSpace, isUpper)
import Data.List ((\\), dropWhile, dropWhileEnd, isPrefixOf, nub, sortBy, groupBy, intercalate, find)
import Data.Version (showVersion)
import Paths_tricu (version)
import System.Console.Haskeline
import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..),
Color(..), ConsoleIntensity(..), clearFromCursorToLineEnd)
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Control.Concurrent (forkIO, threadDelay)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Time (UTCTime, getCurrentTime, diffUTCTime)
import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar)
import Data.Time.Format (formatTime, defaultTimeLocale)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified Data.Text.IO as T ()
data REPLState = REPLState
{ replForm :: EvaluatedForm
@@ -121,26 +114,26 @@ repl = do
| "!tag" `isPrefixOf` strip s -> handleTag state
| take 2 s == "--" -> loop state
| otherwise -> do
result <- liftIO $ catch
evalResult <- liftIO $ catch
(processInput state s)
(errorHandler state)
loop result
loop evalResult
handleOutput :: REPLState -> InputT IO ()
handleOutput state = do
let formats = [Decode, TreeCalculus, FSL, AST, Ternary, Ascii]
outputStrLn "Available output formats:"
mapM_ (\(i, f) -> outputStrLn $ show i ++ ". " ++ show f)
mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f)
(zip [1..] formats)
result <- runMaybeT $ do
evalResult <- runMaybeT $ do
input <- MaybeT $ getInputLine "Select output format (1-6) < "
case reads input of
[(n, "")] | n >= 1 && n <= 6 ->
return $ formats !! (n-1)
_ -> MaybeT $ return Nothing
case result of
case evalResult of
Nothing -> do
outputStrLn "Invalid selection. Keeping current output format."
loop state
@@ -201,7 +194,7 @@ repl = do
importFile :: REPLState -> String -> InputT IO ()
importFile state cleanFilename = do
code <- liftIO $ readFile cleanFilename
_code <- liftIO $ readFile cleanFilename
case replContentStore state of
Nothing -> do
liftIO $ printError "Content store not initialized"
@@ -216,7 +209,7 @@ repl = do
importedCount <- foldM (\count (name, term) -> do
hash <- ContentStore.storeTerm conn [name] term
printSuccess $ "Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
return (count + 1)
return (count + (1 :: Int))
) 0 defs
printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully"
@@ -248,7 +241,7 @@ repl = do
lastProcessedRef <- liftIO $ newIORef =<< getCurrentTime
watcherId <- liftIO $ forkIO $ withManager $ \mgr -> do
stopAction <- watchDir mgr dirPath (\event -> eventPath event == filepath) $ \event -> do
_stopAction <- watchDir mgr dirPath (\ev -> eventPath ev == filepath) $ \_ -> do
now <- getCurrentTime
lastProcessed <- readIORef lastProcessedRef
when (diffUTCTime now lastProcessed > 0.5) $ do
@@ -259,8 +252,8 @@ repl = do
watchLoop state { replWatchedFile = Just filepath, replWatcherThread = Just watcherId }
handleUnwatch :: REPLState -> InputT IO ()
handleUnwatch state = case replWatchedFile state of
_handleUnwatch :: REPLState -> InputT IO ()
_handleUnwatch state = case replWatchedFile state of
Nothing -> do
outputStrLn "No file is currently being watched"
loop state
@@ -275,7 +268,7 @@ repl = do
Nothing -> do
outputStrLn "Content store not initialized"
loop state
Just conn -> do
Just _conn -> do
outputStrLn "Environment refreshed from content store (definitions are live)"
loop state
@@ -486,8 +479,8 @@ repl = do
forM_ asts $ \ast -> do
case ast of
SDef name [] body -> do
result <- evalAST (Just conn) (replSelectedVersions newState) body
hash <- ContentStore.storeTerm conn [name] result
evalResult <- evalAST (Just conn) (replSelectedVersions newState) body
hash <- ContentStore.storeTerm conn [name] evalResult
liftIO $ do
putStr "tricu > "
@@ -498,14 +491,14 @@ repl = do
putStrLn ""
putStr "tricu > "
printResult $ formatT (replForm newState) result
printResult $ formatT (replForm newState) evalResult
putStrLn ""
_ -> do
result <- evalAST (Just conn) (replSelectedVersions newState) ast
evalResult <- evalAST (Just conn) (replSelectedVersions newState) ast
liftIO $ do
putStr "tricu > "
printResult $ formatT (replForm newState) result
printResult $ formatT (replForm newState) evalResult
putStrLn ""
return newState
@@ -531,13 +524,13 @@ repl = do
Just conn -> do
forM_ asts $ \ast -> case ast of
SDef name [] body -> do
result <- evalAST (Just conn) selectedVersions body
hash <- ContentStore.storeTerm conn [name] result
evalResult <- evalAST (Just conn) selectedVersions body
hash <- ContentStore.storeTerm conn [name] evalResult
putStrLn $ "tricu > Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm result
putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm evalResult
_ -> do
result <- evalAST (Just conn) selectedVersions ast
putStrLn $ "tricu > Result: " ++ formatT outputForm result
evalResult <- evalAST (Just conn) selectedVersions ast
putStrLn $ "tricu > Result: " ++ formatT outputForm evalResult
putStrLn $ "tricu > Processed file: " ++ filepath
formatTimestamp :: Integer -> String
@@ -552,12 +545,6 @@ repl = do
putStr $ T.unpack rest
setSGR [Reset]
coloredHashString :: T.Text -> String
coloredHashString hash =
"\ESC[1;36m" ++ T.unpack (T.take 16 hash) ++
"\ESC[0;37m" ++ T.unpack (T.drop 16 hash) ++
"\ESC[0m"
withColor :: ColorIntensity -> Color -> IO () -> IO ()
withColor intensity color action = do
setSGR [SetColor Foreground intensity color]

View File

@@ -1,17 +1,17 @@
module Research where
import Crypto.Hash (hash, SHA256, Digest)
import Data.ByteArray (convert)
import Data.Char (chr, ord)
import Data.ByteString.Base16 (decode, encode)
import Data.List (intercalate)
import Data.Map (Map)
import Data.Text (Text, replace, unpack)
import Data.Word (Word8)
import Data.Map ()
import Data.Text (Text, replace)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import System.Console.CmdArgs (Data, Typeable)
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.Text as T
import Crypto.Hash (hash, SHA256, Digest)
-- Tree Calculus Types
data T = Leaf | Stem T | Fork T T
@@ -19,7 +19,7 @@ data T = Leaf | Stem T | Fork T T
-- Abstract Syntax Tree for tricu
data TricuAST
= SVar String (Maybe String) -- Variable name and optional hash prefix
= SVar String (Maybe String)
| SInt Integer
| SStr String
| SList [TricuAST]
@@ -76,36 +76,21 @@ data Node
-- 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] <> hexToBytes h
serializeNode (NFork l r) = BS.pack [0x02] <> hexToBytes l <> hexToBytes r
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( "tricu.merkle.node.v1" <> 0x00 <> node_payload )
nodeHash :: Node -> MerkleHash
nodeHash node = bytesToHex (sha256WithPrefix (serializeNode node))
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 "tricu.merkle.node.v1"
-- | Convert a Hex Text hash into raw ByteString (2 hex chars per byte)
hexToBytes :: Text -> BS.ByteString
hexToBytes h = BS.pack $ map combinePair pairs
where
chars = unpack h
pairs = chunkPairs chars
chunkPairs :: String -> [(Char, Char)]
chunkPairs (c1:c2:rest) = (c1, c2) : chunkPairs rest
chunkPairs [] = []
chunkPairs _ = error "hexToBytes: odd number of hex digits"
combinePair :: (Char, Char) -> Word8
combinePair (c1, c2) = fromIntegral (hexDigitToInt c1 * 16 + hexDigitToInt c2)
hexDigitToInt :: Char -> Int
hexDigitToInt c
| '0' <= c && c <= '9' = ord c - ord '0'
| 'a' <= c && c <= 'f' = ord c - ord 'a' + 10
| 'A' <= c && c <= 'F' = ord c - ord 'A' + 10
| otherwise = error $ "Invalid hex digit: " ++ show c
-- | Deserialize a Node from canonical bytes.
deserializeNode :: BS.ByteString -> Node
deserializeNode bs =
@@ -115,26 +100,14 @@ deserializeNode bs =
Just (0x01, rest)
| BS.length rest == 32 ->
NStem $ bytesToHex rest
NStem $ decodeUtf8 (encode rest)
Just (0x02, rest)
| BS.length rest == 64 ->
let (l, r) = BS.splitAt 32 rest
in NFork (bytesToHex l) (bytesToHex r)
in NFork (decodeUtf8 (encode l)) (decodeUtf8 (encode r))
_ -> error "invalid merkle node payload"
-- | Convert 32-byte ByteString back to hex Text
bytesToHex :: BS.ByteString -> Text
bytesToHex bs = T.pack $ concatMap byteToHexChars $ BS.unpack bs
where
byteToHexChars :: Word8 -> String
byteToHexChars w = [hexDigit (fromIntegral w `div` 16), hexDigit (fromIntegral w `mod` 16)]
hexDigit :: Int -> Char
hexDigit n
| n < 10 = chr (ord '0' + n)
| otherwise = chr (ord 'a' + n - 10)
_ -> errorWithoutStackTrace "invalid merkle node payload"
-- | Build a Merkle DAG from a Tree Calculus term.
buildMerkle :: T -> Node
@@ -158,9 +131,9 @@ buildMerkle (Fork l r) = NFork (nodeHash left) (nodeHash right)
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
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
@@ -202,7 +175,7 @@ toNumber _ = Left "Invalid Tree Calculus number"
toString :: T -> Either String String
toString tc = case toList tc of
Right list -> traverse (fmap (toEnum . fromInteger) . toNumber) list
Left err -> Left "Invalid Tree Calculus string"
Left _ -> Left "Invalid Tree Calculus string"
toList :: T -> Either String [T]
toList Leaf = Right []

View File

@@ -32,8 +32,10 @@ tests = testGroup "Tricu Tests"
, providedLibraries
, fileEval
, modules
-- , demos
, demos
, decoding
, elimLambdaSingle
, stressElimLambda
]
lexer :: TestTree
@@ -532,7 +534,7 @@ demos = testGroup "Test provided demo functionality"
decodeResult res @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\""
, testCase "Determining the size of functions" $ do
res <- liftIO $ evaluateFileResult "./demos/size.tri"
decodeResult res @?= "454"
decodeResult res @?= "321"
, testCase "Level Order Traversal demo" $ do
res <- liftIO $ evaluateFileResult "./demos/levelOrderTraversal.tri"
decodeResult res @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \""
@@ -569,3 +571,72 @@ decoding = testGroup "Decoding Tests"
let input = ofList [ofList [ofString "nested"], ofString "string"]
decodeResult input @?= "[[\"nested\"], \"string\"]"
]
elimLambdaSingle :: TestTree
elimLambdaSingle = testCase "elimLambda preserves eval, fires eta, and SDef binds" $ do
-- 1) eta reduction, purely structural and parsed from source
let [etaIn] = parseTricu "x : f x"
[fRef ] = parseTricu "f"
elimLambda etaIn @?= fRef
-- 2) SDef binds its own name and parameters
let [defFXY] = parseTricu "f x y : f x"
fv = freeVars defFXY
assertBool "f should be bound in SDef" ("f" `Set.notMember` fv)
assertBool "x should be bound in SDef" ("x" `Set.notMember` fv)
assertBool "y should be bound in SDef" ("y" `Set.notMember` fv)
-- 3) semantics preserved on a small program that exercises compose and triage
let src =
unlines
[ "false = t"
, "_ = t"
, "true = t t"
, "id = a : a"
, "const = a b : a"
, "compose = f g x : f (g x)"
, "triage = leaf stem fork : t (t leaf stem) fork"
, "test = triage \"Leaf\" (_ : \"Stem\") (_ _ : \"Fork\")"
, "main = compose id id test"
]
prog = parseTricu src
progElim = map elimLambda prog
evalBefore = result (evalTricu Map.empty prog)
evalAfter = result (evalTricu Map.empty progElim)
evalAfter @?= evalBefore
stressElimLambda :: TestTree
stressElimLambda = testCase "stress elimLambda on wide list under deep curried lambda" $ do
let numVars = 200
numBody = 800
vars = [ "x" ++ show i | i <- [1..numVars] ]
body = "(" ++ unwords (replicate numBody "t") ++ ")"
etaOne = "h : f h"
etaTwo = "k : id k"
defId = "id = a : a"
lambda = unwords vars ++ " : " ++ body
src = unlines
[ defId
, etaOne
, "compose = f g x : f (g x)"
, "f = t t"
, etaTwo
, lambda
, "main = compose id id (" ++ head vars ++ " : f " ++ head vars ++ ")"
]
prog = parseTricu src
let out = map elimLambda prog
let noLambda term = case term of
SLambda _ _ -> False
SApp f g -> noLambda f && noLambda g
SList xs -> all noLambda xs
TFork l r -> noLambda l && noLambda r
TStem u -> noLambda u
_ -> True
assertBool "all lambdas eliminated" (all noLambda out)
let before = result (evalTricu Map.empty prog)
after = result (evalTricu Map.empty out)
after @?= before

View File

@@ -1,8 +1,8 @@
cabal-version: 1.12
name: tricu
version: 1.0.0
description: A micro-language for exploring Tree Calculus
version: 1.1.0
description: A language for exploring Tree Calculus
author: James Eversole
maintainer: james@eversole.co
copyright: James Eversole
@@ -15,18 +15,31 @@ extra-source-files:
executable tricu
main-is: Main.hs
hs-source-dirs:
src
src
default-extensions:
DeriveDataTypeable
LambdaCase
MultiWayIf
OverloadedStrings
ScopedTypeVariables
ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
DeriveDataTypeable
LambdaCase
MultiWayIf
OverloadedStrings
ScopedTypeVariables
ghc-options:
-Wall
-Wcompat
-Wunused-imports
-Wunused-top-binds
-Wunused-local-binds
-Wunused-matches
-Wredundant-constraints
-threaded
-rtsopts
-with-rtsopts=-N
-optl-pthread
-fPIC
build-depends:
base >=4.7
, aeson
, ansi-terminal
, base16-bytestring
, base64-bytestring
, bytestring
, cereal
@@ -49,10 +62,12 @@ executable tricu
, transformers
, zlib
other-modules:
ContentStore
Eval
FileEval
Lexer
Parser
Paths_tricu
REPL
Research
default-language: Haskell2010
@@ -71,6 +86,7 @@ test-suite tricu-tests
base >=4.7
, aeson
, ansi-terminal
, base16-bytestring
, base64-bytestring
, bytestring
, cereal
@@ -94,9 +110,11 @@ test-suite tricu-tests
, zlib
default-language: Haskell2010
other-modules:
ContentStore
Eval
FileEval
Lexer
Parser
Paths_tricu
REPL
Research