Compare commits
No commits in common. "main" and "fix/comments-0001" have entirely different histories.
main
...
fix/commen
17
.gitignore
vendored
17
.gitignore
vendored
@ -1,11 +1,14 @@
|
||||
bin/
|
||||
data/Purr.sqlite
|
||||
data/encryptionKey
|
||||
/result
|
||||
/config.dhall
|
||||
/Dockerfile
|
||||
/docker-stack.yml
|
||||
.stack-work/
|
||||
*.swp
|
||||
*.txt
|
||||
dist*
|
||||
*~
|
||||
.env
|
||||
.stack-work/
|
||||
/Dockerfile
|
||||
/config.dhall
|
||||
/result
|
||||
WD
|
||||
bin/
|
||||
dist*
|
||||
*.hs.txt
|
||||
|
||||
74
README.md
74
README.md
@ -19,62 +19,42 @@ tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)
|
||||
## What does it look like?
|
||||
|
||||
```
|
||||
tricu < -- Anything after `--` on a single line is a comment
|
||||
tricu < id = (\a : a) -- Lambda abstraction is eliminated to tree calculus terms
|
||||
tricu < head (map (\i : lconcat i " world!") [("Hello, ")])
|
||||
tricu > "Hello, world!"
|
||||
tricu < id (head (map (\i : lconcat i " world!") [("Hello, ")]))
|
||||
tricu > "Hello, world!"
|
||||
-- Anything after `--` on a single line is a comment
|
||||
-- We can define functions or "variables" as Tree Calculus values
|
||||
false = t
|
||||
_ = t
|
||||
true = t t
|
||||
-- We can define functions as lambda expressions that are eliminated to Tree
|
||||
-- Calculus terms.
|
||||
id = (\a : a) -- `id` evaluates to the TC form of: t (t (t t)) t
|
||||
triage = (\a b c : t (t a b) c)
|
||||
-- Intensionality! We can inspect program structure, not just inputs/outputs:
|
||||
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
|
||||
|
||||
tricu < -- Intensionality! We can inspect the structure of a function.
|
||||
tricu < triage = (\a b c : t (t a b) c)
|
||||
tricu < test = triage "Leaf" (\z : "Stem") (\a b : "Fork")
|
||||
tricu < test t t
|
||||
tricu > "Stem"
|
||||
tricu < -- We can even write a function to convert a function to source code
|
||||
tricu < toTString id
|
||||
tricu > "t (t (t t)) t"
|
||||
-- REPL
|
||||
-- `tricu <` is the input prompt
|
||||
-- `tricu >` is the Tree Calculus form output. Most are elided below.
|
||||
-- `READ -:` is an attempt to interpret the TC output as strings/numbers.
|
||||
tricu < test t
|
||||
tricu > Fork (Fork Leaf (Fork ...) ... )
|
||||
READ -: "Leaf"
|
||||
tricu < test (t t)
|
||||
READ -: "Stem"
|
||||
tricu < test (t t t)
|
||||
READ -: "Fork"
|
||||
tricu < map (\i : listConcat i " is super cool!") [("Tree Calculus") ("Intensionality") ("tricu")]
|
||||
READ -: ["Tree Calculus is super cool!", "Intensionality is super cool!", "tricu is super cool!"]
|
||||
```
|
||||
|
||||
## Installation and Use
|
||||
## Installation
|
||||
|
||||
You can easily build and/or run this project using [Nix](https://nixos.org/download/).
|
||||
|
||||
- Quick Start (REPL):
|
||||
- Run REPL immediately:
|
||||
- `nix run git+https://git.eversole.co/James/tricu`
|
||||
- Build executable in `./result/bin`:
|
||||
- Build REPL executable in `./result/bin`:
|
||||
- `nix build git+https://git.eversole.co/James/tricu`
|
||||
|
||||
`./result/bin/tricu --help`
|
||||
|
||||
```
|
||||
tricu Evaluator and REPL
|
||||
|
||||
tricu [COMMAND] ... [OPTIONS]
|
||||
tricu: Exploring Tree Calculus
|
||||
|
||||
Common flags:
|
||||
-? --help Display help message
|
||||
-V --version Print version information
|
||||
|
||||
tricu [repl] [OPTIONS]
|
||||
Start interactive REPL
|
||||
|
||||
tricu eval [OPTIONS]
|
||||
Evaluate tricu and return the result of the final expression.
|
||||
|
||||
-f --file=FILE Input file path(s) for evaluation.
|
||||
Defaults to stdin.
|
||||
-t --form=FORM Optional output form: (tree|fsl|ast|ternary|ascii).
|
||||
Defaults to tricu-compatible `t` tree form.
|
||||
|
||||
tricu decode [OPTIONS]
|
||||
Decode a Tree Calculus value into a string representation.
|
||||
|
||||
-f --file=FILE Optional input file path to attempt decoding.
|
||||
Defaults to stdin.
|
||||
```
|
||||
|
||||
## Acknowledgements
|
||||
|
||||
Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog).
|
||||
|
||||
@ -1,34 +0,0 @@
|
||||
-- Level Order Traversal of a labelled binary tree
|
||||
-- Objective: Print each "level" of the tree on a separate line
|
||||
--
|
||||
-- NOTICE: This demo relies on tricu base library functions
|
||||
--
|
||||
-- We model labelled binary trees as sublists where values act as labels. We
|
||||
-- require explicit notation of empty nodes. Empty nodes can be represented
|
||||
-- with an empty list, `[]`, which is equivalent to a single node `t`.
|
||||
--
|
||||
-- Example tree inputs:
|
||||
-- [("1") [("2") [("4") t t] t] [("3") [("5") t t] [("6") t t]]]]
|
||||
-- Graph:
|
||||
-- 1
|
||||
-- / \
|
||||
-- 2 3
|
||||
-- / / \
|
||||
-- 4 5 6
|
||||
--
|
||||
|
||||
isLeaf = (\node : lOr (emptyList node) (emptyList (tail node)))
|
||||
getLabel = (\node : head node)
|
||||
getLeft = (\node : if (emptyList node) [] (if (emptyList (tail node)) [] (head (tail node))))
|
||||
getRight = (\node : if (emptyList node) [] (if (emptyList (tail node)) [] (if (emptyList (tail (tail node))) [] (head (tail (tail node))))))
|
||||
|
||||
processLevel = y (\self queue : if (emptyList queue) [] (pair (map getLabel queue) (self (filter (\node : not (emptyList node)) (lconcat (map getLeft queue) (map getRight queue))))))
|
||||
levelOrderTraversal = (\a : processLevel (t a t))
|
||||
toLineString = y (\self levels : if (emptyList levels) "" (lconcat (lconcat (map (\x : lconcat x " ") (head levels)) "") (if (emptyList (tail levels)) "" (lconcat (t (t 10 t) t) (self (tail levels))))))
|
||||
levelOrderToString = (\s : toLineString (levelOrderTraversal s))
|
||||
|
||||
flatten = foldl (\acc x : lconcat acc x) ""
|
||||
flatLOT = (\s : lconcat (t 10 t) (flatten (levelOrderToString s)))
|
||||
|
||||
exampleOne = flatLOT [("1") [("2") [("4") t t] t] [("3") [("5") t t] [("6") t t]]]]
|
||||
exampleTwo = flatLOT [("1") [("2") [("4") [("8") t t] [("9") t t]] [("6") [("10") t t] [("12") t t]]] [("3") [("5") [("11") t t] t] [("7") t t]]]
|
||||
41
lib/base.tri
41
lib/base.tri
@ -1,41 +0,0 @@
|
||||
false = t
|
||||
_ = t
|
||||
true = t t
|
||||
k = t t
|
||||
i = t (t k) t
|
||||
s = t (t (k t)) t
|
||||
m = s i i
|
||||
b = s (k s) k
|
||||
c = s (s (k s) (s (k k) s)) (k k)
|
||||
iC = (\a b c : s a (k c) b)
|
||||
iD = b (b iC) iC
|
||||
iE = b (b iD) iC
|
||||
yi = (\i : b m (c b (i m)))
|
||||
y = yi iC
|
||||
yC = yi iD
|
||||
yD = yi iE
|
||||
id = (\a : a)
|
||||
triage = (\a b c : t (t a b) c)
|
||||
pair = t
|
||||
matchBool = (\ot of : triage of (\_ : ot) (\_ _ : ot))
|
||||
matchList = (\oe oc : triage oe _ oc)
|
||||
matchPair = (\op : triage _ _ op)
|
||||
not = matchBool false true
|
||||
and = matchBool id (\z : false)
|
||||
if = (\cond then else : t (t else (t t then)) t cond)
|
||||
test = triage "Leaf" (\z : "Stem") (\a b : "Fork")
|
||||
emptyList = matchList true (\y z : false)
|
||||
head = matchList t (\hd tl : hd)
|
||||
tail = matchList t (\hd tl : tl)
|
||||
lconcat = y (\self : matchList (\k : k) (\h r k : pair h (self r k)))
|
||||
lAnd = triage (\x : false) (\_ x : x) (\_ _ x : x)
|
||||
lOr = triage (\x : x) (\_ _ : true) (\_ _ x : true)
|
||||
hmap = y (\self : matchList (\f : t) (\hd tl f : pair (f hd) (self tl f)))
|
||||
map = (\f l : hmap l f)
|
||||
equal = y (\self : triage (triage true (\z : false) (\y z : false)) (\ax : triage false (self ax) (\y z : false)) (\ax ay : triage false (\z : false) (\bx by : lAnd (self ax bx) (self ay by))))
|
||||
hfilter = y (\self : matchList (\f : t) (\hd tl f : matchBool (t hd) i (f hd) (self tl f)))
|
||||
filter = (\f l : hfilter l f)
|
||||
hfoldl = y (\self f l x : matchList (\acc : acc) (\hd tl acc : self f tl (f acc hd)) l x)
|
||||
foldl = (\f x l : hfoldl f l x)
|
||||
hfoldr = y (\self x f l : matchList x (\hd tl : f (self x f tl) hd) l)
|
||||
foldr = (\f x l : hfoldr x f l)
|
||||
8
shell.nix
Normal file
8
shell.nix
Normal file
@ -0,0 +1,8 @@
|
||||
{ pkgs ? import <nixpkgs> {} }:
|
||||
let x = pkgs.haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
|
||||
megaparsec
|
||||
]);
|
||||
in
|
||||
pkgs.mkShell {
|
||||
buildInputs = [ x ];
|
||||
}
|
||||
54
src/Eval.hs
54
src/Eval.hs
@ -3,7 +3,8 @@ module Eval where
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
import Data.Map (Map)
|
||||
import Data.Map (Map)
|
||||
import Data.List (foldl')
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
@ -13,7 +14,7 @@ evalSingle env term = case term of
|
||||
SFunc name [] body ->
|
||||
let lineNoLambda = eliminateLambda body
|
||||
result = evalAST env lineNoLambda
|
||||
in Map.insert "__result" result (Map.insert name result env)
|
||||
in Map.insert name result env
|
||||
SLambda _ body ->
|
||||
let result = evalAST env body
|
||||
in Map.insert "__result" result env
|
||||
@ -23,41 +24,39 @@ evalSingle env term = case term of
|
||||
SVar name ->
|
||||
case Map.lookup name env of
|
||||
Just value -> Map.insert "__result" value env
|
||||
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
||||
Nothing -> error $ "Variable " ++ name ++ " not defined"
|
||||
_ ->
|
||||
let result = evalAST env term
|
||||
in Map.insert "__result" result env
|
||||
|
||||
evalTricu :: Map String T -> [TricuAST] -> Map String T
|
||||
evalTricu env list = evalTricu' env (filter (/= SEmpty) list)
|
||||
where
|
||||
evalTricu' :: Map String T -> [TricuAST] -> Map String T
|
||||
evalTricu' env [] = env
|
||||
evalTricu' env [lastLine] =
|
||||
evalTricu env [] = env
|
||||
evalTricu env [lastLine] =
|
||||
let lastLineNoLambda = eliminateLambda lastLine
|
||||
updatedEnv = evalSingle env lastLineNoLambda
|
||||
in Map.insert "__result" (result updatedEnv) updatedEnv
|
||||
evalTricu' env (line:rest) =
|
||||
evalTricu env (line:rest) =
|
||||
let lineNoLambda = eliminateLambda line
|
||||
updatedEnv = evalSingle env lineNoLambda
|
||||
in evalTricu updatedEnv rest
|
||||
|
||||
evalAST :: Map String T -> TricuAST -> T
|
||||
evalAST env term = case term of
|
||||
SVar name -> case Map.lookup name env of
|
||||
Just value -> value
|
||||
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
||||
TLeaf -> Leaf
|
||||
TStem t -> Stem (evalAST env t)
|
||||
TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2)
|
||||
SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2)
|
||||
SStr str -> ofString str
|
||||
SInt num -> ofNumber num
|
||||
SList elems -> ofList (map (evalAST env) elems)
|
||||
SEmpty -> Leaf
|
||||
SFunc name args body ->
|
||||
errorWithoutStackTrace $ "Unexpected function definition " ++ name
|
||||
SLambda {} -> errorWithoutStackTrace "Internal error: SLambda found in evalAST after elimination."
|
||||
SVar name -> case Map.lookup name env of
|
||||
Just value -> value
|
||||
Nothing -> error $ "Variable " ++ name ++ " not defined"
|
||||
TLeaf -> Leaf
|
||||
TStem t -> Stem (evalAST env t)
|
||||
TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2)
|
||||
SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2)
|
||||
SStr str -> ofString str
|
||||
SInt num -> ofNumber num
|
||||
SList elems -> ofList (map (evalAST Map.empty) elems)
|
||||
SEmpty -> Leaf
|
||||
SFunc name args body ->
|
||||
error $ "Unexpected function definition " ++ name
|
||||
++ " in evalAST; define via evalSingle."
|
||||
SLambda {} -> error "Internal error: SLambda found in evalAST after elimination."
|
||||
|
||||
eliminateLambda :: TricuAST -> TricuAST
|
||||
eliminateLambda (SLambda (v:vs) body)
|
||||
@ -100,6 +99,11 @@ freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
|
||||
isFree :: String -> TricuAST -> Bool
|
||||
isFree x = Set.member x . freeVars
|
||||
|
||||
toAST :: T -> TricuAST
|
||||
toAST Leaf = TLeaf
|
||||
toAST (Stem a) = TStem (toAST a)
|
||||
toAST (Fork a b) = TFork (toAST a) (toAST b)
|
||||
|
||||
-- We need the SKI operators in an unevaluated TricuAST tree form so that we
|
||||
-- can keep the evaluation functions straightforward
|
||||
tI :: TricuAST
|
||||
@ -113,5 +117,5 @@ tS = SApp (SApp TLeaf (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf))) TLeaf
|
||||
|
||||
result :: Map String T -> T
|
||||
result r = case Map.lookup "__result" r of
|
||||
Just a -> a
|
||||
Nothing -> errorWithoutStackTrace "No __result field found in provided environment"
|
||||
Just a -> a
|
||||
Nothing -> error "No __result field found in provided environment"
|
||||
|
||||
@ -1,30 +0,0 @@
|
||||
module FileEval where
|
||||
|
||||
import Eval
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
import System.IO
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
evaluateFileResult :: FilePath -> IO T
|
||||
evaluateFileResult filePath = do
|
||||
contents <- readFile filePath
|
||||
let asts = parseTricu contents
|
||||
let finalEnv = evalTricu Map.empty asts
|
||||
case Map.lookup "__result" finalEnv of
|
||||
Just finalResult -> return finalResult
|
||||
Nothing -> errorWithoutStackTrace "No expressions to evaluate found"
|
||||
|
||||
evaluateFile :: FilePath -> IO Env
|
||||
evaluateFile filePath = do
|
||||
contents <- readFile filePath
|
||||
let asts = parseTricu contents
|
||||
pure $ evalTricu Map.empty asts
|
||||
|
||||
evaluateFileWithContext :: Env -> FilePath -> IO Env
|
||||
evaluateFileWithContext env filePath = do
|
||||
contents <- readFile filePath
|
||||
let asts = parseTricu contents
|
||||
pure $ evalTricu env asts
|
||||
35
src/Lexer.hs
35
src/Lexer.hs
@ -1,25 +1,38 @@
|
||||
module Lexer where
|
||||
|
||||
import Research
|
||||
|
||||
import Control.Monad (void)
|
||||
import Data.Void
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char hiding (space)
|
||||
import Text.Megaparsec.Char.Lexer
|
||||
|
||||
import Control.Monad (void)
|
||||
import Data.Void
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
type Lexer = Parsec Void String
|
||||
|
||||
data LToken
|
||||
= LKeywordT
|
||||
| LIdentifier String
|
||||
| LIntegerLiteral Int
|
||||
| LStringLiteral String
|
||||
| LAssign
|
||||
| LColon
|
||||
| LBackslash
|
||||
| LOpenParen
|
||||
| LCloseParen
|
||||
| LOpenBracket
|
||||
| LCloseBracket
|
||||
| LNewline
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
keywordT :: Lexer LToken
|
||||
keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
|
||||
|
||||
identifier :: Lexer LToken
|
||||
identifier = do
|
||||
first <- letterChar <|> char '_'
|
||||
rest <- many (letterChar <|> char '_' <|> char '-' <|> digitChar)
|
||||
let name = first : rest
|
||||
name <- some (letterChar <|> char '_' <|> char '-')
|
||||
if (name == "t" || name == "__result")
|
||||
then fail "Keywords (`t`, `__result`) cannot be used as an identifier"
|
||||
else return (LIdentifier name)
|
||||
@ -33,8 +46,11 @@ stringLiteral :: Lexer LToken
|
||||
stringLiteral = do
|
||||
char '"'
|
||||
content <- many (noneOf ['"'])
|
||||
char '"' --"
|
||||
return (LStringLiteral content)
|
||||
if null content
|
||||
then fail "Empty string literals are not allowed"
|
||||
else do
|
||||
char '"' --"
|
||||
return (LStringLiteral content)
|
||||
|
||||
assign :: Lexer LToken
|
||||
assign = char '=' *> pure LAssign
|
||||
@ -88,7 +104,8 @@ tricuLexer = do
|
||||
, closeBracket
|
||||
]
|
||||
|
||||
|
||||
lexTricu :: String -> [LToken]
|
||||
lexTricu input = case runParser tricuLexer "" input of
|
||||
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
|
||||
Left err -> error $ "Lexical error:\n" ++ errorBundlePretty err
|
||||
Right tokens -> tokens
|
||||
|
||||
46
src/Library.hs
Normal file
46
src/Library.hs
Normal file
@ -0,0 +1,46 @@
|
||||
module Library where
|
||||
|
||||
import Eval
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
library :: Map.Map String T
|
||||
library = evalTricu Map.empty $ parseTricu $ unlines
|
||||
[ "false = t"
|
||||
, "true = t t"
|
||||
, "_ = t"
|
||||
, "k = t t"
|
||||
, "i = t (t k) t"
|
||||
, "s = t (t (k t)) t"
|
||||
, "m = s i i"
|
||||
, "b = s (k s) k"
|
||||
, "c = s (s (k s) (s (k k) s)) (k k)"
|
||||
, "iC = (\\a b c : s a (k c) b)"
|
||||
, "iD = b (b iC) iC"
|
||||
, "iE = b (b iD) iC"
|
||||
, "yi = (\\i : b m (c b (i m)))"
|
||||
, "y = yi iC"
|
||||
, "yC = yi iD"
|
||||
, "yD = yi iE"
|
||||
, "id = (\\a : a)"
|
||||
, "triage = (\\a b c : t (t a b) c)"
|
||||
, "pair = t"
|
||||
, "matchBool = (\\ot of : triage of (\\_ : ot) (\\_ _ : ot))"
|
||||
, "matchList = (\\oe oc : triage oe _ oc)"
|
||||
, "matchPair = (\\op : triage _ _ op)"
|
||||
, "not = matchBool false true"
|
||||
, "and = matchBool id (\\z : false)"
|
||||
, "if = (\\cond then else : t (t else (t t then)) t cond)"
|
||||
, "test = triage \"Leaf\" (\\z : \"Stem\") (\\a b : \"Fork\")"
|
||||
, "emptyList = matchList true (\\y z : false)"
|
||||
, "head = matchList t (\\hd tl : hd)"
|
||||
, "tail = matchList t (\\hd tl : tl)"
|
||||
, "listConcat = y (\\self : matchList (\\k : k) (\\h r k : pair h (self r k)))"
|
||||
, "lAnd = triage (\\x : false) (\\_ x : x) (\\_ _ x : x)"
|
||||
, "lOr = triage (\\x : x) (\\_ _ : true) (\\_ _ x : true)"
|
||||
, "hmap = y (\\self : matchList (\\f : t) (\\hd tl f : pair (f hd) (self tl f)))"
|
||||
, "map = (\\f l : hmap l f)"
|
||||
, "equal = y (\\self : triage (triage true (\\z : false) (\\y z : false)) (\\ax : triage false (self ax) (\\y z : false)) (\\ax ay : triage false (\\z : false) (\\bx by : lAnd (self ax bx) (self ay by))))"
|
||||
]
|
||||
86
src/Main.hs
86
src/Main.hs
@ -1,84 +1,22 @@
|
||||
module Main where
|
||||
|
||||
import Eval (evalTricu, result)
|
||||
import FileEval
|
||||
import Parser (parseTricu)
|
||||
import REPL
|
||||
import Research
|
||||
import Eval (evalTricu, result)
|
||||
import Library (library)
|
||||
import Parser (parseTricu)
|
||||
import REPL (repl)
|
||||
import Research (T)
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Text.Megaparsec (runParser)
|
||||
import System.Console.CmdArgs
|
||||
import Text.Megaparsec (runParser)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
data TricuArgs
|
||||
= Repl
|
||||
| Evaluate { file :: [FilePath], form :: EvaluatedForm }
|
||||
| Decode { file :: [FilePath] }
|
||||
deriving (Show, Data, Typeable)
|
||||
|
||||
replMode :: TricuArgs
|
||||
replMode = Repl
|
||||
&= help "Start interactive REPL"
|
||||
&= auto
|
||||
&= name "repl"
|
||||
|
||||
evaluateMode :: TricuArgs
|
||||
evaluateMode = Evaluate
|
||||
{ file = def &= help "Input file path(s) for evaluation.\n \
|
||||
\ Defaults to stdin."
|
||||
&= name "f" &= typ "FILE"
|
||||
, form = TreeCalculus &= typ "FORM"
|
||||
&= help "Optional output form: (tree|fsl|ast|ternary|ascii).\n \
|
||||
\ Defaults to tricu-compatible `t` tree form."
|
||||
&= name "t"
|
||||
}
|
||||
&= help "Evaluate tricu and return the result of the final expression."
|
||||
&= explicit
|
||||
&= name "eval"
|
||||
|
||||
decodeMode :: TricuArgs
|
||||
decodeMode = Decode
|
||||
{ file = def
|
||||
&= help "Optional input file path to attempt decoding.\n \
|
||||
\ Defaults to stdin."
|
||||
&= name "f" &= typ "FILE"
|
||||
}
|
||||
&= help "Decode a Tree Calculus value into a string representation."
|
||||
&= explicit
|
||||
&= name "decode"
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- cmdArgs $ modes [replMode, evaluateMode, decodeMode]
|
||||
&= help "tricu: Exploring Tree Calculus"
|
||||
&= program "tricu"
|
||||
&= summary "tricu Evaluator and REPL"
|
||||
case args of
|
||||
Repl -> do
|
||||
putStrLn "Welcome to the tricu REPL"
|
||||
putStrLn "You can exit with `CTRL+D` or the `:_exit` command.`"
|
||||
library <- liftIO $ evaluateFile "./lib/base.tri"
|
||||
repl $ Map.delete "__result" library
|
||||
Evaluate { file = filePaths, form = form } -> do
|
||||
result <- case filePaths of
|
||||
[] -> do
|
||||
t <- getContents
|
||||
pure $ runTricu t
|
||||
(filePath:restFilePaths) -> do
|
||||
initialEnv <- evaluateFile filePath
|
||||
finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
|
||||
pure $ result finalEnv
|
||||
let fRes = formatResult form result
|
||||
putStr fRes
|
||||
Decode { file = filePaths } -> do
|
||||
value <- case filePaths of
|
||||
[] -> getContents
|
||||
(filePath:_) -> readFile filePath
|
||||
library <- liftIO $ evaluateFile "./lib/base.tri"
|
||||
putStrLn $ decodeResult $ result $ evalTricu library $ parseTricu value
|
||||
putStrLn "Welcome to the tricu Interpreter"
|
||||
putStrLn "You can exit at any time by typing and entering: "
|
||||
putStrLn ":_exit"
|
||||
repl library
|
||||
|
||||
runTricu :: String -> T
|
||||
runTricu = result . evalTricu Map.empty . parseTricu
|
||||
runTricu s = result (evalTricu Map.empty $ parseTricu s)
|
||||
runTricuEnv env s = result (evalTricu env $ parseTricu s)
|
||||
|
||||
@ -1,18 +1,31 @@
|
||||
module Parser where
|
||||
|
||||
import Lexer
|
||||
import Research hiding (toList)
|
||||
import Research hiding (toList)
|
||||
|
||||
import Data.List.NonEmpty (toList)
|
||||
import Data.List.NonEmpty (toList)
|
||||
import Data.Void (Void)
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
|
||||
import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle)
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
type Parser = Parsec Void [LToken]
|
||||
type AltParser = Parsec Void String
|
||||
type Parser = Parsec Void [LToken]
|
||||
|
||||
data TricuAST
|
||||
= SVar String
|
||||
| SInt Int
|
||||
| SStr String
|
||||
| SList [TricuAST]
|
||||
| SFunc String [String] TricuAST
|
||||
| SApp TricuAST TricuAST
|
||||
| TLeaf
|
||||
| TStem TricuAST
|
||||
| TFork TricuAST TricuAST
|
||||
| SLambda [String] TricuAST
|
||||
| SEmpty
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
parseTricu :: String -> [TricuAST]
|
||||
parseTricu input
|
||||
@ -54,9 +67,16 @@ parseFunction = do
|
||||
|
||||
parseAtomicBase :: Parser TricuAST
|
||||
parseAtomicBase = choice
|
||||
[ parseTreeLeaf
|
||||
[ try parseVarWithoutAssignment
|
||||
, parseTreeLeaf
|
||||
, parseGrouped
|
||||
]
|
||||
parseVarWithoutAssignment :: Parser TricuAST
|
||||
parseVarWithoutAssignment = do
|
||||
LIdentifier name <- satisfy isIdentifier
|
||||
if (name == "t" || name == "__result")
|
||||
then fail $ "Reserved keyword: " ++ name ++ " cannot be assigned."
|
||||
else notFollowedBy (satisfy (== LAssign)) *> return (SVar name)
|
||||
|
||||
parseLambda :: Parser TricuAST
|
||||
parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
|
||||
@ -222,42 +242,6 @@ isLiteral _ = False
|
||||
isNewline (LNewline) = True
|
||||
isNewline _ = False
|
||||
|
||||
-- Alternative parsers
|
||||
altSC :: AltParser ()
|
||||
altSC = skipMany (char ' ' <|> char '\t' <|> char '\n')
|
||||
|
||||
parseTernaryTerm :: AltParser TricuAST
|
||||
parseTernaryTerm = do
|
||||
altSC
|
||||
term <- choice parseTernaryTerm'
|
||||
altSC
|
||||
pure term
|
||||
where
|
||||
parseTernaryTerm' =
|
||||
[ try (between (char '(') (char ')') parseTernaryTerm)
|
||||
, try parseTernaryLeaf
|
||||
, try parseTernaryStem
|
||||
, try parseTernaryFork
|
||||
]
|
||||
|
||||
parseTernaryLeaf :: AltParser TricuAST
|
||||
parseTernaryLeaf = char '0' *> pure TLeaf
|
||||
|
||||
parseTernaryStem :: AltParser TricuAST
|
||||
parseTernaryStem = char '1' *> (TStem <$> parseTernaryTerm)
|
||||
|
||||
parseTernaryFork :: AltParser TricuAST
|
||||
parseTernaryFork = do
|
||||
char '2'
|
||||
term1 <- parseTernaryTerm
|
||||
term2 <- parseTernaryTerm
|
||||
pure $ TFork term1 term2
|
||||
|
||||
parseTernary :: String -> Either String TricuAST
|
||||
parseTernary input = case runParser (parseTernaryTerm <* eof) "" input of
|
||||
Left err -> Left (errorBundlePretty err)
|
||||
Right ast -> Right ast
|
||||
|
||||
-- Error Handling
|
||||
handleParseError :: ParseErrorBundle [LToken] Void -> String
|
||||
handleParseError bundle =
|
||||
@ -275,3 +259,4 @@ showError (FancyError offset fancy) =
|
||||
showError (TrivialError offset Nothing expected) =
|
||||
"Parse error at offset " ++ show offset ++ ": expected one of "
|
||||
++ show (Set.toList expected)
|
||||
|
||||
|
||||
59
src/REPL.hs
59
src/REPL.hs
@ -1,71 +1,54 @@
|
||||
module REPL where
|
||||
|
||||
import Eval
|
||||
import FileEval
|
||||
import Lexer
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
import Control.Exception (SomeException, catch)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Char (isSpace)
|
||||
import Data.List (dropWhile, dropWhileEnd, intercalate)
|
||||
import Data.List (intercalate)
|
||||
import System.Console.Haskeline
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
repl :: Env -> IO ()
|
||||
repl :: Map.Map String T -> IO ()
|
||||
repl env = runInputT defaultSettings (loop env)
|
||||
where
|
||||
loop :: Env -> InputT IO ()
|
||||
loop :: Map.Map String T -> InputT IO ()
|
||||
loop env = do
|
||||
minput <- getInputLine "tricu < "
|
||||
case minput of
|
||||
Nothing -> outputStrLn "Exiting tricu"
|
||||
Just s -> case strip s of
|
||||
"!exit" -> outputStrLn "Exiting tricu"
|
||||
"!load" -> do
|
||||
path <- getInputLine "File path to load < "
|
||||
case path of
|
||||
Nothing -> do
|
||||
outputStrLn "No input received; stopping import."
|
||||
loop env
|
||||
Just path -> do
|
||||
loadedEnv <- liftIO $ evaluateFileWithContext env (strip path)
|
||||
loop $ Map.delete "__result" (Map.union loadedEnv env)
|
||||
"" -> do
|
||||
outputStrLn ""
|
||||
loop env
|
||||
input -> do
|
||||
case (take 2 input) of
|
||||
"--" -> loop env
|
||||
_ -> do
|
||||
newEnv <- liftIO $ (processInput env input `catch` errorHandler env)
|
||||
loop newEnv
|
||||
|
||||
processInput :: Env -> String -> IO Env
|
||||
Nothing -> outputStrLn "Goodbye!"
|
||||
Just ":_exit" -> outputStrLn "Goodbye!"
|
||||
Just "" -> do
|
||||
outputStrLn ""
|
||||
loop env
|
||||
Just input -> do
|
||||
newEnv <- liftIO $ (processInput env input `catch` errorHandler env)
|
||||
loop newEnv
|
||||
|
||||
processInput :: Map.Map String T -> String -> IO (Map.Map String T)
|
||||
processInput env input = do
|
||||
let asts = parseTricu input
|
||||
newEnv = evalTricu env asts
|
||||
let clearEnv = Map.delete "__result" env
|
||||
newEnv = evalSingle clearEnv (parseSingle input)
|
||||
case Map.lookup "__result" newEnv of
|
||||
Just r -> do
|
||||
putStrLn $ "tricu > " ++ decodeResult r
|
||||
putStrLn $ "tricu > " ++ show r
|
||||
putStrLn $ "READ -: \"" ++ decodeResult r ++ "\""
|
||||
Nothing -> return ()
|
||||
return newEnv
|
||||
|
||||
errorHandler :: Env -> SomeException -> IO (Env)
|
||||
|
||||
errorHandler :: Map.Map String T -> SomeException -> IO (Map.Map String T)
|
||||
errorHandler env e = do
|
||||
putStrLn $ "Error: " ++ show e
|
||||
return env
|
||||
|
||||
strip :: String -> String
|
||||
strip = dropWhileEnd isSpace . dropWhile isSpace
|
||||
|
||||
decodeResult :: T -> String
|
||||
decodeResult tc = case toNumber tc of
|
||||
Right num -> show num
|
||||
Left _ -> case toString tc of
|
||||
Right str -> "\"" ++ str ++ "\""
|
||||
Right str -> str
|
||||
Left _ -> case toList tc of
|
||||
Right list -> "[" ++ intercalate ", " (map decodeResult list) ++ "]"
|
||||
Left _ -> formatResult TreeCalculus tc
|
||||
Left _ -> ""
|
||||
|
||||
124
src/Research.hs
124
src/Research.hs
@ -1,57 +1,14 @@
|
||||
module Research where
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.List (intercalate)
|
||||
import Data.Map (Map)
|
||||
import Data.Text (Text, replace)
|
||||
import System.Console.CmdArgs (Data, Typeable)
|
||||
import Data.List (intercalate)
|
||||
import Data.Map (Map)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as Map
|
||||
|
||||
-- Tree Calculus Types
|
||||
data T = Leaf | Stem T | Fork T T
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- Abstract Syntax Tree for tricu
|
||||
data TricuAST
|
||||
= SVar String
|
||||
| SInt Int
|
||||
| SStr String
|
||||
| SList [TricuAST]
|
||||
| SFunc String [String] TricuAST
|
||||
| SApp TricuAST TricuAST
|
||||
| TLeaf
|
||||
| TStem TricuAST
|
||||
| TFork TricuAST TricuAST
|
||||
| SLambda [String] TricuAST
|
||||
| SEmpty
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- Tokens from Lexer
|
||||
data LToken
|
||||
= LKeywordT
|
||||
| LIdentifier String
|
||||
| LIntegerLiteral Int
|
||||
| LStringLiteral String
|
||||
| LAssign
|
||||
| LColon
|
||||
| LBackslash
|
||||
| LOpenParen
|
||||
| LCloseParen
|
||||
| LOpenBracket
|
||||
| LCloseBracket
|
||||
| LNewline
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- Output formats
|
||||
data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii
|
||||
deriving (Show, Data, Typeable)
|
||||
|
||||
-- Environment containing previously evaluated TC terms
|
||||
type Env = Map.Map String T
|
||||
|
||||
-- Tree Calculus Reduction
|
||||
apply :: T -> T -> T
|
||||
apply Leaf b = Stem b
|
||||
apply (Stem a) b = Fork a b
|
||||
@ -61,6 +18,16 @@ apply (Fork (Fork a1 a2) a3) Leaf = a1
|
||||
apply (Fork (Fork a1 a2) a3) (Stem u) = apply a2 u
|
||||
apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v
|
||||
|
||||
reduce :: T -> T
|
||||
reduce expr =
|
||||
let next = step expr
|
||||
in if next == expr then expr else reduce next
|
||||
|
||||
step :: T -> T
|
||||
step (Fork left right) = reduce (apply (reduce left) (reduce right))
|
||||
step (Stem inner) = Stem (reduce inner)
|
||||
step t = t
|
||||
|
||||
-- SKI Combinators
|
||||
_S :: T
|
||||
_S = Fork (Stem (Fork Leaf Leaf)) Leaf
|
||||
@ -121,31 +88,7 @@ toList (Fork x rest) = case toList rest of
|
||||
Left err -> Left err
|
||||
toList _ = Left "Invalid Tree Calculus list"
|
||||
|
||||
-- Outputs
|
||||
formatResult :: EvaluatedForm -> T -> String
|
||||
formatResult TreeCalculus = toSimpleT . show
|
||||
formatResult FSL = show
|
||||
formatResult AST = show . toAST
|
||||
formatResult Ternary = toTernaryString
|
||||
formatResult Ascii = toAscii
|
||||
|
||||
toSimpleT :: String -> String
|
||||
toSimpleT s = T.unpack
|
||||
$ replace "Fork" "t"
|
||||
$ replace "Stem" "t"
|
||||
$ replace "Leaf" "t"
|
||||
$ (T.pack s)
|
||||
|
||||
toTernaryString :: T -> String
|
||||
toTernaryString Leaf = "0"
|
||||
toTernaryString (Stem t) = "1" ++ toTernaryString t
|
||||
toTernaryString (Fork t1 t2) = "2" ++ toTernaryString t1 ++ toTernaryString t2
|
||||
|
||||
toAST :: T -> TricuAST
|
||||
toAST Leaf = TLeaf
|
||||
toAST (Stem a) = TStem (toAST a)
|
||||
toAST (Fork a b) = TFork (toAST a) (toAST b)
|
||||
|
||||
-- Utility
|
||||
toAscii :: T -> String
|
||||
toAscii tree = go tree "" True
|
||||
where
|
||||
@ -160,4 +103,41 @@ toAscii tree = go tree "" True
|
||||
++ go left (prefix ++ (if isLast then " " else "| ")) False
|
||||
++ go right (prefix ++ (if isLast then " " else "| ")) True
|
||||
|
||||
-- Utility
|
||||
rules :: IO ()
|
||||
rules = putStr $ header
|
||||
++ (unlines $ tcRules)
|
||||
++ (unlines $ haskellRules)
|
||||
++ footer
|
||||
where
|
||||
tcRules :: [String]
|
||||
tcRules =
|
||||
[ "| |"
|
||||
, "| ┌--------- | Tree Calculus | ---------┐ |"
|
||||
, "| | 1. t t a b -> a | |"
|
||||
, "| | 2. t (t a) b c -> a c (b c)| |"
|
||||
, "| | 3a. t (t a b) c t -> a | |"
|
||||
, "| | 3b. t (t a b) c (t u) -> b u | |"
|
||||
, "| | 3c. t (t a b) c (t u v) -> c u v | |"
|
||||
, "| └-------------------------------------┘ |"
|
||||
, "| |"
|
||||
]
|
||||
haskellRules :: [String]
|
||||
haskellRules =
|
||||
[ "| ┌------------------------------ | Haskell | --------------------------------┐ |"
|
||||
, "| | | |"
|
||||
, "| | data T = Leaf | Stem T | Fork TT | |"
|
||||
, "| | | |"
|
||||
, "| | apply :: T -> T -> T | |"
|
||||
, "| | apply Leaf b = Stem b | |"
|
||||
, "| | apply (Stem a) b = Fork a b | |"
|
||||
, "| | apply (Fork Leaf a) _ = a | |"
|
||||
, "| | apply (Fork (Stem a1) a2) b = apply (apply a1 b) (apply a2 b) | |"
|
||||
, "| | apply (Fork (Fork a1 a2) a3) Leaf = a1 | |"
|
||||
, "| | apply (Fork (Fork a1 a2) a3) (Stem u) = apply a2 u | |"
|
||||
, "| | apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v | |"
|
||||
, "| └---------------------------------------------------------------------------┘ |"
|
||||
]
|
||||
header :: String
|
||||
header = "┌-------------------- | Rules for evaluating Tree Calculus | -------------------┐\n"
|
||||
footer :: String
|
||||
footer = "└-------------------- | Rules for evaluating Tree Calculus | -------------------┘\n"
|
||||
|
||||
73
test/Spec.hs
73
test/Spec.hs
@ -1,14 +1,12 @@
|
||||
module Main where
|
||||
|
||||
import Eval
|
||||
import FileEval
|
||||
import Lexer
|
||||
import Library
|
||||
import Parser
|
||||
import REPL
|
||||
import Research
|
||||
|
||||
import Control.Exception (evaluate, try, SomeException)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
import Test.Tasty.QuickCheck
|
||||
@ -30,7 +28,6 @@ tests = testGroup "Tricu Tests"
|
||||
, evaluationTests
|
||||
, lambdaEvalTests
|
||||
, libraryTests
|
||||
, fileEvaluationTests
|
||||
, propertyTests
|
||||
]
|
||||
|
||||
@ -53,7 +50,7 @@ lexerTests = testGroup "Lexer Tests"
|
||||
expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
|
||||
runParser tricuLexer "" input @?= expect
|
||||
, testCase "Lex invalid token" $ do
|
||||
let input = "&invalid"
|
||||
let input = "$invalid"
|
||||
case runParser tricuLexer "" input of
|
||||
Left _ -> return ()
|
||||
Right _ -> assertFailure "Expected lexer to fail on invalid token"
|
||||
@ -71,7 +68,12 @@ lexerTests = testGroup "Lexer Tests"
|
||||
|
||||
parserTests :: TestTree
|
||||
parserTests = testGroup "Parser Tests"
|
||||
[ testCase "Error when assigning a value to T" $ do
|
||||
[-- testCase "Error when parsing incomplete definitions" $ do
|
||||
-- let input = lexTricu "x = "
|
||||
-- case (runParser parseExpression "" input) of
|
||||
-- Left _ -> return ()
|
||||
-- Right _ -> assertFailure "Expected failure on invalid input"
|
||||
testCase "Error when assigning a value to T" $ do
|
||||
let input = lexTricu "t = x"
|
||||
case (runParser parseExpression "" input) of
|
||||
Left _ -> return ()
|
||||
@ -150,10 +152,10 @@ parserTests = testGroup "Parser Tests"
|
||||
let input = "(t) -- (t) -- (t)"
|
||||
expect = [TLeaf]
|
||||
parseTricu input @?= expect
|
||||
, testCase "Comments with no terms" $ do
|
||||
let input = unlines ["-- (t)", "(t t)"]
|
||||
expect = [SEmpty,SApp TLeaf TLeaf]
|
||||
parseTricu input @?= expect
|
||||
-- , testCase "Comments with no terms" $ do
|
||||
-- let input = unlines ["-- (t)", "(t t)"]
|
||||
-- expect = []
|
||||
-- parseTricu input @?= expect
|
||||
]
|
||||
|
||||
evaluationTests :: TestTree
|
||||
@ -216,7 +218,7 @@ evaluationTests = testGroup "Evaluation Tests"
|
||||
let input = "x = t t\nx = t\nx"
|
||||
env = evalTricu Map.empty (parseTricu input)
|
||||
(result env) @?= Leaf
|
||||
, testCase "Apply identity to Boolean Not" $ do
|
||||
, testCase "Apply identity to Boolean Not" $ do
|
||||
let not = "(t (t (t t) (t t t)) t)"
|
||||
let input = "x = (\\a : a)\nx " ++ not
|
||||
env = evalTricu Map.empty (parseTricu input)
|
||||
@ -287,134 +289,95 @@ lambdaEvalTests = testGroup "Lambda Evaluation Tests"
|
||||
libraryTests :: TestTree
|
||||
libraryTests = testGroup "Library Tests"
|
||||
[ testCase "K combinator 1" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "k (t) (t t)"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Leaf
|
||||
, testCase "K combinator 2" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "k (t t) (t)"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Stem Leaf
|
||||
, testCase "K combinator 3" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "k (t t t) (t)"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Fork Leaf Leaf
|
||||
, testCase "S combinator" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "s (t) (t) (t)"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Fork Leaf (Stem Leaf)
|
||||
, testCase "SKK == I (fully expanded)" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "s k k"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Fork (Stem (Stem Leaf)) (Stem Leaf)
|
||||
, testCase "I combinator" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "i not"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) (Fork Leaf (Fork Leaf Leaf))
|
||||
, testCase "Triage test Leaf" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "test t"
|
||||
env = decodeResult $ result $ evalTricu library (parseTricu input)
|
||||
env @?= "\"Leaf\""
|
||||
env @?= "Leaf"
|
||||
, testCase "Triage test (Stem Leaf)" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "test (t t)"
|
||||
env = decodeResult $ result $ evalTricu library (parseTricu input)
|
||||
env @?= "\"Stem\""
|
||||
env @?= "Stem"
|
||||
, testCase "Triage test (Fork Leaf Leaf)" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "test (t t t)"
|
||||
env = decodeResult $ result $ evalTricu library (parseTricu input)
|
||||
env @?= "\"Fork\""
|
||||
env @?= "Fork"
|
||||
, testCase "Boolean NOT: true" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "not true"
|
||||
env = result $ evalTricu library (parseTricu input)
|
||||
env @?= Leaf
|
||||
, testCase "Boolean NOT: false" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "not false"
|
||||
env = result $ evalTricu library (parseTricu input)
|
||||
env @?= Stem Leaf
|
||||
, testCase "Boolean AND TF" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "and (t t) (t)"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Leaf
|
||||
, testCase "Boolean AND FT" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "and (t) (t t)"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Leaf
|
||||
, testCase "Boolean AND FF" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "and (t) (t)"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Leaf
|
||||
, testCase "Boolean AND TT" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "and (t t) (t t)"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Stem Leaf
|
||||
, testCase "List head" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "head [(t) (t t) (t t t)]"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Leaf
|
||||
, testCase "List tail" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "head (tail (tail [(t) (t t) (t t t)]))"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Fork Leaf Leaf
|
||||
, testCase "List map" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "head (tail (map (\\a : (t t t)) [(t) (t) (t)]))"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Fork Leaf Leaf
|
||||
, testCase "Empty list check" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "emptyList []"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Stem Leaf
|
||||
, testCase "Non-empty list check" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "not (emptyList [(1) (2) (3)])"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Stem Leaf
|
||||
, testCase "Concatenate strings" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "lconcat \"Hello, \" \"world!\""
|
||||
let input = "listConcat \"Hello, \" \"world!\""
|
||||
env = decodeResult $ result $ evalTricu library (parseTricu input)
|
||||
env @?= "\"Hello, world!\""
|
||||
env @?= "Hello, world!"
|
||||
, testCase "Verifying Equality" $ do
|
||||
library <- evaluateFile "./lib/base.tri"
|
||||
let input = "equal (t t t) (t t t)"
|
||||
env = evalTricu library (parseTricu input)
|
||||
result env @?= Stem Leaf
|
||||
]
|
||||
|
||||
fileEvaluationTests :: TestTree
|
||||
fileEvaluationTests = testGroup "Evaluation tests"
|
||||
[ testCase "Forks" $ do
|
||||
res <- liftIO $ evaluateFileResult "./test/fork.tri"
|
||||
res @?= Fork Leaf Leaf
|
||||
, testCase "File ends with comment" $ do
|
||||
res <- liftIO $ evaluateFileResult "./test/comments-1.tri"
|
||||
res @?= Fork (Stem Leaf) Leaf
|
||||
, testCase "Mapping and Equality" $ do
|
||||
res <- liftIO $ evaluateFileResult "./test/map.tri"
|
||||
res @?= Stem Leaf
|
||||
, testCase "Eval and decoding string" $ do
|
||||
library <- liftIO $ evaluateFile "./lib/base.tri"
|
||||
res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
|
||||
decodeResult (result res) @?= "\"String test!\""
|
||||
]
|
||||
|
||||
propertyTests :: TestTree
|
||||
propertyTests = testGroup "Property Tests"
|
||||
[ testProperty "Lexing and parsing round-trip" $ \input ->
|
||||
|
||||
@ -1 +0,0 @@
|
||||
t (t (t (t (t t) (t t t)) t) t t) t
|
||||
@ -1 +0,0 @@
|
||||
x = t (t t) t
|
||||
@ -1,9 +0,0 @@
|
||||
-- This is a tricu comment!
|
||||
-- t (t t) (t (t t t))
|
||||
-- t (t t t) (t t)
|
||||
-- x = (\a : a)
|
||||
t (t t) t -- Fork (Stem Leaf) Leaf
|
||||
-- t t
|
||||
-- x
|
||||
-- x = (\a : a)
|
||||
-- t
|
||||
@ -1 +0,0 @@
|
||||
t t t
|
||||
24
test/map.tri
24
test/map.tri
@ -1,24 +0,0 @@
|
||||
false = t
|
||||
true = t t
|
||||
_ = t
|
||||
k = t t
|
||||
i = t (t k) t
|
||||
s = t (t (k t)) t
|
||||
m = s i i
|
||||
b = s (k s) k
|
||||
c = s (s (k s) (s (k k) s)) (k k)
|
||||
iC = (\a b c : s a (k c) b)
|
||||
yi = (\i : b m (c b (i m)))
|
||||
y = yi iC
|
||||
triage = (\a b c : t (t a b) c)
|
||||
pair = t
|
||||
matchList = (\oe oc : triage oe _ oc)
|
||||
lconcat = y (\self : matchList (\k : k) (\h r k : pair h (self r k)))
|
||||
hmap = y (\self : matchList (\f : t) (\hd tl f : pair (f hd) (self tl f)))
|
||||
map = (\f l : hmap l f)
|
||||
lAnd = triage (\x : false) (\_ x : x) (\_ _ x : x)
|
||||
lOr = triage (\x : x) (\_ _ : true) (\_ _ x : true)
|
||||
equal = y (\self : triage (triage true (\z : false) (\y z : false)) (\ax : triage false (self ax) (\y z : false)) (\ax ay : triage false (\z : false) (\bx by : lAnd (self ax bx) (self ay by))))
|
||||
|
||||
x = map (\i : lconcat "Successfully concatenated " i) [("two strings!")]
|
||||
equal x [("Successfully concatenated two strings!")]
|
||||
@ -1 +0,0 @@
|
||||
head (map (\i : lconcat "String " i) [("test!")])
|
||||
21
tricu.cabal
21
tricu.cabal
@ -1,7 +1,7 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
name: tricu
|
||||
version: 0.5.0
|
||||
version: 0.4.0
|
||||
description: A micro-language for exploring Tree Calculus
|
||||
author: James Eversole
|
||||
maintainer: james@eversole.co
|
||||
@ -17,21 +17,25 @@ executable tricu
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions:
|
||||
DeriveDataTypeable
|
||||
ConstraintKinds
|
||||
DataKinds
|
||||
DeriveGeneric
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
GeneralizedNewtypeDeriving
|
||||
OverloadedStrings
|
||||
ScopedTypeVariables
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
|
||||
build-depends:
|
||||
base >=4.7
|
||||
, cmdargs
|
||||
, containers
|
||||
, haskeline
|
||||
, megaparsec
|
||||
, mtl
|
||||
, text
|
||||
other-modules:
|
||||
Eval
|
||||
FileEval
|
||||
Lexer
|
||||
Library
|
||||
Parser
|
||||
REPL
|
||||
Research
|
||||
@ -41,12 +45,8 @@ test-suite tricu-tests
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
hs-source-dirs: test, src
|
||||
default-extensions:
|
||||
DeriveDataTypeable
|
||||
OverloadedStrings
|
||||
build-depends:
|
||||
base
|
||||
, cmdargs
|
||||
, containers
|
||||
, haskeline
|
||||
, megaparsec
|
||||
@ -54,12 +54,11 @@ test-suite tricu-tests
|
||||
, tasty
|
||||
, tasty-hunit
|
||||
, tasty-quickcheck
|
||||
, text
|
||||
default-language: Haskell2010
|
||||
other-modules:
|
||||
Eval
|
||||
FileEval
|
||||
Lexer
|
||||
Library
|
||||
Parser
|
||||
REPL
|
||||
Research
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user