Drop unreachable cases of updateDepth

Priming to update all source to lhs and document extensively

.gitea/workflows/test-and-build.yml

@@ -0,0 +1,86 @@
+name: Test and Build
+
+on:
+  push:
+    branches:
+      - main
+  pull_request:
+    types:
+      - opened
+      - synchronize
+
+jobs:
+  test:
+    container:
+      image: docker.matri.cx/nix-runner:latest
+      credentials:
+        username: ${{ secrets.REGISTRY_USERNAME }}
+        password: ${{ secrets.REGISTRY_PASSWORD }}
+    steps:
+      - name: Checkout code
+        uses: actions/checkout@v3
+
+      - name: Set up cache for Cabal
+        uses: actions/cache@v4
+        with:
+          path: |
+            ~/.cabal
+            ~/.ghc
+          key: cabal-${{ runner.os }}-${{ hashFiles('tricu.cabal') }}
+          restore-keys: |
+            cabal-${{ runner.os }}-
+
+      - name: Set up cache for Nix
+        uses: actions/cache@v4
+        with:
+          path: |
+            /nix/store
+            /nix/var/nix/cache
+          key: nix-${{ runner.os }}-${{ hashFiles('flake.lock') }}
+          restore-keys: |
+            nix-${{ runner.os }}-
+
+      - name: Initialize Cabal and update package list
+        run: |
+          nix develop --command cabal update
+
+      - name: Install dependencies and run tests
+        run: |
+          nix develop --command cabal test
+
+  build:
+    needs: test
+    container:
+      image: docker.matri.cx/nix-runner:latest
+      credentials:
+        username: ${{ secrets.REGISTRY_USERNAME }}
+        password: ${{ secrets.REGISTRY_PASSWORD }}
+    steps:
+      - name: Checkout code
+        uses: actions/checkout@v3
+
+      - name: Set up cache for Cabal
+        uses: actions/cache@v4
+        with:
+          path: |
+            ~/.cabal
+            ~/.ghc
+          key: cabal-${{ runner.os }}-${{ hashFiles('tricu.cabal') }}
+          restore-keys: |
+            cabal-${{ runner.os }}-
+
+      - name: Set up cache for Nix
+        uses: actions/cache@v4
+        with:
+          path: |
+            /nix/store
+            /nix/var/nix/cache
+          key: nix-${{ runner.os }}-${{ hashFiles('flake.lock') }}
+          restore-keys: |
+            nix-${{ runner.os }}-
+
+      - name: Build binary
+        run: |
+          nix build
+          ls -alh ./result/bin/tricu
+

README.md

@@ -2,7 +2,7 @@
 
 ## Introduction
 
-tricu (pronounced like "tree-shoe" in English) is a purely functional interpreted language implemented in Haskell. [I'm](https://eversole.co) developing tricu to further research the possibilities offered by the various forms of [Tree Calculi](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf).
+tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. [I'm](https://eversole.co) developing tricu to further research the possibilities offered by the various forms of [Tree Calculi](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf).
 
 tricu offers minimal syntax sugar yet manages to provide a complete, intuitive, and familiar programming environment. There is great power in simplicity. tricu offers:
 

demos/LevelOrderTraversal.tri

@@ -17,18 +17,52 @@
 --   4   5    6
 --
 
-isLeaf = (\node : lOr (emptyList node) (emptyList (tail node)))
+isLeaf = (\node : 
-getLabel = (\node : head node)
+  lOr 
-getLeft = (\node : if (emptyList node) [] (if (emptyList (tail node)) [] (head (tail node))))
+    (emptyList node) 
-getRight = (\node : if (emptyList node) [] (if (emptyList (tail node)) [] (if (emptyList (tail (tail node))) [] (head (tail (tail 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))))))
 
-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))))))
+
+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]]]]
+exampleOne = flatLOT [("1")
-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]]]
+                       [("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]]]
+
+exampleTwo

lib/base.tri

@@ -17,25 +17,77 @@ 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)
+matchBool = (\ot of : triage 
-matchPair = (\op : triage _ _ op)
+  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)
+lconcat = y (\self : matchList 
-lOr = triage (\x : x) (\_ _ : true) (\_ _ x : true)
+  (\k : k) 
-hmap = y (\self : matchList (\f : t) (\hd tl f : pair (f hd) (self tl f)))
+  (\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))))
+
+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)

src/Eval.hs

@@ -8,110 +8,85 @@ import Data.Map  (Map)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
-evalSingle :: Map String T -> TricuAST -> Map String T
+evalSingle :: Env -> TricuAST -> Env
-evalSingle env term = case term of
+evalSingle env term
-  SFunc name [] body ->
+  | SFunc name [] body <- term =
-    let lineNoLambda = eliminateLambda body
+      let res = evalAST env body
-        result = evalAST env lineNoLambda
+      in Map.insert "__result" res (Map.insert name res env)
-    in Map.insert "__result" result (Map.insert name result env)
+  | SApp func arg <- term =
-  SLambda _ body ->
+      let res = apply (evalAST env func) (evalAST env arg)
-    let result = evalAST env body
+      in Map.insert "__result" res env
-    in Map.insert "__result" result env
+  | SVar name <- term =
-  SApp func arg ->
-    let result = apply (evalAST env $ eliminateLambda func) (evalAST env $ eliminateLambda arg)
-    in Map.insert "__result" result env
-  SVar name ->
       case Map.lookup name env of
-      Just value -> Map.insert "__result" value env
+        Just v  -> Map.insert "__result" v env
         Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
-  _ ->
+  | otherwise =
-    let result = evalAST env term
+      Map.insert "__result" (evalAST env term) env
-    in Map.insert "__result" result env
 
-evalTricu :: Map String T -> [TricuAST] -> Map String T
+evalTricu :: Env -> [TricuAST] -> Env
-evalTricu env list = evalTricu' env (filter (/= SEmpty) list)
+evalTricu env []     = env
-  where
+evalTricu env [x]    =
-  evalTricu' :: Map String T -> [TricuAST] -> Map String T
+  let updatedEnv = evalSingle env x
-  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 (x:xs) =
-    let lineNoLambda = eliminateLambda line
+  evalTricu (evalSingle env x) xs
-        updatedEnv = evalSingle env lineNoLambda
-    in evalTricu updatedEnv rest
 
-evalAST :: Map String T -> TricuAST -> T
+evalAST :: Env -> TricuAST -> T
-evalAST env term = case term of
+evalAST env term
-  SVar name -> case Map.lookup name env of
+  | SLambda _ _ <- term = evalAST env (elimLambda term)
-    Just value -> value
+  | SVar   name <- term = evalVar name
-    Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
+  | TLeaf       <- term = Leaf
-  TLeaf -> Leaf
+  | TStem  t    <- term = Stem (evalAST env t)
-  TStem t -> Stem (evalAST env t)
+  | TFork  t u  <- term = Fork (evalAST env t) (evalAST env u)
-  TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2)
+  | SApp   t u  <- term = apply (evalAST env t) (evalAST env u)
-  SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2)
+  | SStr   s    <- term = ofString s
-  SStr str -> ofString str
+  | SInt   n    <- term = ofNumber n
-  SInt num -> ofNumber num
+  | SList  xs   <- term = ofList (map (evalAST env) xs)
-  SList elems -> ofList (map (evalAST env) elems)
+  | SEmpty      <- term = Leaf
-  SEmpty -> Leaf
+  | otherwise           = errorWithoutStackTrace "Unexpected AST term"
-  SFunc name args body ->
+    where
-    errorWithoutStackTrace $ "Unexpected function definition " ++ name
+      evalVar name = Map.findWithDefault
-  SLambda {} -> errorWithoutStackTrace "Internal error: SLambda found in evalAST after elimination."
+        (errorWithoutStackTrace $ "Variable " ++ name ++ " not defined")
-
+        name env
-eliminateLambda :: TricuAST -> TricuAST
-eliminateLambda (SLambda (v:vs) body)
-  | null vs = lambdaToT v (eliminateLambda body)
-  | otherwise = eliminateLambda (SLambda [v] (SLambda vs body))
-eliminateLambda (SApp f arg) = SApp (eliminateLambda f) (eliminateLambda arg)
-eliminateLambda (TStem t) = TStem (eliminateLambda t)
-eliminateLambda (TFork l r) = TFork (eliminateLambda l) (eliminateLambda r)
-eliminateLambda (SList xs) = SList (map eliminateLambda xs)
-eliminateLambda other = other
 
 -- https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf
 -- Chapter 4: Lambda-Abstraction
-lambdaToT :: String -> TricuAST -> TricuAST
+elimLambda :: TricuAST -> TricuAST
-lambdaToT x (SVar y)
+elimLambda = go
-  | x == y = tI
+  where
-lambdaToT x (SVar y)
+    go (SLambda (v:vs) body)
-  | x /= y = SApp tK (SVar y)
+      | null vs              = toSKI v (elimLambda body)
-lambdaToT x t
+      | otherwise            = elimLambda (SLambda [v] (SLambda vs body))
-  | not (isFree x t) = SApp tK t
+    go (SApp f g)            = SApp (elimLambda f) (elimLambda g)
-lambdaToT x (SApp n u)
+    go x                     = x
-  | not (isFree x (SApp n u)) = SApp tK (SApp (eliminateLambda n) (eliminateLambda u))
-lambdaToT x (SApp n u) = SApp (SApp tS (lambdaToT x (eliminateLambda n))) (lambdaToT x (eliminateLambda u))
-lambdaToT x body
-  | not (isFree x body) = SApp tK body
-  | otherwise = SApp (SApp tS (lambdaToT x body)) TLeaf
 
-freeVars :: TricuAST -> Set.Set String
+    toSKI x (SVar y)
+      | x == y           = _I
+      | otherwise        = SApp _K (SVar y)
+    toSKI x t@(SApp n u)
+      | not (isFree x t) = SApp _K t
+      | 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
+
+    _S = parseSingle "t (t (t t t)) t"
+    _K = parseSingle "t t"
+    _I = parseSingle "t (t (t t)) t"
+    
+    isFree x = Set.member x . freeVars
     freeVars (SVar    v    ) = Set.singleton v
     freeVars (SInt    _    ) = Set.empty
     freeVars (SStr    _    ) = Set.empty
-freeVars (SList xs) = foldMap freeVars xs
+    freeVars (SList   s    ) = foldMap freeVars s
-freeVars (SApp f arg) = freeVars f <> freeVars arg
+    freeVars (SApp    f a  ) = freeVars f <> freeVars a
-freeVars TLeaf = Set.empty
+    freeVars (TLeaf        ) = Set.empty
     freeVars (SFunc   _ _ b) = freeVars b
     freeVars (TStem   t    ) = freeVars t
     freeVars (TFork   l r  ) = freeVars l <> freeVars r
-freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
+    freeVars (SLambda v b  ) = foldr Set.delete (freeVars b) v
 
-isFree :: String -> TricuAST -> Bool
+result :: Env -> T
-isFree x = Set.member x . freeVars
-
--- We need the SKI operators in an unevaluated TricuAST tree form so that we
--- can keep the evaluation functions straightforward
-tI :: TricuAST
-tI = SApp (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))) TLeaf
-
-tK :: TricuAST
-tK = SApp TLeaf TLeaf
-
-tS :: TricuAST
-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"

src/Lexer.hs

@@ -61,7 +61,10 @@ lnewline :: Lexer LToken
 lnewline = char '\n' *> pure LNewline
 
 sc :: Lexer ()
-sc = space space1 (skipLineComment "--") (skipBlockComment "|-" "-|")
+sc = space
+  (void $ takeWhile1P (Just "space") (\c -> c == ' ' || c == '\t'))
+  (skipLineComment "--")
+  (skipBlockComment "|-" "-|")
 
 tricuLexer :: Lexer [LToken]
 tricuLexer = do
@@ -75,7 +78,8 @@ tricuLexer = do
   pure tokens
     where
       tricuLexer' = 
-        [ try identifier
+        [ try lnewline
+        , try identifier
         , try keywordT
         , try integerLiteral
         , try stringLiteral

src/Main.hs

@@ -81,4 +81,7 @@ main = do
       putStrLn $ decodeResult $ result $ evalTricu library $ parseTricu value
 
 runTricu :: String -> T
-runTricu = result . evalTricu Map.empty . parseTricu
+runTricu input =
+  let asts     = parseTricu input
+      finalEnv = evalTricu Map.empty asts
+   in result finalEnv

src/Parser.hs

@@ -1,277 +1,304 @@
 module Parser where
 
 import Lexer
-import Research hiding       (toList)
+import Research
 
+import Control.Monad (void)
+import Control.Monad.State
 import Data.List.NonEmpty (toList)
 import Data.Void (Void)
 import Text.Megaparsec
-import Text.Megaparsec.Char
 import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
-
 import qualified Data.Set as Set
 
-type Parser    = Parsec Void [LToken]
+data PState = PState
-type AltParser = Parsec Void String
+  { parenDepth  :: Int
+  , bracketDepth :: Int
+  } deriving (Show)
+
+type ParserM = StateT PState (Parsec Void [LToken])
+
+satisfyM :: (LToken -> Bool) -> ParserM LToken
+satisfyM f = do
+  token <- lift (satisfy f)
+  modify' (updateDepth token)
+  return token
+
+updateDepth :: LToken -> PState -> PState
+updateDepth LOpenParen    st = st { parenDepth   = parenDepth st   + 1 }
+updateDepth LOpenBracket  st = st { bracketDepth = bracketDepth st + 1 }
+updateDepth LCloseParen   st = st { parenDepth   = parenDepth st   - 1 }
+updateDepth LCloseBracket st = st { bracketDepth = bracketDepth st - 1 }
+updateDepth _ st = st
+
+topLevelNewline :: ParserM ()
+topLevelNewline = do
+  st <- get
+  if parenDepth st == 0 && bracketDepth st == 0
+    then void (satisfyM (== LNewline))
+    else fail "Top-level exit in nested context (paren or bracket)"
+
+parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
+parseProgram tokens =
+  runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
+
+parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
+parseSingleExpr tokens =
+  runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
+
+finalizeDepth :: ParserM ()
+finalizeDepth = do
+  st <- get
+  case (parenDepth st, bracketDepth st) of
+    (0, 0) -> pure ()
+    (p, b) -> fail $ "Unmatched tokens: " ++ show (p, b)
 
 parseTricu :: String -> [TricuAST]
-parseTricu input
+parseTricu input =
-  | null tokens = []
+  case lexTricu input of
-  | otherwise = map parseSingle tokens
-  where
-    tokens = case lexTricu input of
     [] -> []
-      tokens -> lines input
+    toks ->
+      case parseProgram toks of
+        Left err   -> errorWithoutStackTrace (handleParseError err)
+        Right asts -> asts
 
 parseSingle :: String -> TricuAST
-parseSingle input = case lexTricu input of
+parseSingle input =
+  case lexTricu input of
     [] -> SEmpty
-  tokens -> case runParser parseExpression "" tokens of
+    toks ->
-    Left err -> error $ handleParseError err
+      case parseSingleExpr toks of
+        Left err -> errorWithoutStackTrace (handleParseError err)
         Right ast -> ast
 
-parseExpression :: Parser TricuAST
+parseProgramM :: ParserM [TricuAST]
-parseExpression = choice
+parseProgramM = do
-  [ try parseFunction
+  skipMany topLevelNewline
-  , try parseLambda
+  exprs <- sepEndBy parseOneExpression (some topLevelNewline)
-  , try parseLambdaExpression
+  skipMany topLevelNewline
-  , try parseListLiteral
+  return exprs
-  , try parseApplication
+
-  , try parseTreeTerm
+parseOneExpression :: ParserM TricuAST
-  , parseLiteral
+parseOneExpression = scnParserM *> parseExpressionM
+
+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
+
+
+eofM :: ParserM ()
+eofM = lift eof
+
+parseExpressionM :: ParserM TricuAST
+parseExpressionM = choice
+  [ try parseFunctionM
+  , try parseLambdaM
+  , try parseLambdaExpressionM
+  , try parseListLiteralM
+  , try parseApplicationM
+  , try parseTreeTermM
+  , parseLiteralM
   ]
 
-scnParser :: Parser ()
+parseFunctionM :: ParserM TricuAST
-scnParser = skipMany (satisfy isNewline)
+parseFunctionM = do
+  LIdentifier name <- satisfyM $ \case
+    LIdentifier _ -> True
+    _             -> False
+  args <- many $ satisfyM $ \case
+    LIdentifier _ -> True
+    _             -> False
+  _    <- satisfyM (== LAssign)
+  scnParserM
+  body <- parseExpressionM
+  pure (SFunc name (map getIdentifier args) body)
 
-parseFunction :: Parser TricuAST
+parseLambdaM :: ParserM TricuAST
-parseFunction = do
+parseLambdaM =
-  LIdentifier name <- satisfy isIdentifier
+  between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ do
-  args <- many (satisfy isIdentifier)
+    _     <- satisfyM (== LBackslash)
-  satisfy (== LAssign)
+    param <- satisfyM $ \case
-  body <- parseExpression
+      LIdentifier _ -> True
-  return (SFunc name (map getIdentifier args) body)
+      _             -> False
+    rest  <- many $ satisfyM $ \case
+      LIdentifier _ -> True
+      _             -> False
+    _     <- satisfyM (== LColon)
+    scnParserM
+    body <- parseLambdaExpressionM
+    let nested = foldr (\v acc -> SLambda [getIdentifier v] acc) body rest
+    pure (SLambda [getIdentifier param] nested)
 
-parseAtomicBase :: Parser TricuAST
+parseLambdaExpressionM :: ParserM TricuAST
-parseAtomicBase = choice
+parseLambdaExpressionM = choice
-    [ parseTreeLeaf
+  [ try parseLambdaApplicationM
-    , parseGrouped
+  , parseAtomicLambdaM
   ]
 
-parseLambda :: Parser TricuAST
+parseAtomicLambdaM :: ParserM TricuAST
-parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
+parseAtomicLambdaM = choice
-  satisfy (== LBackslash)
+  [ parseVarM
-  param    <- satisfy isIdentifier
+  , parseTreeLeafM
-  rest     <- many (satisfy isIdentifier)
+  , parseLiteralM
-  satisfy (== LColon)
+  , parseListLiteralM
-  body     <- parseLambdaExpression
+  , try parseLambdaM
-  let nestedLambda = foldr (\v acc -> SLambda [v] acc) body (map getIdentifier rest)
+  , between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseLambdaExpressionM
-  return (SLambda [getIdentifier param] nestedLambda)
-
-parseLambdaExpression :: Parser TricuAST
-parseLambdaExpression = choice
-  [ try parseLambdaApplication
-  , parseAtomicLambda
   ]
 
-parseAtomicLambda :: Parser TricuAST
+parseApplicationM :: ParserM TricuAST
-parseAtomicLambda = choice
+parseApplicationM = do
-  [ parseVar
+  func <- parseAtomicBaseM
-  , parseTreeLeaf
+  scnParserM
-  , parseLiteral
+  args <- many $ do
-  , parseListLiteral
+    scnParserM
-  , try parseLambda
+    arg <- parseAtomicM
-  , between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseLambdaExpression
+    return arg
+  return $ foldl SApp func args
+
+parseLambdaApplicationM :: ParserM TricuAST
+parseLambdaApplicationM = do
+  func <- parseAtomicLambdaM
+  scnParserM
+  args <- many $ do
+    arg <- parseAtomicLambdaM
+    scnParserM
+    pure arg
+  pure $ foldl SApp func args
+
+parseAtomicBaseM :: ParserM TricuAST
+parseAtomicBaseM = choice
+  [ parseTreeLeafM
+  , parseGroupedM
   ]
 
-parseApplication :: Parser TricuAST
+parseTreeLeafM :: ParserM TricuAST
-parseApplication = do
+parseTreeLeafM = do
-  func <- parseAtomicBase
+  _ <- satisfyM $ \case
-  args <- many parseAtomic
+    LKeywordT -> True
-  return $ foldl (\acc arg -> SApp acc arg) func args
+    _         -> False
+  notFollowedBy $ lift $ satisfy (== LAssign)
+  pure TLeaf
 
-parseLambdaApplication :: Parser TricuAST
+parseTreeTermM :: ParserM TricuAST
-parseLambdaApplication = do
+parseTreeTermM = do
-  func <- parseAtomicLambda
+  base <- parseTreeLeafOrParenthesizedM
-  args <- many parseAtomicLambda
+  rest <- many parseTreeLeafOrParenthesizedM
-  return $ foldl (\acc arg -> SApp acc arg) func args
+  pure (foldl combine base rest)
+  where
+    combine acc next
+      | TLeaf     <- acc = TStem next
+      | TStem t   <- acc = TFork t next
+      | TFork _ _ <- acc = TFork acc next
 
-isTreeTerm :: TricuAST -> Bool
+parseTreeLeafOrParenthesizedM :: ParserM TricuAST
-isTreeTerm TLeaf = True
+parseTreeLeafOrParenthesizedM = choice
-isTreeTerm (TStem _) = True
+  [ between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseTreeTermM
-isTreeTerm (TFork _ _) = True
+  , parseTreeLeafM
-isTreeTerm _ = False
+  ]
 
-parseTreeLeaf :: Parser TricuAST
+parseAtomicM :: ParserM TricuAST
-parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf
+parseAtomicM = choice
+  [ parseVarM
+  , parseTreeLeafM
+  , parseListLiteralM
+  , parseGroupedM
+  , parseLiteralM
+  ]
+
+parseGroupedM :: ParserM TricuAST
+parseGroupedM = between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $
+  scnParserM *> parseExpressionM <* scnParserM
+
+parseLiteralM :: ParserM TricuAST
+parseLiteralM = choice
+  [ parseIntLiteralM
+  , parseStrLiteralM
+  ]
+
+parseListLiteralM :: ParserM TricuAST
+parseListLiteralM = do
+  _        <- satisfyM (== LOpenBracket)
+  elements <- many $ do
+    scnParserM
+    parseListItemM
+  scnParserM
+  _        <- satisfyM (== LCloseBracket)
+  pure (SList elements)
+
+parseListItemM :: ParserM TricuAST
+parseListItemM = choice
+  [ parseGroupedItemM
+  , parseListLiteralM
+  , parseSingleItemM
+  ]
+
+parseGroupedItemM :: ParserM TricuAST
+parseGroupedItemM = do
+  _     <- satisfyM (== LOpenParen)
+  inner <- parseExpressionM
+  _     <- satisfyM (== LCloseParen)
+  pure inner
+
+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"
+
+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)
+
+parseIntLiteralM :: ParserM TricuAST
+parseIntLiteralM = do
+  LIntegerLiteral value <- satisfyM $ \case
+    LIntegerLiteral _ -> True
+    _                 -> False
+  pure (SInt value)
+
+parseStrLiteralM :: ParserM TricuAST
+parseStrLiteralM = do
+  LStringLiteral value <- satisfyM $ \case 
+    LStringLiteral _ -> True
+    _ -> False
+  pure (SStr value)
 
 getIdentifier :: LToken -> String
 getIdentifier (LIdentifier name) = name
-getIdentifier _ = error "Expected identifier"
+getIdentifier _                  = errorWithoutStackTrace "Expected identifier"
 
-parseTreeTerm :: Parser TricuAST
-parseTreeTerm = do
-  base <- parseTreeLeafOrParenthesized
-  rest <- many parseTreeLeafOrParenthesized
-  pure $ foldl combine base rest
-  where
-    combine acc next = case acc of
-      TLeaf -> TStem next
-      TStem t -> TFork t next
-      TFork _ _ -> TFork acc next
-
-parseTreeLeafOrParenthesized :: Parser TricuAST
-parseTreeLeafOrParenthesized = choice
-  [ between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseTreeTerm
-  , parseTreeLeaf
-  ]
-
-foldTree :: [TricuAST] -> TricuAST
-foldTree [] = TLeaf
-foldTree [x] = x
-foldTree (x:y:rest) = TFork x (foldTree (y:rest))
-
-parseAtomic :: Parser TricuAST
-parseAtomic = choice
-  [ parseVar
-  , parseTreeLeaf
-  , parseListLiteral
-  , parseGrouped
-  , parseLiteral
-  ]
-
-parseGrouped :: Parser TricuAST
-parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
-
-parseLiteral :: Parser TricuAST
-parseLiteral = choice
-  [ parseIntLiteral
-  , parseStrLiteral
-  ]
-
-parens :: Parser TricuAST -> Parser TricuAST
-parens p = do
-  satisfy (== LOpenParen)
-  result <- p
-  satisfy (== LCloseParen)
-  return result
-
-parseListLiteral :: Parser TricuAST
-parseListLiteral = do
-  satisfy (== LOpenBracket)
-  elements <- many parseListItem
-  satisfy (== LCloseBracket)
-  return (SList elements)
-
-parseListItem :: Parser TricuAST
-parseListItem = choice
-  [ parseGroupedItem
-  , parseListLiteral
-  , parseSingleItem
-  ]
-
-parseGroupedItem :: Parser TricuAST
-parseGroupedItem = do
-  satisfy (== LOpenParen)
-  inner <- parseExpression
-  satisfy (== LCloseParen)
-  return inner
-
-parseSingleItem :: Parser TricuAST
-parseSingleItem = do
-  token <- satisfy isListItem
-  case token of
-    LIdentifier name -> return (SVar name)
-    LKeywordT -> return TLeaf
-    _ -> fail "Unexpected token in list item"
-
-isListItem :: LToken -> Bool
-isListItem (LIdentifier _) = True
-isListItem LKeywordT = True
-isListItem _ = False
-
-parseVar :: Parser TricuAST
-parseVar = do
-  LIdentifier name <- satisfy isIdentifier
-  if (name == "t" || name == "__result")
-    then fail $ "Reserved keyword: " ++ name ++ " cannot be assigned."
-    else return (SVar name)
-
-parseIntLiteral :: Parser TricuAST
-parseIntLiteral = do
-  LIntegerLiteral value <- satisfy isIntegerLiteral
-  return (SInt value)
-
-parseStrLiteral :: Parser TricuAST
-parseStrLiteral = do
-  LStringLiteral value <- satisfy isStringLiteral
-  return (SStr value)
-
--- Boolean Helpers
-isKeywordT (LKeywordT) = True
-isKeywordT _ = False
-isIdentifier (LIdentifier _) = True
-isIdentifier _ = False
-isIntegerLiteral (LIntegerLiteral _) = True
-isIntegerLiteral _ = False
-isStringLiteral (LStringLiteral _) = True
-isStringLiteral _ = False
-isLiteral (LIntegerLiteral _) = True
-isLiteral (LStringLiteral _) = True
-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 =
   let errors = bundleErrors bundle
-      errorList = toList errors
+      formattedErrors = map formatError (Data.List.NonEmpty.toList errors)
-      formattedErrors = map showError errorList
   in unlines ("Parse error(s) encountered:" : formattedErrors)
 
-showError :: ParseError [LToken] Void -> String
+formatError :: ParseError [LToken] Void -> String
-showError (TrivialError offset (Just (Tokens tokenStream)) expected) =
+formatError (TrivialError offset unexpected expected) =
-  "Parse error at offset " ++ show offset ++ ": unexpected token "
+  let unexpectedMsg = case unexpected of
-  ++ show tokenStream ++ ", expected one of " ++ show (Set.toList expected)
+        Just x  -> "unexpected token " ++ show x
-showError (FancyError offset fancy) =
+        Nothing -> "unexpected end of input"
-  "Parse error at offset " ++ show offset ++ ":\n " ++ unlines (map show (Set.toList fancy))
+      expectedMsg = if null expected
-showError (TrivialError offset Nothing expected) =
+        then ""
-  "Parse error at offset " ++ show offset ++ ": expected one of "
+        else "expected " ++ show (Set.toList expected)
-  ++ show (Set.toList expected)
+  in "Parse error at offset " ++ show offset ++ ": " ++ unexpectedMsg ++
+     if null expectedMsg then "" else " " ++ expectedMsg
+formatError (FancyError offset _) =
+  "Parse error at offset " ++ show offset ++ ": unexpected FancyError"

src/REPL.hs

@@ -20,37 +20,36 @@ repl env = runInputT defaultSettings (loop env)
     loop :: Env -> InputT IO ()
     loop env = do
       minput <- getInputLine "tricu < "
-      case minput of
+      if
-        Nothing -> outputStrLn "Exiting tricu"
+        | Nothing <- minput                     -> outputStrLn "Exiting tricu"
-        Just s -> case strip s of 
+        | Just s  <- minput, strip s == "!exit" -> outputStrLn "Exiting tricu"
-          "!exit" -> outputStrLn "Exiting tricu"
+        | Just s  <- minput, strip s == ""      -> do
-          "!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
+        | Just s  <- minput, strip s == "!load" -> do
-            case (take 2 input) of 
+          path <- getInputLine "File path to load < "
-              "--" -> loop env
+          if
-              _ -> do
+            | Nothing <- path -> do
-                newEnv <- liftIO $ (processInput env input `catch` errorHandler env)
+              outputStrLn "No input received; stopping import."
+              loop env
+            | Just p  <- path -> do
+              loadedEnv <- liftIO $ evaluateFileWithContext env (strip p) `catch` \e -> errorHandler env e
+              loop $ Map.delete "__result" (Map.union loadedEnv env)
+        | Just s <- minput -> do
+          if
+            | take 2 s == "--" -> loop env
+            | otherwise -> do
+              newEnv <- liftIO $ processInput env s `catch` errorHandler env
               loop newEnv
 
     processInput :: Env -> String -> IO Env
     processInput env input = do
       let asts   = parseTricu input
           newEnv = evalTricu env asts
-      case Map.lookup "__result" newEnv of
+      if
-        Just r -> do
+        | Just r <- Map.lookup "__result" newEnv -> do
           putStrLn $ "tricu > " ++ decodeResult r
-        Nothing -> return ()
+        | otherwise -> return ()
       return newEnv
     
     errorHandler :: Env -> SomeException -> IO (Env)
@@ -62,10 +61,8 @@ repl env = runInputT defaultSettings (loop env)
     strip = dropWhileEnd isSpace . dropWhile isSpace
 
 decodeResult :: T -> String
-decodeResult tc = case toNumber tc of
+decodeResult tc
-  Right num -> show num
+  | Right num  <- toNumber tc = show num
-  Left _ -> case toString tc of
+  | Right str  <- toString tc = "\"" ++ str ++ "\""
-    Right str -> "\"" ++ str ++ "\""
+  | Right list <- toList tc   = "[" ++ intercalate ", " (map decodeResult list) ++ "]"
-    Left _ -> case toList tc of
+  | otherwise                 = formatResult TreeCalculus tc
-      Right list -> "[" ++ intercalate ", " (map decodeResult list) ++ "]"
-      Left _ -> formatResult TreeCalculus tc

src/Research.hs

@@ -28,7 +28,7 @@ data TricuAST
   | SEmpty
   deriving (Show, Eq, Ord)
 
--- Tokens from Lexer
+-- Lexer Tokens
 data LToken
   = LKeywordT
   | LIdentifier String
@@ -61,19 +61,6 @@ 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
 
--- SKI Combinators
-_S :: T
-_S = Fork (Stem (Fork Leaf Leaf)) Leaf
-
-_K :: T
-_K = Stem Leaf
-
--- Identity
--- We use the "point-free" style which drops a redundant node
--- Full I form (SKK): Fork (Stem (Stem Leaf)) (Stem Leaf)
-_I :: T
-_I = Fork (Stem (Stem Leaf)) Leaf 
-
 -- Booleans
 _false :: T
 _false = Leaf

test/Spec.hs

@@ -31,7 +31,6 @@ tests = testGroup "Tricu Tests"
   , lambdaEvalTests
   , libraryTests
   , fileEvaluationTests
-  , propertyTests
   ]
 
 lexerTests :: TestTree
@@ -72,8 +71,8 @@ lexerTests = testGroup "Lexer Tests"
 parserTests :: TestTree
 parserTests = testGroup "Parser Tests"
   [ testCase "Error when assigning a value to T" $ do
-      let input = lexTricu "t = x"
+      let tokens = lexTricu "t = x" 
-      case (runParser parseExpression "" input) of
+      case parseSingleExpr tokens of
         Left  _ -> return ()
         Right _ -> assertFailure "Expected failure when trying to assign the value of T"
   , testCase "Parse function definitions" $ do
@@ -150,10 +149,6 @@ 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 
   ]
 
 evaluationTests :: TestTree
@@ -414,13 +409,3 @@ fileEvaluationTests = testGroup "Evaluation tests"
       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 ->
-      case runParser tricuLexer "" input of
-        Left _ -> property True
-        Right tokens -> case runParser parseExpression "" tokens of
-          Left _ -> property True
-          Right ast -> parseSingle input === ast
-  ]

tricu.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           tricu
-version:        0.5.0
+version:        0.6.0
 description:    A micro-language for exploring Tree Calculus
 author:         James Eversole
 maintainer:     james@eversole.co
@@ -18,6 +18,8 @@ executable tricu
       src
   default-extensions:
       DeriveDataTypeable
+      LambdaCase
+      MultiWayIf
       OverloadedStrings
   ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
   build-depends:
@@ -43,6 +45,8 @@ test-suite tricu-tests
   hs-source-dirs:      test, src
   default-extensions:
       DeriveDataTypeable
+      LambdaCase
+      MultiWayIf
       OverloadedStrings
   build-depends:       
     base