Compare commits
6 Commits
contentsto
...
efbe9350ed
| Author | SHA1 | Date | |
|---|---|---|---|
| efbe9350ed | |||
| 2627627493 | |||
| c008126b14 | |||
|
|
71653311ce | ||
| 0cdc0bfc34 | |||
| c36d963640 |
177
AGENTS.md
Normal file
177
AGENTS.md
Normal 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: 16–64 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.
|
||||
28
README.md
28
README.md
@@ -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
|
||||
|
||||
49
flake.nix
49
flake.nix
@@ -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
|
||||
];
|
||||
};
|
||||
});
|
||||
}
|
||||
|
||||
@@ -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
|
||||
|
||||
412
src/Eval.hs
412
src/Eval.hs
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
14
src/Lexer.hs
14
src/Lexer.hs
@@ -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
|
||||
|
||||
16
src/Main.hs
16
src/Main.hs
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
101
src/REPL.hs
101
src/REPL.hs
@@ -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]
|
||||
|
||||
@@ -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 []
|
||||
|
||||
75
test/Spec.hs
75
test/Spec.hs
@@ -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
|
||||
|
||||
36
tricu.cabal
36
tricu.cabal
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user