Ditch attoparsec for megaparsec: great error msgs

Author: omnibs

nri-redis/nri-redis.cabal

@@ -65,12 +65,12 @@ library
   build-depends:
       aeson >=1.4.6.0 && <2.2
     , async >=2.2.2 && <2.3
-    , attoparsec >=0.13.0.0 && <0.15
     , base >=4.12.0.0 && <4.18
     , bytestring >=0.10.8.2 && <0.12
     , conduit >=1.3.0 && <1.4
     , containers >=0.6.0.1 && <0.7
     , hedis >=0.14.0 && <0.16
+    , megaparsec >=9.2.2 && <9.3
     , modern-uri >=0.3.1.0 && <0.4
     , nri-env-parser >=0.1.0.0 && <0.2
     , nri-observability >=0.1.0 && <0.2
@@ -90,6 +90,7 @@ test-suite tests
   other-modules:
       Helpers
       Spec.Redis
+      Spec.Redis.Script
       Spec.Settings
       NonEmptyDict
       Redis
@@ -127,12 +128,12 @@ test-suite tests
   build-depends:
       aeson >=1.4.6.0 && <2.2
     , async >=2.2.2 && <2.3
-    , attoparsec >=0.13.0.0 && <0.15
     , base >=4.12.0.0 && <4.18
     , bytestring >=0.10.8.2 && <0.12
     , conduit >=1.3.0 && <1.4
     , containers >=0.6.0.1 && <0.7
     , hedis >=0.14.0 && <0.16
+    , megaparsec >=9.2.2 && <9.3
     , modern-uri >=0.3.1.0 && <0.4
     , nri-env-parser >=0.1.0.0 && <0.2
     , nri-observability >=0.1.0 && <0.2

nri-redis/package.yaml

@@ -16,13 +16,13 @@ extra-doc-files:
 dependencies:
   - aeson >= 1.4.6.0 && < 2.2
   - async >=2.2.2 && <2.3
-  - attoparsec >= 0.13.0.0 && < 0.15
   - base >= 4.12.0.0 && < 4.18
   - bytestring >= 0.10.8.2 && < 0.12
   - conduit >= 1.3.0 && < 1.4
   - containers >= 0.6.0.1 && < 0.7
   # hedis 14 introduces redis-cluster support
   - hedis >= 0.14.0 && < 0.16
+  - megaparsec >= 9.2.2 && < 9.3
   - modern-uri >= 0.3.1.0 && < 0.4
   - nri-env-parser >= 0.1.0.0 && < 0.2
   - nri-observability >= 0.1.0 && < 0.2

nri-redis/src/Redis/Script.hs

@@ -1,12 +1,13 @@
-module Redis.Script (Script (..), script, evalString, mapKeys, keysTouchedByScript, paramNames, paramValues, parser, ScriptExpression (..)) where
+module Redis.Script (Script (..), script, evalString, mapKeys, keysTouchedByScript, paramNames, paramValues, parser, Tokens (..)) where
 
-import Data.Attoparsec.Text (Parser, char,choice, inClass, many1', skipSpace, takeWhile1, (<?>), endOfInput)
-import qualified Data.Attoparsec.Text as Attoparsec
+import Data.Void (Void)
 import qualified Language.Haskell.TH as TH
 import qualified Language.Haskell.TH.Quote as QQ
--- import Control.Applicative ((<|>))
 import qualified Set
-import Prelude (pure)
+import Text.Megaparsec ((<|>))
+import qualified Text.Megaparsec as P
+import qualified Text.Megaparsec.Char as PC
+import Prelude (notElem, pure, (<*))
 import qualified Prelude
 
 data Script result = Script
@@ -41,37 +42,36 @@ script =
 qqScript :: Prelude.String -> TH.ExpQ
 qqScript scriptWithVars = do
   let str = Text.fromList scriptWithVars
-  let _expr = Attoparsec.parseOnly parser str
+  let _expr = P.parse parser "" str
   -- let parsedScript = case expr str of
   --       Left err -> Prelude.error <| "Failed to parse script: " ++ err
   --       Right parsed ->
   -- [|parsedScript|]
   Debug.todo "qqScript"
 
-data ScriptExpression
+data Tokens
   = ScriptText Text
   | ScriptVariable Text
   deriving (Show, Eq)
 
-parser :: Parser (List ScriptExpression)
+type Parser = P.Parsec Void Text
+
+parser :: Parser (List Tokens)
 parser = do
-  result <- many1' (choice [parseText, parseVariable]) <?> "Expected at least one"
-  endOfInput
-  pure <| result
+  (P.some (parseText <|> parseVariable))
+    <* P.eof
 
-parseText :: Parser ScriptExpression
+parseText :: Parser Tokens
 parseText = do
-  text <- takeWhile1 ('$' /=) <?> "Expected text"
+  text <- P.takeWhile1P (Just "some plain text") (/= '$')
   pure <| ScriptText text
 
-parseVariable :: Parser ScriptExpression
+parseVariable :: Parser Tokens
 parseVariable = do
-  _ <- char '$' <?> "Expected '$'"
-  _ <- char '{' <?> "Expected '{'"
-  skipSpace <?> "Expected space after '{'"
-  name <- (takeWhile1 (not << inClass "${}"))
-    <?> "No '$', '{' or '}' allowed in interpolated expression. Note: I'm a simple parser and I don't support records inside ${}."
-  _ <- char '}' <?> "Expected '}' after: ${" ++ Text.toList name
+  _ <- PC.string "${"
+  _ <- PC.space
+  name <- P.takeWhile1P (Just "anything but '$', '{' or '}' (no records, sorry)") (\t -> t `notElem` ['$', '{', '}'])
+  _ <- PC.char '}'
   pure <| ScriptVariable <| Text.trim name
 
 -- | EVAL script numkeys [key [key ...]] [arg [arg ...]]

nri-redis/test/Spec/Redis/Script.hs

@@ -1,10 +1,10 @@
 module Spec.Redis.Script (tests) where
 
-import qualified Data.Attoparsec.Text as Attoparsec
 import Data.Either (Either (..))
 import qualified Expect
 import Redis.Script
 import qualified Test
+import qualified Text.Megaparsec as P
 
 tests :: Test.Test
 tests =
@@ -16,19 +16,19 @@ tests =
 parserTests :: List Test.Test
 parserTests =
   [ Test.test "1 word" <| \_ ->
-      (Attoparsec.parseOnly parser "Jabuticaba")
+      P.runParser parser "" "Jabuticaba"
         |> Expect.equal (Right [ScriptText "Jabuticaba"]),
     Test.test "3 words" <| \_ ->
-      (Attoparsec.parseOnly parser "Picolé de Jabuticaba")
+      P.runParser parser "" "Picolé de Jabuticaba"
         |> Expect.equal (Right [ScriptText "Picolé de Jabuticaba"]),
     Test.test "1 value" <| \_ ->
-      (Attoparsec.parseOnly parser "${value}")
+      P.runParser parser "" "${value}"
         |> Expect.equal (Right [ScriptVariable "value"]),
     Test.test "function application" <| \_ ->
-      (Attoparsec.parseOnly parser "${func arg1 arg2}")
+      P.runParser parser "" "${func arg1 arg2}"
         |> Expect.equal (Right [ScriptVariable "func arg1 arg2"]),
     Test.test "text and variables" <| \_ ->
-      (Attoparsec.parseOnly parser "some text ${value} some more text ${ anotherValue }")
+      P.runParser parser "" "some text ${value} some more text ${ anotherValue }"
         |> Expect.equal
           ( Right
               [ ScriptText "some text ",
@@ -37,13 +37,73 @@ parserTests =
                 ScriptVariable "anotherValue"
               ]
           ),
-    Test.only <| Test.test "ERROR: nested ${}" <| \_ -> do
-      (Attoparsec.parseOnly parser "asdasd ${ ${ value } }")
-        |> Expect.equal (Left "Expected at least one > No '$', '{' or '}' allowed in interpolated expression. Note: I'm a simple parser and I don't support records inside ${}.: Failed reading: takeWhile1"),
-    Test.test "ERROR: misplaced ${ inside ${}" <| \_ -> do
-      (Attoparsec.parseOnly parser "${ v$alue }")
-        |> Expect.equal (Left "Expected at least one > Expected '}' after: ${v > '}': Failed reading: satisfy"),
+    Test.test "ERROR: empty" <| \_ -> do
+      P.runParser parser "" ""
+        |> mapLeft P.errorBundlePretty
+        |> Expect.equal
+          ( Left
+              "1:1:\n\
+              \  |\n\
+              \1 | <empty line>\n\
+              \  | ^\n\
+              \unexpected end of input\n\
+              \expecting \"${\" or some plain text\n\
+              \"
+          ),
+    Test.test "ERROR: empty variable" <| \_ -> do
+      P.runParser parser "" "${}"
+        |> mapLeft P.errorBundlePretty
+        |> Expect.equal
+          ( Left
+                "1:3:\n\
+                \  |\n\
+                \1 | ${}\n\
+                \  |   ^\n\
+                \unexpected '}'\n\
+                \expecting anything but '$', '{' or '}' (no records, sorry) or white space\n\
+                \"
+          ),
+    Test.test "ERROR: nested ${}" <| \_ -> do
+      P.runParser parser "" "asdasd ${ ${ value } }"
+        |> mapLeft P.errorBundlePretty
+        |> Expect.equal
+          ( Left
+              "1:11:\n\
+              \  |\n\
+              \1 | asdasd ${ ${ value } }\n\
+              \  |           ^\n\
+              \unexpected '$'\n\
+              \expecting anything but '$', '{' or '}' (no records, sorry) or white space\n\
+              \"
+          ),
     Test.test "ERROR: misplaced ${ inside ${}" <| \_ -> do
-      (Attoparsec.parseOnly parser "${ v{alue }")
-        |> Expect.equal (Left "Expected at least one > Expected '}' after: ${v > '}': Failed reading: satisfy")
+      P.runParser parser "" "${ v$alue }"
+        |> mapLeft P.errorBundlePretty
+        |> Expect.equal
+          ( Left
+              "1:5:\n\
+              \  |\n\
+              \1 | ${ v$alue }\n\
+              \  |     ^\n\
+              \unexpected '$'\n\
+              \expecting '}' or anything but '$', '{' or '}' (no records, sorry)\n\
+              \"
+          ),
+    Test.test "ERROR: misplaced { inside ${}" <| \_ -> do
+      P.runParser parser "" "${ v{alue }"
+        |> mapLeft P.errorBundlePretty
+        |> Expect.equal
+          ( Left
+              "1:5:\n\
+              \  |\n\
+              \1 | ${ v{alue }\n\
+              \  |     ^\n\
+              \unexpected '{'\n\
+              \expecting '}' or anything but '$', '{' or '}' (no records, sorry)\n\
+              \"
+          )
   ]
+
+mapLeft :: (a -> c) -> Either a b -> Either c b
+mapLeft f (Left a) = Left (f a)
+mapLeft _ (Right b) = Right b