Allow lambda expressions without explicit paren

README.md

@@ -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)`.
 

demos/equality.tri

@@ -1,19 +1,19 @@
 -- We represent `false` with a Leaf and `true` with a Stem Leaf
-false = t
+demo_false = t
-true  = t t
+demo_true  = t t
 
 -- Tree Calculus representation of the Boolean `not` function
 not_TC?     = t (t (t t) (t t t)) (t t (t t t))
 
 -- /demos/toSource.tri contains an explanation of `triage`
-triage = (\a b c : t (t a b) c)
+demo_triage = \a b c : t (t a b) c
-matchBool = (\ot of : triage
+demo_matchBool = (\ot of : demo_triage
   of
   (\_ : ot)
   (\_ _ : ot)
 )
 -- Lambda representation of the Boolean `not` function
-not_Lambda? = matchBool false true
+not_Lambda? = demo_matchBool demo_false demo_true
 
 -- Since tricu eliminates Lambda terms to SKI combinators, the tree form of many
 -- functions defined via Lambda terms are larger than the most efficient TC
@@ -25,11 +25,11 @@ not_Lambda? = matchBool false true
 lambdaEqualsTC = equal? not_TC? not_Lambda?
 
 -- Here are some checks to verify their extensional behavior is the same:
-true_TC?  = not_TC? false
+true_TC?  = not_TC? demo_false
-false_TC? = not_TC? true
+false_TC? = not_TC? demo_true
 
-true_Lambda?  = not_Lambda? false
+true_Lambda?  = not_Lambda? demo_false
-false_Lambda? = not_Lambda? true
+false_Lambda? = not_Lambda? demo_true
 
 bothTrueEqual?  = equal? true_TC?  true_Lambda?
 bothFalseEqual? = equal? false_TC? false_Lambda?

demos/levelOrderTraversal.tri

@@ -4,7 +4,7 @@
 -- 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 
+-- require explicit not?ation of empty nodes. Empty nodes can be represented 
 -- with an empty list, `[]`, which is equivalent to a single node `t`. 
 --
 -- Example tree inputs:
@@ -17,41 +17,41 @@
 --   4   5    6
 --
 
-label = (\node : head node)
+label = \node : head node
 
-left  = (\node : if (emptyList node) 
+left = (\node : if (emptyList? node)
   [] 
-  (if (emptyList (tail node)) 
+  (if (emptyList? (tail node)) 
     [] 
     (head (tail node))))
 
-right = (\node : if (emptyList node) 
+right = (\node : if (emptyList? node) 
   [] 
-  (if (emptyList (tail node)) 
+  (if (emptyList? (tail node)) 
     [] 
-    (if (emptyList (tail (tail node))) 
+    (if (emptyList? (tail (tail node))) 
       [] 
       (head (tail (tail node))))))
 
-processLevel = y (\self queue : if (emptyList queue) 
+processLevel = y (\self queue : if (emptyList? queue) 
   [] 
   (pair (map label queue) (self (filter 
-    (\node : not (emptyList node)) 
+    (\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) 
+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))))))
+    (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] 

demos/size.tri

@@ -1,4 +1,4 @@
-compose = (\f g x : f (g x))
+compose = \f g x : f (g x)
 
 succ = y (\self : 
   triage 
@@ -17,3 +17,5 @@ size = (\x :
         self 
         (\x y : compose (self x) (self y)) 
         x)) x 0))
+
+size size

demos/toSource.tri

@@ -8,7 +8,7 @@
 -- the Tree Calculus term, `triage` enables branching logic based on the term's 
 -- shape, making it possible to perform structure-specific operations such as
 -- reconstructing the terms' source code representation.
-triage = (\leaf stem fork : t (t leaf stem) fork)
+-- triage = (\leaf stem fork : t (t leaf stem) fork)
 
 -- Base case of a single Leaf
 sourceLeaf = t (head "t")
@@ -40,7 +40,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)))"

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    = \a : a
-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)
 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 
+matchList = \a b : triage a _ b
-  oe 
-  _ 
-  oc
-)
 
-matchPair = (\op : triage 
+matchPair = \a   : triage _ _ a
-  _ 
-  _ 
-  op
-)
 
 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

src/Eval.hs

@@ -24,7 +24,7 @@ evalSingle env term
   | SVar name <- term =
       case Map.lookup name env of
         Just v  -> Map.insert "__result" v env
-        Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
+        Nothing -> errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined"
   | otherwise =
       Map.insert "__result" (evalAST env term) env
 
@@ -54,16 +54,29 @@ 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)
+      | null vs                    = toSKI v (elimLambda body)
-      | otherwise            = elimLambda (SLambda [v] (SLambda vs body))
+      | otherwise                  = elimLambda (SLambda [v] (SLambda vs body))
-    go (SApp f g)            = SApp (elimLambda f) (elimLambda g)
+    go (SApp f g)                  = SApp (elimLambda f) (elimLambda g)
-    go x                     = x
+    go x                           = x
 
     toSKI x (SVar y)
       | x == y           = _I
@@ -73,11 +86,13 @@ elimLambda = go
       | otherwise        = SApp (SApp _S (toSKI x n)) (toSKI x u)
     toSKI x t
       | not (isFree x t) = SApp _K t
-      | otherwise        = SApp (SApp _S (toSKI x t)) TLeaf
+      | otherwise        = errorWithoutStackTrace "Unhandled toSKI conversion"
 
-    _S = parseSingle "t (t (t t t)) t"
+    _S       = parseSingle "t (t (t t t)) t"
-    _K = parseSingle "t t"
+    _K       = parseSingle "t t"
-    _I = parseSingle "t (t (t 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 x = Set.member x . freeVars
     freeVars (SVar    v    ) = Set.singleton v

src/Parser.hs

@@ -85,13 +85,10 @@ scnParserM :: ParserM ()
 scnParserM = skipMany $ do
   t  <- lookAhead anySingle
   st <- get
-  if | (parenDepth st > 0 || bracketDepth st > 0) && case t of
+  if | (parenDepth st > 0 || bracketDepth st > 0) && (t == LNewline) ->
-         LNewline -> True
+       void $ satisfyM (== LNewline)
-         _        -> False -> void $ satisfyM $ \case
+     | otherwise ->
-           LNewline -> True
+       fail "In nested context or no space token" <|> empty
-           _        -> False
-     | 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
+  let ident = (\case LIdentifier _ -> True; _ -> False)
-    LIdentifier _ -> True
+  LIdentifier name <- satisfyM ident
-    _             -> False
+  args <- many $ satisfyM ident
-  args <- many $ satisfyM $ \case
-    LIdentifier _ -> True
-    _             -> False
   _    <- satisfyM (== LAssign)
   scnParserM
   body <- parseExpressionM
   pure (SFunc name (map getIdentifier args) body)
 
 parseLambdaM :: ParserM TricuAST
-parseLambdaM =
+parseLambdaM = do
-  between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ do
+  let ident = (\case LIdentifier _ -> True; _ -> False)
-    _     <- satisfyM (== LBackslash)
+  _      <- satisfyM (== LBackslash)
-    param <- satisfyM $ \case
+  params <- some (satisfyM ident)
-      LIdentifier _ -> True
+  _      <- satisfyM (== LColon)
-      _             -> False
+  scnParserM
-    rest  <- many $ satisfyM $ \case
+  body  <- parseLambdaExpressionM
-      LIdentifier _ -> True
+  pure $ foldr (\param acc -> SLambda [getIdentifier param] acc) body params
-      _             -> False
-    _     <- satisfyM (== LColon)
-    scnParserM
-    body <- parseLambdaExpressionM
-    let nested = foldr (\v acc -> SLambda [getIdentifier v] acc) body rest
-    pure (SLambda [getIdentifier param] nested)
 
 parseLambdaExpressionM :: ParserM TricuAST
 parseLambdaExpressionM = choice
@@ -180,9 +168,8 @@ parseAtomicBaseM = choice
 
 parseTreeLeafM :: ParserM TricuAST
 parseTreeLeafM = do
-  _ <- satisfyM $ \case
+  let keyword = (\case LKeywordT -> True; _ -> False)
-    LKeywordT -> True
+  _ <- satisfyM keyword
-    _         -> False
   notFollowedBy $ lift $ satisfy (== LAssign)
   pure TLeaf
 
@@ -248,37 +235,38 @@ parseGroupedItemM = do
 
 parseSingleItemM :: ParserM TricuAST
 parseSingleItemM = do
-  token <- satisfyM $ \case
+  token <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
-    LIdentifier _ -> True
+  if | LIdentifier name <- token -> pure (SVar name)
-    LKeywordT     -> True
+     | token == LKeywordT        -> pure TLeaf
-    _             -> False
+     | otherwise                 -> fail "Unexpected token in list item"
-  case token of
-    LIdentifier name -> pure (SVar name)
-    LKeywordT        -> pure TLeaf
-    _                -> fail "Unexpected token in list item"
 
 parseVarM :: ParserM TricuAST
 parseVarM = do
-  LIdentifier name <- satisfyM $ \case
+  satisfyM (\case LIdentifier _ -> True; _ -> False) >>= \case
-    LIdentifier _ -> True
+    LIdentifier name
-    _             -> False
+      | name == "t" || name == "__result" ->
-  if name == "t" || name == "__result"
+        fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
-    then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
+      | otherwise                         ->
-    else pure (SVar name)
+         pure (SVar name)
+    _ -> fail "Unexpected token while parsing variable"
 
 parseIntLiteralM :: ParserM TricuAST
 parseIntLiteralM = do
-  LIntegerLiteral value <- satisfyM $ \case
+  let intL = (\case LIntegerLiteral _ -> True; _ -> False)
-    LIntegerLiteral _ -> True
+  token <- satisfyM intL
-    _                 -> False
+  if | LIntegerLiteral value <- token ->
-  pure (SInt value)
+       pure (SInt value)
+     | otherwise                      ->
+       fail "Unexpected token while parsing integer literal"
 
 parseStrLiteralM :: ParserM TricuAST
 parseStrLiteralM = do
-  LStringLiteral value <- satisfyM $ \case 
+  let strL = (\case LStringLiteral _ -> True; _ -> False)
-    LStringLiteral _ -> True
+  token <- satisfyM strL
-    _ -> False
+  if | LStringLiteral value <- token ->
-  pure (SStr value)
+       pure (SStr value)
+     | otherwise                     ->
+       fail "Unexpected token while parsing string literal"
 
 getIdentifier :: LToken -> String
 getIdentifier (LIdentifier name) = name

test/Spec.hs

@@ -25,16 +25,17 @@ runTricu s = show $ result (evalTricu Map.empty $ parseTricu s)
 
 tests :: TestTree
 tests = testGroup "Tricu Tests"
-  [ lexerTests
+  [ lexer
-  , parserTests
+  , parser
-  , evaluationTests
+  , simpleEvaluation
-  , lambdaEvalTests
+  , lambdas
-  , libraryTests
+  , baseLibrary
-  , fileEvaluationTests
+  , fileEval
+  , demos
   ]
 
-lexerTests :: TestTree
+lexer :: TestTree
-lexerTests = testGroup "Lexer Tests"
+lexer = testGroup "Lexer Tests"
   [ testCase "Lex simple identifiers" $ do
       let input = "x a b = a"
           expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
@@ -74,8 +75,8 @@ lexerTests = testGroup "Lexer Tests"
           Right _ -> assertFailure "Expected failure when trying to assign the value of __result"
   ]
 
-parserTests :: TestTree
+parser :: TestTree
-parserTests = testGroup "Parser Tests"
+parser = testGroup "Parser Tests"
   [ testCase "Error when assigning a value to T" $ do
       let tokens = lexTricu "t = x" 
       case parseSingleExpr tokens of
@@ -175,8 +176,8 @@ parserTests = testGroup "Parser Tests"
       parseTricu input @?= expect
   ]
 
-evaluationTests :: TestTree
+simpleEvaluation :: TestTree
-evaluationTests = testGroup "Evaluation Tests"
+simpleEvaluation = testGroup "Evaluation Tests"
   [ testCase "Evaluate single Leaf" $ do
       let input = "t"
       let ast = parseSingle input
@@ -244,7 +245,7 @@ evaluationTests = testGroup "Evaluation Tests"
       (result env) @?= (Stem (Stem Leaf))
 
 
-  , testCase "Evaluate variable shadowing" $ do
+  , testCase "Immutable definitions" $ do
       let input = "x = t t\nx = t\nx"
           env = evalTricu Map.empty (parseTricu input)
       result <- try (evaluate (runTricu input)) :: IO (Either SomeException String)
@@ -260,8 +261,8 @@ evaluationTests = testGroup "Evaluation Tests"
       result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
   ]
 
-lambdaEvalTests :: TestTree
+lambdas :: TestTree
-lambdaEvalTests = testGroup "Lambda Evaluation Tests"
+lambdas = testGroup "Lambda Evaluation Tests"
   [ testCase "Lambda Identity Function" $ do
       let input = "id = (\\x : x)\nid t"
       runTricu input @?= "Leaf"
@@ -340,8 +341,8 @@ lambdaEvalTests = testGroup "Lambda Evaluation Tests"
         runTricu input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
   ]
 
-libraryTests :: TestTree
+baseLibrary :: TestTree
-libraryTests = testGroup "Library Tests"
+baseLibrary = testGroup "Library Tests"
   [ testCase "K combinator 1" $ do
       library <- evaluateFile "./lib/base.tri"
       let input = "k (t) (t t)"
@@ -476,8 +477,8 @@ libraryTests = testGroup "Library Tests"
       result env @?= Stem Leaf
   ]
 
-fileEvaluationTests :: TestTree
+fileEval :: TestTree
-fileEvaluationTests = testGroup "Evaluation tests"
+fileEval = testGroup "File evaluation tests"
   [ testCase "Forks" $ do
       res <- liftIO $ evaluateFileResult "./test/fork.tri"
       res @?= Fork Leaf Leaf
@@ -495,3 +496,23 @@ fileEvaluationTests = testGroup "Evaluation tests"
       res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
       decodeResult (result res) @?= "\"String test!\""
   ]
+
+demos :: TestTree
+demos = testGroup "Test provided demo functionality"
+  [ testCase "Structural equality demo" $ do
+      library <- liftIO $ evaluateFile "./lib/base.tri"
+      res     <- liftIO $ evaluateFileWithContext library "./demos/equality.tri"
+      decodeResult (result res) @?= "t t"
+  , testCase "Convert values back to source code demo" $ do
+      library <- liftIO $ evaluateFile "./lib/base.tri"
+      res     <- liftIO $ evaluateFileWithContext library "./demos/toSource.tri"
+      decodeResult (result res) @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\""
+  , testCase "Determining the size of functions" $ do
+      library <- liftIO $ evaluateFile "./lib/base.tri"
+      res     <- liftIO $ evaluateFileWithContext library "./demos/size.tri"
+      decodeResult (result res) @?= "454"
+  , testCase "Level Order Traversal demo" $ do
+      library <- liftIO $ evaluateFile "./lib/base.tri"
+      res     <- liftIO $ evaluateFileWithContext library "./demos/levelOrderTraversal.tri"
+      decodeResult (result res) @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \""
+  ]

tricu.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           tricu
-version:        0.7.0
+version:        0.9.0
 description:    A micro-language for exploring Tree Calculus
 author:         James Eversole
 maintainer:     james@eversole.co