Drop unreachable cases of updateDepth

demos/LevelOrderTraversal.tri

@@ -57,7 +57,12 @@ 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]]]
 
-exampleOne
+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

src/Parser.hs

@@ -12,7 +12,8 @@ import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
 import qualified Data.Set as Set
 
 data PState = PState
-  { depth :: Int
+  { parenDepth  :: Int
+  , bracketDepth :: Int
   } deriving (Show)
 
 type ParserM = StateT PState (Parsec Void [LToken])
@@ -24,24 +25,33 @@ satisfyM f = do
   return token
 
 updateDepth :: LToken -> PState -> PState
-updateDepth LOpenParen  st = st { depth = depth st + 1 }
+updateDepth LOpenParen    st = st { parenDepth   = parenDepth st   + 1 }
-updateDepth LCloseParen st = st { depth = max 0 (depth 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 depth st == 0
+  if parenDepth st == 0 && bracketDepth st == 0
     then void (satisfyM (== LNewline))
-    else fail "Top-level exit in paren context"
+    else fail "Top-level exit in nested context (paren or bracket)"
 
 parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
 parseProgram tokens =
-  runParser (evalStateT parseProgramM (PState 0)) "" tokens
+  runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
 
 parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
 parseSingleExpr tokens =
-  runParser (evalStateT (scnParserM *> parseExpressionM <* eofM) (PState 0)) "" 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 =
@@ -49,7 +59,7 @@ parseTricu input =
     [] -> []
     toks ->
       case parseProgram toks of
-        Left err   -> error (handleParseError err)
+        Left err   -> errorWithoutStackTrace (handleParseError err)
         Right asts -> asts
 
 parseSingle :: String -> TricuAST
@@ -58,7 +68,7 @@ parseSingle input =
     [] -> SEmpty
     toks ->
       case parseSingleExpr toks of
-        Left err -> error (handleParseError err)
+        Left err -> errorWithoutStackTrace (handleParseError err)
         Right ast -> ast
 
 parseProgramM :: ParserM [TricuAST]
@@ -75,10 +85,13 @@ scnParserM :: ParserM ()
 scnParserM = skipMany $ do
   t  <- lookAhead anySingle
   st <- get
-  if depth st > 0 && isNewline t
+  if | (parenDepth st > 0 || bracketDepth st > 0) && case t of
-    then void (satisfyM isNewline)
+         LNewline -> True
-    else
+         _        -> False -> void $ satisfyM $ \case
-      fail "In paren context or no space token" <|> empty
+           LNewline -> True
+           _        -> False
+     | otherwise -> fail "In nested context or no space token" <|> empty
+
 
 eofM :: ParserM ()
 eofM = lift eof
@@ -96,18 +109,27 @@ parseExpressionM = choice
 
 parseFunctionM :: ParserM TricuAST
 parseFunctionM = do
-  LIdentifier name <- satisfyM isIdentifier
+  LIdentifier name <- satisfyM $ \case
-  args <- many (satisfyM isIdentifier)
+    LIdentifier _ -> True
+    _             -> False
+  args <- many $ satisfyM $ \case
+    LIdentifier _ -> True
+    _             -> False
   _    <- satisfyM (== LAssign)
   scnParserM
   body <- parseExpressionM
   pure (SFunc name (map getIdentifier args) body)
 
 parseLambdaM :: ParserM TricuAST
-parseLambdaM = between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ do
+parseLambdaM =
+  between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ do
     _     <- satisfyM (== LBackslash)
-  param   <- satisfyM isIdentifier
+    param <- satisfyM $ \case
-  rest    <- many (satisfyM isIdentifier)
+      LIdentifier _ -> True
+      _             -> False
+    rest  <- many $ satisfyM $ \case
+      LIdentifier _ -> True
+      _             -> False
     _     <- satisfyM (== LColon)
     scnParserM
     body <- parseLambdaExpressionM
@@ -158,8 +180,10 @@ parseAtomicBaseM = choice
 
 parseTreeLeafM :: ParserM TricuAST
 parseTreeLeafM = do
-  _ <- satisfyM isKeywordT
+  _ <- satisfyM $ \case
-  notFollowedBy (lift (satisfy (== LAssign)))
+    LKeywordT -> True
+    _         -> False
+  notFollowedBy $ lift $ satisfy (== LAssign)
   pure TLeaf
 
 parseTreeTermM :: ParserM TricuAST
@@ -201,7 +225,10 @@ parseLiteralM = choice
 parseListLiteralM :: ParserM TricuAST
 parseListLiteralM = do
   _        <- satisfyM (== LOpenBracket)
-  elements <- many parseListItemM
+  elements <- many $ do
+    scnParserM
+    parseListItemM
+  scnParserM
   _        <- satisfyM (== LCloseBracket)
   pure (SList elements)
 
@@ -221,7 +248,10 @@ parseGroupedItemM = do
 
 parseSingleItemM :: ParserM TricuAST
 parseSingleItemM = do
-  token <- satisfyM isListItem
+  token <- satisfyM $ \case
+    LIdentifier _ -> True
+    LKeywordT     -> True
+    _             -> False
   case token of
     LIdentifier name -> pure (SVar name)
     LKeywordT        -> pure TLeaf
@@ -229,71 +259,46 @@ parseSingleItemM = do
 
 parseVarM :: ParserM TricuAST
 parseVarM = do
-  LIdentifier name <- satisfyM isIdentifier
+  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 isIntegerLiteral
+  LIntegerLiteral value <- satisfyM $ \case
+    LIntegerLiteral _ -> True
+    _                 -> False
   pure (SInt value)
 
 parseStrLiteralM :: ParserM TricuAST
 parseStrLiteralM = do
-  LStringLiteral value <- satisfyM isStringLiteral
+  LStringLiteral value <- satisfyM $ \case 
+    LStringLiteral _ -> True
+    _ -> False
   pure (SStr value)
 
-isKeywordT :: LToken -> Bool
-isKeywordT LKeywordT = True
-isKeywordT _         = False
-
-isIdentifier :: LToken -> Bool
-isIdentifier (LIdentifier _) = True
-isIdentifier _               = False
-
-isIntegerLiteral :: LToken -> Bool
-isIntegerLiteral (LIntegerLiteral _) = True
-isIntegerLiteral _                   = False
-
-isStringLiteral :: LToken -> Bool
-isStringLiteral (LStringLiteral _)   = True
-isStringLiteral _                    = False
-
-isLiteral :: LToken -> Bool
-isLiteral (LIntegerLiteral _) = True
-isLiteral (LStringLiteral _)  = True
-isLiteral _                   = False
-
-isListItem :: LToken -> Bool
-isListItem (LIdentifier _) = True
-isListItem LKeywordT       = True
-isListItem _               = False
-
-isNewline :: LToken -> Bool
-isNewline LNewline = True
-isNewline _        = False
-
 getIdentifier :: LToken -> String
 getIdentifier (LIdentifier name) = name
-getIdentifier _                  = error "Expected identifier"
+getIdentifier _                  = errorWithoutStackTrace "Expected identifier"
 
 handleParseError :: ParseErrorBundle [LToken] Void -> String
 handleParseError bundle =
   let errors = bundleErrors bundle
-      errorList     = Data.List.NonEmpty.toList errors
+      formattedErrors = map formatError (Data.List.NonEmpty.toList errors)
-      formattedErrs = map showError errorList
+  in unlines ("Parse error(s) encountered:" : formattedErrors)
-  in unlines ("Parse error(s) encountered:" : formattedErrs)
-
-showError :: ParseError [LToken] Void -> String
-showError (TrivialError offset (Just (Tokens tokenStream)) expected) =
-  "Parse error at offset " ++ show offset
-    ++ ": unexpected token " ++ show tokenStream
-    ++ ", expected one of " ++ show (Set.toList expected)
-showError (FancyError offset fancy) =
-  "Parse error at offset " ++ show offset ++ ":\n "
-    ++ unlines (map show (Set.toList fancy))
-showError (TrivialError offset Nothing expected) =
-  "Parse error at offset " ++ show offset
-    ++ ": expected one of " ++ show (Set.toList expected)
 
+formatError :: ParseError [LToken] Void -> String
+formatError (TrivialError offset unexpected expected) =
+  let unexpectedMsg = case unexpected of
+        Just x  -> "unexpected token " ++ show x
+        Nothing -> "unexpected end of input"
+      expectedMsg = if null expected
+        then ""
+        else "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"

tricu.cabal

@@ -18,6 +18,7 @@ executable tricu
       src
   default-extensions:
       DeriveDataTypeable
+      LambdaCase
       MultiWayIf
       OverloadedStrings
   ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
@@ -44,6 +45,7 @@ test-suite tricu-tests
   hs-source-dirs:      test, src
   default-extensions:
       DeriveDataTypeable
+      LambdaCase
       MultiWayIf
       OverloadedStrings
   build-depends: