Compare commits
4 Commits
Author | SHA1 | Date | |
---|---|---|---|
918d929c09 | |||
a64b3f0829 | |||
e2621bc09d | |||
ea128929da |
@ -55,15 +55,11 @@ jobs:
|
||||
chmod 755 ./tricu
|
||||
nix develop --command upx ./tricu
|
||||
|
||||
- name: Setup go for release action
|
||||
uses: actions/setup-go@v5
|
||||
with:
|
||||
go-version: '>=1.20.1'
|
||||
|
||||
- name: Release binary
|
||||
uses: https://gitea.com/actions/release-action@main
|
||||
uses: akkuman/gitea-release-action@v1
|
||||
with:
|
||||
files: |-
|
||||
./tricu
|
||||
api_key: '${{ secrets.RELEASE_TOKEN }}'
|
||||
token: '${{ secrets.RELEASE_TOKEN }}'
|
||||
body: '${{ gitea.event.head_commit.message }}'
|
||||
pre_release: true
|
||||
|
@ -2,7 +2,7 @@
|
||||
|
||||
## Introduction
|
||||
|
||||
tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included to provide a useful programming tool.
|
||||
tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included to provide a useful programming tool. tricu is under active development and you can expect breaking changes with nearly every commit.
|
||||
|
||||
tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`.
|
||||
|
||||
@ -71,7 +71,7 @@ tricu eval [OPTIONS]
|
||||
|
||||
-f --file=FILE Input file path(s) for evaluation.
|
||||
Defaults to stdin.
|
||||
-t --form=FORM Optional output form: (tree|fsl|ast|ternary|ascii).
|
||||
-t --form=FORM Optional output form: (tree|fsl|ast|ternary|ascii|decode).
|
||||
Defaults to tricu-compatible `t` tree form.
|
||||
|
||||
tricu decode [OPTIONS]
|
||||
|
@ -1,3 +1,5 @@
|
||||
main = lambdaEqualsTC
|
||||
|
||||
-- We represent `false` with a Leaf and `true` with a Stem Leaf
|
||||
demo_false = t
|
||||
demo_true = t t
|
||||
@ -6,7 +8,7 @@ demo_true = t t
|
||||
not_TC? = t (t (t t) (t t t)) (t t (t t t))
|
||||
|
||||
-- /demos/toSource.tri contains an explanation of `triage`
|
||||
demo_triage = (\a b c : t (t a b) c)
|
||||
demo_triage = \a b c : t (t a b) c
|
||||
demo_matchBool = (\ot of : demo_triage
|
||||
of
|
||||
(\_ : ot)
|
||||
|
@ -1,11 +1,10 @@
|
||||
main = exampleTwo
|
||||
-- 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 not?ation of empty nodes. Empty nodes can be represented
|
||||
-- with an empty list, `[]`, which is equivalent to a single node `t`.
|
||||
-- We model labelled binary trees as nested lists where values act as labels. We
|
||||
-- require explicit notation of empty nodes. Empty nodes can be represented
|
||||
-- with an empty list, `[]`, which evaluates to a single node `t`.
|
||||
--
|
||||
-- Example tree inputs:
|
||||
-- [("1") [("2") [("4") t t] t] [("3") [("5") t t] [("6") t t]]]]
|
||||
@ -15,9 +14,8 @@
|
||||
-- 2 3
|
||||
-- / / \
|
||||
-- 4 5 6
|
||||
--
|
||||
|
||||
label = (\node : head node)
|
||||
label = \node : head node
|
||||
|
||||
left = (\node : if (emptyList? node)
|
||||
[]
|
||||
@ -39,7 +37,7 @@ processLevel = y (\self queue : if (emptyList? queue)
|
||||
(\node : not? (emptyList? node))
|
||||
(lconcat (map left queue) (map right queue))))))
|
||||
|
||||
levelOrderTraversal_ = (\a : processLevel (t a t))
|
||||
levelOrderTraversal_ = \a : processLevel (t a t)
|
||||
|
||||
toLineString = y (\self levels : if (emptyList? levels)
|
||||
""
|
||||
@ -47,11 +45,11 @@ toLineString = y (\self levels : if (emptyList? levels)
|
||||
(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))
|
||||
levelOrderToString = \s : toLineString (levelOrderTraversal_ s)
|
||||
|
||||
flatten = foldl (\acc x : lconcat acc x) ""
|
||||
|
||||
levelOrderTraversal = (\s : lconcat (t 10 t) (flatten (levelOrderToString s)))
|
||||
levelOrderTraversal = \s : lconcat (t 10 t) (flatten (levelOrderToString s))
|
||||
|
||||
exampleOne = levelOrderTraversal [("1")
|
||||
[("2") [("4") t t] t]
|
||||
@ -61,5 +59,3 @@ exampleTwo = levelOrderTraversal [("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]]]
|
||||
|
||||
exampleTwo
|
||||
|
@ -1,4 +1,6 @@
|
||||
compose = (\f g x : f (g x))
|
||||
main = size size
|
||||
|
||||
compose = \f g x : f (g x)
|
||||
|
||||
succ = y (\self :
|
||||
triage
|
||||
@ -17,5 +19,3 @@ size = (\x :
|
||||
self
|
||||
(\x y : compose (self x) (self y))
|
||||
x)) x 0))
|
||||
|
||||
size size
|
||||
|
@ -1,3 +1,4 @@
|
||||
main = toSource not?
|
||||
-- Thanks to intensionality, we can inspect the structure of a given value
|
||||
-- even if it's a function. This includes lambdas which are eliminated to
|
||||
-- Tree Calculus (TC) terms during evaluation.
|
||||
@ -40,7 +41,7 @@ toSource_ = y (\self arg :
|
||||
arg) -- The term to be inspected
|
||||
|
||||
-- toSource takes a single TC term and returns a String
|
||||
toSource = (\v : toSource_ v "")
|
||||
toSource = \v : toSource_ v ""
|
||||
|
||||
exampleOne = toSource true -- OUT: "(t t)"
|
||||
exampleTwo = toSource not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"
|
||||
|
43
lib/base.tri
43
lib/base.tri
@ -7,18 +7,15 @@ 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)
|
||||
id = \a : a
|
||||
pair = t
|
||||
if = (\cond then else : t (t else (t t then)) t cond)
|
||||
if = \cond then else : t (t else (t t then)) t cond
|
||||
|
||||
triage = (\leaf stem fork : t (t leaf stem) fork)
|
||||
y = ((\mut wait fun : wait mut (\x : fun (wait mut x)))
|
||||
(\x : x x)
|
||||
(\a0 a1 a2 : t (t a0) (t t a2) a1))
|
||||
|
||||
triage = \leaf stem fork : t (t leaf stem) fork
|
||||
test = triage "Leaf" (\_ : "Stem") (\_ _ : "Fork")
|
||||
|
||||
matchBool = (\ot of : triage
|
||||
@ -27,17 +24,9 @@ matchBool = (\ot of : triage
|
||||
(\_ _ : ot)
|
||||
)
|
||||
|
||||
matchList = (\oe oc : triage
|
||||
oe
|
||||
_
|
||||
oc
|
||||
)
|
||||
matchList = \a b : triage a _ b
|
||||
|
||||
matchPair = (\op : triage
|
||||
_
|
||||
_
|
||||
op
|
||||
)
|
||||
matchPair = \a : triage _ _ a
|
||||
|
||||
not? = matchBool false true
|
||||
and? = matchBool id (\_ : false)
|
||||
@ -53,20 +42,18 @@ lconcat = y (\self : matchList
|
||||
lAnd = (triage
|
||||
(\_ : false)
|
||||
(\_ x : x)
|
||||
(\_ _ x : x)
|
||||
)
|
||||
(\_ _ x : x))
|
||||
|
||||
lOr = (triage
|
||||
(\x : x)
|
||||
(\_ _ : true)
|
||||
(\_ _ _ : true)
|
||||
)
|
||||
(\_ _ _ : true))
|
||||
|
||||
map_ = y (\self :
|
||||
matchList
|
||||
(\_ : t)
|
||||
(\head tail f : pair (f head) (self tail f)))
|
||||
map = (\f l : map_ l f)
|
||||
map = \f l : map_ l f
|
||||
|
||||
equal? = y (\self : triage
|
||||
(triage
|
||||
@ -87,10 +74,10 @@ equal? = y (\self : triage
|
||||
filter_ = y (\self : matchList
|
||||
(\_ : t)
|
||||
(\head tail f : matchBool (t head) i (f head) (self tail f)))
|
||||
filter = (\f l : filter_ l f)
|
||||
filter = \f l : filter_ l f
|
||||
|
||||
foldl_ = y (\self f l x : matchList (\acc : acc) (\head tail acc : self f tail (f acc head)) l x)
|
||||
foldl = (\f x l : foldl_ f l x)
|
||||
foldl = \f x l : foldl_ f l x
|
||||
|
||||
foldr_ = y (\self x f l : matchList x (\head tail : f (self x f tail) head) l)
|
||||
foldr = (\f x l : foldr_ x f l)
|
||||
foldr = \f x l : foldr_ x f l
|
||||
|
110
src/Eval.hs
110
src/Eval.hs
@ -3,14 +3,14 @@ module Eval where
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
import Data.List (partition)
|
||||
import Data.Map (Map)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
evalSingle :: Env -> TricuAST -> Env
|
||||
evalSingle env term
|
||||
| SFunc name [] body <- term =
|
||||
| SDef name [] body <- term =
|
||||
if
|
||||
| Map.member name env ->
|
||||
errorWithoutStackTrace $
|
||||
@ -23,17 +23,22 @@ evalSingle env term
|
||||
in Map.insert "__result" res env
|
||||
| SVar name <- term =
|
||||
case Map.lookup name env of
|
||||
Just v -> Map.insert "__result" v env
|
||||
Nothing -> errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined"
|
||||
Just v ->
|
||||
Map.insert "__result" v env
|
||||
Nothing ->
|
||||
errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined\n\
|
||||
\This error should never occur here. Please report this as an issue."
|
||||
| otherwise =
|
||||
Map.insert "__result" (evalAST env term) env
|
||||
|
||||
evalTricu :: Env -> [TricuAST] -> Env
|
||||
evalTricu env [] = env
|
||||
evalTricu env [x] =
|
||||
evalTricu env x = go env (reorderDefs env x)
|
||||
where
|
||||
go env [] = env
|
||||
go env [x] =
|
||||
let updatedEnv = evalSingle env x
|
||||
in Map.insert "__result" (result updatedEnv) updatedEnv
|
||||
evalTricu env (x:xs) =
|
||||
go env (x:xs) =
|
||||
evalTricu (evalSingle env x) xs
|
||||
|
||||
evalAST :: Env -> TricuAST -> T
|
||||
@ -54,13 +59,24 @@ evalAST env term
|
||||
(errorWithoutStackTrace $ "Variable " ++ name ++ " not defined")
|
||||
name env
|
||||
|
||||
-- https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf
|
||||
-- Chapter 4: Lambda-Abstraction
|
||||
elimLambda :: TricuAST -> TricuAST
|
||||
elimLambda = go
|
||||
where
|
||||
-- η-reduction
|
||||
go (SLambda [v] (SApp f (SVar x)))
|
||||
| v == x && not (isFree v f) = elimLambda f
|
||||
-- Triage optimization
|
||||
go (SLambda [a] (SLambda [b] (SLambda [c] body)))
|
||||
| body == triageBody = _TRIAGE
|
||||
where
|
||||
triageBody =
|
||||
(SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c))
|
||||
-- Composition optimization
|
||||
go (SLambda [f] (SLambda [g] (SLambda [x] body)))
|
||||
| body == composeBody = _COMPOSE
|
||||
where
|
||||
composeBody = SApp (SVar f) (SApp (SVar g) (SVar x))
|
||||
-- General elimination
|
||||
go (SLambda (v:vs) body)
|
||||
| null vs = toSKI v (elimLambda body)
|
||||
| otherwise = elimLambda (SLambda [v] (SLambda vs body))
|
||||
@ -75,24 +91,96 @@ elimLambda = go
|
||||
| otherwise = SApp (SApp _S (toSKI x n)) (toSKI x u)
|
||||
toSKI x t
|
||||
| not (isFree x t) = SApp _K t
|
||||
| otherwise = errorWithoutStackTrace "Unhandled toSKI conversion"
|
||||
|
||||
_S = parseSingle "t (t (t t t)) t"
|
||||
_K = parseSingle "t t"
|
||||
_I = parseSingle "t (t (t t)) t"
|
||||
_TRIAGE = parseSingle "t (t (t t (t (t (t t t))))) t"
|
||||
_COMPOSE = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
|
||||
|
||||
isFree :: String -> TricuAST -> Bool
|
||||
isFree x = Set.member x . freeVars
|
||||
|
||||
freeVars :: TricuAST -> Set.Set String
|
||||
freeVars (SVar v ) = Set.singleton v
|
||||
freeVars (SInt _ ) = Set.empty
|
||||
freeVars (SStr _ ) = Set.empty
|
||||
freeVars (SList s ) = foldMap freeVars s
|
||||
freeVars (SApp f a ) = freeVars f <> freeVars a
|
||||
freeVars (TLeaf ) = Set.empty
|
||||
freeVars (SFunc _ _ b) = freeVars b
|
||||
freeVars (SDef _ _ b) = freeVars b
|
||||
freeVars (TStem t ) = freeVars t
|
||||
freeVars (TFork l r ) = freeVars l <> freeVars r
|
||||
freeVars (SLambda v b ) = foldr Set.delete (freeVars b) v
|
||||
|
||||
reorderDefs :: Env -> [TricuAST] -> [TricuAST]
|
||||
reorderDefs env defs
|
||||
| not (null missingDeps) =
|
||||
errorWithoutStackTrace $
|
||||
"Missing dependencies detected: " ++ show missingDeps
|
||||
| otherwise = orderedDefs ++ others
|
||||
where
|
||||
(defsOnly, others) = partition isDef defs
|
||||
graph = buildDepGraph defsOnly
|
||||
sortedDefs = sortDeps graph
|
||||
defMap = Map.fromList [(name, def) | def@(SDef name _ _) <- defsOnly]
|
||||
orderedDefs = map (\name -> defMap Map.! name) sortedDefs
|
||||
topDefNames = Set.fromList (Map.keys defMap)
|
||||
envNames = Set.fromList (Map.keys env)
|
||||
freeVarsDefs = foldMap (\(SDef _ _ body) -> freeVars body) defsOnly
|
||||
freeVarsOthers = foldMap freeVars others
|
||||
allFreeVars = freeVarsDefs <> freeVarsOthers
|
||||
validNames = topDefNames `Set.union` envNames
|
||||
missingDeps = Set.toList (allFreeVars `Set.difference` validNames)
|
||||
|
||||
isDef (SDef _ _ _) = True
|
||||
isDef _ = False
|
||||
|
||||
buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
|
||||
buildDepGraph topDefs
|
||||
| not (null duplicateNames) =
|
||||
errorWithoutStackTrace $
|
||||
"Duplicate definitions detected: " ++ show duplicateNames
|
||||
| otherwise =
|
||||
Map.fromList
|
||||
[ (name, depends topDefs (SDef name [] body))
|
||||
| SDef name _ body <- topDefs]
|
||||
where
|
||||
names = [name | SDef name _ _ <- topDefs]
|
||||
duplicateNames =
|
||||
[ name | (name, count) <- Map.toList (countOccurrences names) , count > 1]
|
||||
countOccurrences = foldr (\x -> Map.insertWith (+) x 1) Map.empty
|
||||
|
||||
sortDeps :: Map.Map String (Set.Set String) -> [String]
|
||||
sortDeps graph = go [] (Map.keys graph)
|
||||
where
|
||||
go sorted [] = sorted
|
||||
go sorted remaining
|
||||
| null ready =
|
||||
errorWithoutStackTrace
|
||||
"ERROR: Top-level cyclic dependency detected and prohibited\n\
|
||||
\RESOLVE: Use nested lambdas"
|
||||
| otherwise = go (sorted ++ ready) notReady
|
||||
where
|
||||
ready = [ name | name <- remaining
|
||||
, all (`elem` sorted) (Set.toList (graph Map.! name))]
|
||||
notReady =
|
||||
[ name | name <- remaining , name `notElem` ready]
|
||||
|
||||
depends :: [TricuAST] -> TricuAST -> Set.Set String
|
||||
depends topDefs (SDef _ _ body) =
|
||||
Set.intersection
|
||||
(Set.fromList [n | SDef n _ _ <- topDefs])
|
||||
(freeVars body)
|
||||
depends _ _ = Set.empty
|
||||
|
||||
result :: Env -> T
|
||||
result r = case Map.lookup "__result" r of
|
||||
Just a -> a
|
||||
Nothing -> errorWithoutStackTrace "No __result field found in provided environment"
|
||||
Nothing -> errorWithoutStackTrace "No __result field found in provided env"
|
||||
|
||||
mainResult :: Env -> T
|
||||
mainResult r = case Map.lookup "main" r of
|
||||
Just a -> a
|
||||
Nothing -> errorWithoutStackTrace "No valid definition for `main` found."
|
||||
|
@ -13,9 +13,9 @@ evaluateFileResult filePath = do
|
||||
contents <- readFile filePath
|
||||
let asts = parseTricu contents
|
||||
let finalEnv = evalTricu Map.empty asts
|
||||
case Map.lookup "__result" finalEnv of
|
||||
case Map.lookup "main" finalEnv of
|
||||
Just finalResult -> return finalResult
|
||||
Nothing -> errorWithoutStackTrace "No expressions to evaluate found"
|
||||
Nothing -> errorWithoutStackTrace "No `main` function detected"
|
||||
|
||||
evaluateFile :: FilePath -> IO Env
|
||||
evaluateFile filePath = do
|
||||
|
12
src/Main.hs
12
src/Main.hs
@ -1,6 +1,6 @@
|
||||
module Main where
|
||||
|
||||
import Eval (evalTricu, result)
|
||||
import Eval (evalTricu, mainResult, result)
|
||||
import FileEval
|
||||
import Parser (parseTricu)
|
||||
import REPL
|
||||
@ -16,7 +16,7 @@ import qualified Data.Map as Map
|
||||
data TricuArgs
|
||||
= Repl
|
||||
| Evaluate { file :: [FilePath], form :: EvaluatedForm }
|
||||
| Decode { file :: [FilePath] }
|
||||
| TDecode { file :: [FilePath] }
|
||||
deriving (Show, Data, Typeable)
|
||||
|
||||
replMode :: TricuArgs
|
||||
@ -31,7 +31,7 @@ evaluateMode = Evaluate
|
||||
\ Defaults to stdin."
|
||||
&= name "f" &= typ "FILE"
|
||||
, form = TreeCalculus &= typ "FORM"
|
||||
&= help "Optional output form: (tree|fsl|ast|ternary|ascii).\n \
|
||||
&= help "Optional output form: (tree|fsl|ast|ternary|ascii|decode).\n \
|
||||
\ Defaults to tricu-compatible `t` tree form."
|
||||
&= name "t"
|
||||
}
|
||||
@ -40,7 +40,7 @@ evaluateMode = Evaluate
|
||||
&= name "eval"
|
||||
|
||||
decodeMode :: TricuArgs
|
||||
decodeMode = Decode
|
||||
decodeMode = TDecode
|
||||
{ file = def
|
||||
&= help "Optional input file path to attempt decoding.\n \
|
||||
\ Defaults to stdin."
|
||||
@ -70,10 +70,10 @@ main = do
|
||||
(filePath:restFilePaths) -> do
|
||||
initialEnv <- evaluateFile filePath
|
||||
finalEnv <- foldM evaluateFileWithContext initialEnv restFilePaths
|
||||
pure $ result finalEnv
|
||||
pure $ mainResult finalEnv
|
||||
let fRes = formatResult form result
|
||||
putStr fRes
|
||||
Decode { file = filePaths } -> do
|
||||
TDecode { file = filePaths } -> do
|
||||
value <- case filePaths of
|
||||
[] -> getContents
|
||||
(filePath:_) -> readFile filePath
|
||||
|
@ -85,13 +85,10 @@ scnParserM :: ParserM ()
|
||||
scnParserM = skipMany $ do
|
||||
t <- lookAhead anySingle
|
||||
st <- get
|
||||
if | (parenDepth st > 0 || bracketDepth st > 0) && case t of
|
||||
LNewline -> True
|
||||
_ -> False -> void $ satisfyM $ \case
|
||||
LNewline -> True
|
||||
_ -> False
|
||||
| otherwise -> fail "In nested context or no space token" <|> empty
|
||||
|
||||
if | (parenDepth st > 0 || bracketDepth st > 0) && (t == LNewline) ->
|
||||
void $ satisfyM (== LNewline)
|
||||
| otherwise ->
|
||||
fail "In nested context or no space token" <|> empty
|
||||
|
||||
eofM :: ParserM ()
|
||||
eofM = lift eof
|
||||
@ -109,32 +106,23 @@ parseExpressionM = choice
|
||||
|
||||
parseFunctionM :: ParserM TricuAST
|
||||
parseFunctionM = do
|
||||
LIdentifier name <- satisfyM $ \case
|
||||
LIdentifier _ -> True
|
||||
_ -> False
|
||||
args <- many $ satisfyM $ \case
|
||||
LIdentifier _ -> True
|
||||
_ -> False
|
||||
let ident = (\case LIdentifier _ -> True; _ -> False)
|
||||
LIdentifier name <- satisfyM ident
|
||||
args <- many $ satisfyM ident
|
||||
_ <- satisfyM (== LAssign)
|
||||
scnParserM
|
||||
body <- parseExpressionM
|
||||
pure (SFunc name (map getIdentifier args) body)
|
||||
pure (SDef name (map getIdentifier args) body)
|
||||
|
||||
parseLambdaM :: ParserM TricuAST
|
||||
parseLambdaM =
|
||||
between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ do
|
||||
parseLambdaM = do
|
||||
let ident = (\case LIdentifier _ -> True; _ -> False)
|
||||
_ <- satisfyM (== LBackslash)
|
||||
param <- satisfyM $ \case
|
||||
LIdentifier _ -> True
|
||||
_ -> False
|
||||
rest <- many $ satisfyM $ \case
|
||||
LIdentifier _ -> True
|
||||
_ -> False
|
||||
params <- some (satisfyM ident)
|
||||
_ <- satisfyM (== LColon)
|
||||
scnParserM
|
||||
body <- parseLambdaExpressionM
|
||||
let nested = foldr (\v acc -> SLambda [getIdentifier v] acc) body rest
|
||||
pure (SLambda [getIdentifier param] nested)
|
||||
pure $ foldr (\param acc -> SLambda [getIdentifier param] acc) body params
|
||||
|
||||
parseLambdaExpressionM :: ParserM TricuAST
|
||||
parseLambdaExpressionM = choice
|
||||
@ -180,9 +168,8 @@ parseAtomicBaseM = choice
|
||||
|
||||
parseTreeLeafM :: ParserM TricuAST
|
||||
parseTreeLeafM = do
|
||||
_ <- satisfyM $ \case
|
||||
LKeywordT -> True
|
||||
_ -> False
|
||||
let keyword = (\case LKeywordT -> True; _ -> False)
|
||||
_ <- satisfyM keyword
|
||||
notFollowedBy $ lift $ satisfy (== LAssign)
|
||||
pure TLeaf
|
||||
|
||||
@ -248,37 +235,38 @@ parseGroupedItemM = do
|
||||
|
||||
parseSingleItemM :: ParserM TricuAST
|
||||
parseSingleItemM = do
|
||||
token <- satisfyM $ \case
|
||||
LIdentifier _ -> True
|
||||
LKeywordT -> True
|
||||
_ -> False
|
||||
case token of
|
||||
LIdentifier name -> pure (SVar name)
|
||||
LKeywordT -> pure TLeaf
|
||||
_ -> fail "Unexpected token in list item"
|
||||
token <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
|
||||
if | LIdentifier name <- token -> pure (SVar name)
|
||||
| token == LKeywordT -> pure TLeaf
|
||||
| otherwise -> fail "Unexpected token in list item"
|
||||
|
||||
parseVarM :: ParserM TricuAST
|
||||
parseVarM = do
|
||||
LIdentifier name <- satisfyM $ \case
|
||||
LIdentifier _ -> True
|
||||
_ -> False
|
||||
if name == "t" || name == "__result"
|
||||
then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
||||
else pure (SVar name)
|
||||
satisfyM (\case LIdentifier _ -> True; _ -> False) >>= \case
|
||||
LIdentifier name
|
||||
| name == "t" || name == "__result" ->
|
||||
fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
|
||||
| otherwise ->
|
||||
pure (SVar name)
|
||||
_ -> fail "Unexpected token while parsing variable"
|
||||
|
||||
parseIntLiteralM :: ParserM TricuAST
|
||||
parseIntLiteralM = do
|
||||
LIntegerLiteral value <- satisfyM $ \case
|
||||
LIntegerLiteral _ -> True
|
||||
_ -> False
|
||||
let intL = (\case LIntegerLiteral _ -> True; _ -> False)
|
||||
token <- satisfyM intL
|
||||
if | LIntegerLiteral value <- token ->
|
||||
pure (SInt value)
|
||||
| otherwise ->
|
||||
fail "Unexpected token while parsing integer literal"
|
||||
|
||||
parseStrLiteralM :: ParserM TricuAST
|
||||
parseStrLiteralM = do
|
||||
LStringLiteral value <- satisfyM $ \case
|
||||
LStringLiteral _ -> True
|
||||
_ -> False
|
||||
let strL = (\case LStringLiteral _ -> True; _ -> False)
|
||||
token <- satisfyM strL
|
||||
if | LStringLiteral value <- token ->
|
||||
pure (SStr value)
|
||||
| otherwise ->
|
||||
fail "Unexpected token while parsing string literal"
|
||||
|
||||
getIdentifier :: LToken -> String
|
||||
getIdentifier (LIdentifier name) = name
|
||||
|
@ -59,10 +59,3 @@ repl env = runInputT defaultSettings (loop env)
|
||||
|
||||
strip :: String -> String
|
||||
strip = dropWhileEnd isSpace . dropWhile isSpace
|
||||
|
||||
decodeResult :: T -> String
|
||||
decodeResult tc
|
||||
| Right num <- toNumber tc = show num
|
||||
| Right str <- toString tc = "\"" ++ str ++ "\""
|
||||
| Right list <- toList tc = "[" ++ intercalate ", " (map decodeResult list) ++ "]"
|
||||
| otherwise = formatResult TreeCalculus tc
|
||||
|
@ -19,7 +19,7 @@ data TricuAST
|
||||
| SInt Int
|
||||
| SStr String
|
||||
| SList [TricuAST]
|
||||
| SFunc String [String] TricuAST
|
||||
| SDef String [String] TricuAST
|
||||
| SApp TricuAST TricuAST
|
||||
| TLeaf
|
||||
| TStem TricuAST
|
||||
@ -45,7 +45,7 @@ data LToken
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- Output formats
|
||||
data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii
|
||||
data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
|
||||
deriving (Show, Data, Typeable)
|
||||
|
||||
-- Environment containing previously evaluated TC terms
|
||||
@ -115,6 +115,7 @@ formatResult FSL = show
|
||||
formatResult AST = show . toAST
|
||||
formatResult Ternary = toTernaryString
|
||||
formatResult Ascii = toAscii
|
||||
formatResult Decode = decodeResult
|
||||
|
||||
toSimpleT :: String -> String
|
||||
toSimpleT s = T.unpack
|
||||
@ -147,4 +148,9 @@ toAscii tree = go tree "" True
|
||||
++ go left (prefix ++ (if isLast then " " else "| ")) False
|
||||
++ go right (prefix ++ (if isLast then " " else "| ")) True
|
||||
|
||||
-- Utility
|
||||
decodeResult :: T -> String
|
||||
decodeResult tc
|
||||
| Right num <- toNumber tc = show num
|
||||
| Right str <- toString tc = "\"" ++ str ++ "\""
|
||||
| Right list <- toList tc = "[" ++ intercalate ", " (map decodeResult list) ++ "]"
|
||||
| otherwise = formatResult TreeCalculus tc
|
||||
|
18
test/Spec.hs
18
test/Spec.hs
@ -85,7 +85,7 @@ parser = testGroup "Parser Tests"
|
||||
|
||||
, testCase "Parse function definitions" $ do
|
||||
let input = "x = (\\a b c : a)"
|
||||
expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a"))))
|
||||
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a"))))
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse nested Tree Calculus terms" $ do
|
||||
@ -105,7 +105,7 @@ parser = testGroup "Parser Tests"
|
||||
|
||||
, testCase "Parse function with applications" $ do
|
||||
let input = "f = (\\x : t x)"
|
||||
expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x")))
|
||||
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x")))
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse nested lists" $ do
|
||||
@ -147,7 +147,7 @@ parser = testGroup "Parser Tests"
|
||||
|
||||
, testCase "Parse nested parentheses in function body" $ do
|
||||
let input = "f = (\\x : t (t (t t)))"
|
||||
expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
|
||||
expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Parse lambda abstractions" $ do
|
||||
@ -157,12 +157,12 @@ parser = testGroup "Parser Tests"
|
||||
|
||||
, testCase "Parse multiple arguments to lambda abstractions" $ do
|
||||
let input = "x = (\\a b : a)"
|
||||
expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
|
||||
expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
|
||||
parseSingle input @?= expect
|
||||
|
||||
, testCase "Grouping T terms with parentheses in function application" $ do
|
||||
let input = "x = (\\a : a)\nx (t)"
|
||||
expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
|
||||
expect = [SDef "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
|
||||
parseTricu input @?= expect
|
||||
|
||||
, testCase "Comments 1" $ do
|
||||
@ -488,8 +488,9 @@ fileEval = testGroup "File evaluation tests"
|
||||
res @?= Fork (Stem Leaf) Leaf
|
||||
|
||||
, testCase "Mapping and Equality" $ do
|
||||
res <- liftIO $ evaluateFileResult "./test/map.tri"
|
||||
res @?= Stem Leaf
|
||||
library <- liftIO $ evaluateFile "./lib/base.tri"
|
||||
fEnv <- liftIO $ evaluateFileWithContext library "./test/map.tri"
|
||||
(mainResult fEnv) @?= Stem Leaf
|
||||
|
||||
, testCase "Eval and decoding string" $ do
|
||||
library <- liftIO $ evaluateFile "./lib/base.tri"
|
||||
@ -497,7 +498,6 @@ fileEval = testGroup "File evaluation tests"
|
||||
decodeResult (result res) @?= "\"String test!\""
|
||||
]
|
||||
|
||||
|
||||
demos :: TestTree
|
||||
demos = testGroup "Test provided demo functionality"
|
||||
[ testCase "Structural equality demo" $ do
|
||||
@ -511,7 +511,7 @@ demos = testGroup "Test provided demo functionality"
|
||||
, testCase "Determining the size of functions" $ do
|
||||
library <- liftIO $ evaluateFile "./lib/base.tri"
|
||||
res <- liftIO $ evaluateFileWithContext library "./demos/size.tri"
|
||||
decodeResult (result res) @?= "2071"
|
||||
decodeResult (result res) @?= "454"
|
||||
, testCase "Level Order Traversal demo" $ do
|
||||
library <- liftIO $ evaluateFile "./lib/base.tri"
|
||||
res <- liftIO $ evaluateFileWithContext library "./demos/levelOrderTraversal.tri"
|
||||
|
@ -2,7 +2,7 @@
|
||||
-- t (t t) (t (t t t))
|
||||
-- t (t t t) (t t)
|
||||
-- x = (\a : a)
|
||||
t (t t) t -- Fork (Stem Leaf) Leaf
|
||||
main = t (t t) t -- Fork (Stem Leaf) Leaf
|
||||
-- t t
|
||||
-- x
|
||||
-- x = (\a : a)
|
||||
|
@ -1 +1 @@
|
||||
t t t
|
||||
main = t t t
|
||||
|
24
test/map.tri
24
test/map.tri
@ -1,24 +1,2 @@
|
||||
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!")]
|
||||
main = equal? x [("Successfully concatenated two strings!")]
|
||||
|
21
test/size.tri
Normal file
21
test/size.tri
Normal file
@ -0,0 +1,21 @@
|
||||
compose = \f g x : f (g x)
|
||||
|
||||
succ = y (\self :
|
||||
triage
|
||||
1
|
||||
t
|
||||
(triage
|
||||
(t (t t))
|
||||
(\_ tail : t t (self tail))
|
||||
t))
|
||||
|
||||
size = (\x :
|
||||
(y (\self x :
|
||||
compose succ
|
||||
(triage
|
||||
(\x : x)
|
||||
self
|
||||
(\x y : compose (self x) (self y))
|
||||
x)) x 0))
|
||||
|
||||
size size
|
1
test/undefined.tri
Normal file
1
test/undefined.tri
Normal file
@ -0,0 +1 @@
|
||||
namedTerm = undefinedForTesting
|
@ -1,7 +1,7 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
name: tricu
|
||||
version: 0.7.0
|
||||
version: 0.11.0
|
||||
description: A micro-language for exploring Tree Calculus
|
||||
author: James Eversole
|
||||
maintainer: james@eversole.co
|
||||
|
Reference in New Issue
Block a user