demos/LevelOrderTraversal.tri

@@ -57,12 +57,7 @@ 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") [("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 = 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
+exampleOne

src/Parser.hs

@@ -12,8 +12,7 @@ import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
 import qualified Data.Set as Set
 
 data PState = PState
-  { parenDepth  :: Int
-  , bracketDepth :: Int
+  { depth :: Int
   } deriving (Show)
 
 type ParserM = StateT PState (Parsec Void [LToken])
@@ -25,33 +24,24 @@ satisfyM f = do
   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 LOpenParen  st = st { depth = depth st + 1 }
+updateDepth LCloseParen st = st { depth = max 0 (depth st - 1) }
 updateDepth _           st = st
 
 topLevelNewline :: ParserM ()
 topLevelNewline = do
   st <- get
-  if parenDepth st == 0 && bracketDepth st == 0
+  if depth st == 0
     then void (satisfyM (== LNewline))
-    else fail "Top-level exit in nested context (paren or bracket)"
+    else fail "Top-level exit in paren context"
 
 parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
 parseProgram tokens =
-  runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
+  runParser (evalStateT parseProgramM (PState 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)
+  runParser (evalStateT (scnParserM *> parseExpressionM <* eofM) (PState 0)) "" tokens
 
 parseTricu :: String -> [TricuAST]
 parseTricu input =
@@ -59,7 +49,7 @@ parseTricu input =
     [] -> []
     toks ->
       case parseProgram toks of
-        Left err   -> errorWithoutStackTrace (handleParseError err)
+        Left err   -> error (handleParseError err)
         Right asts -> asts
 
 parseSingle :: String -> TricuAST
@@ -68,7 +58,7 @@ parseSingle input =
     [] -> SEmpty
     toks ->
       case parseSingleExpr toks of
-        Left err -> errorWithoutStackTrace (handleParseError err)
+        Left err -> error (handleParseError err)
         Right ast -> ast
 
 parseProgramM :: ParserM [TricuAST]
@@ -85,13 +75,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 depth st > 0 && isNewline t
+    then void (satisfyM isNewline)
+    else
+      fail "In paren context or no space token" <|> empty
 
 eofM :: ParserM ()
 eofM = lift eof
@@ -109,27 +96,18 @@ parseExpressionM = choice
 
 parseFunctionM :: ParserM TricuAST
 parseFunctionM = do
-  LIdentifier name <- satisfyM $ \case
-    LIdentifier _ -> True
-    _             -> False
-  args <- many $ satisfyM $ \case
-    LIdentifier _ -> True
-    _             -> False
+  LIdentifier name <- satisfyM isIdentifier
+  args <- many (satisfyM isIdentifier)
   _    <- 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 $ \case
-      LIdentifier _ -> True
-      _             -> False
-    rest  <- many $ satisfyM $ \case
-      LIdentifier _ -> True
-      _             -> False
+  param   <- satisfyM isIdentifier
+  rest    <- many (satisfyM isIdentifier)
   _       <- satisfyM (== LColon)
   scnParserM
   body    <- parseLambdaExpressionM
@@ -180,10 +158,8 @@ parseAtomicBaseM = choice
 
 parseTreeLeafM :: ParserM TricuAST
 parseTreeLeafM = do
-  _ <- satisfyM $ \case
-    LKeywordT -> True
-    _         -> False
-  notFollowedBy $ lift $ satisfy (== LAssign)
+  _ <- satisfyM isKeywordT
+  notFollowedBy (lift (satisfy (== LAssign)))
   pure TLeaf
 
 parseTreeTermM :: ParserM TricuAST
@@ -225,10 +201,7 @@ parseLiteralM = choice
 parseListLiteralM :: ParserM TricuAST
 parseListLiteralM = do
   _        <- satisfyM (== LOpenBracket)
-  elements <- many $ do
-    scnParserM
-    parseListItemM
-  scnParserM
+  elements <- many parseListItemM
   _        <- satisfyM (== LCloseBracket)
   pure (SList elements)
 
@@ -248,10 +221,7 @@ parseGroupedItemM = do
 
 parseSingleItemM :: ParserM TricuAST
 parseSingleItemM = do
-  token <- satisfyM $ \case
-    LIdentifier _ -> True
-    LKeywordT     -> True
-    _             -> False
+  token <- satisfyM isListItem
   case token of
     LIdentifier name -> pure (SVar name)
     LKeywordT        -> pure TLeaf
@@ -259,46 +229,71 @@ parseSingleItemM = do
 
 parseVarM :: ParserM TricuAST
 parseVarM = do
-  LIdentifier name <- satisfyM $ \case
-    LIdentifier _ -> True
-    _             -> False
+  LIdentifier name <- satisfyM isIdentifier
   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
+  LIntegerLiteral value <- satisfyM isIntegerLiteral
   pure (SInt value)
 
 parseStrLiteralM :: ParserM TricuAST
 parseStrLiteralM = do
-  LStringLiteral value <- satisfyM $ \case 
-    LStringLiteral _ -> True
-    _ -> False
+  LStringLiteral value <- satisfyM isStringLiteral
   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 _                  = errorWithoutStackTrace "Expected identifier"
+getIdentifier _                  = error "Expected identifier"
 
 handleParseError :: ParseErrorBundle [LToken] Void -> String
 handleParseError bundle =
   let errors        = bundleErrors bundle
-      formattedErrors = map formatError (Data.List.NonEmpty.toList errors)
-  in unlines ("Parse error(s) encountered:" : formattedErrors)
+      errorList     = Data.List.NonEmpty.toList errors
+      formattedErrs = map showError errorList
+  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,7 +18,6 @@ executable tricu
       src
   default-extensions:
       DeriveDataTypeable
-      LambdaCase
       MultiWayIf
       OverloadedStrings
   ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
@@ -45,7 +44,6 @@ test-suite tricu-tests
   hs-source-dirs:      test, src
   default-extensions:
       DeriveDataTypeable
-      LambdaCase
       MultiWayIf
       OverloadedStrings
   build-depends: