diff --git a/nri-redis/nri-redis.cabal b/nri-redis/nri-redis.cabal index a154f497..94143c87 100644 --- a/nri-redis/nri-redis.cabal +++ b/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 diff --git a/nri-redis/package.yaml b/nri-redis/package.yaml index cf3ed2ab..d2016831 100644 --- a/nri-redis/package.yaml +++ b/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 diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index c4362fdb..c06ece28 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/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 ...]] diff --git a/nri-redis/test/Spec/Redis/Script.hs b/nri-redis/test/Spec/Redis/Script.hs index 35f509fe..84994809 100644 --- a/nri-redis/test/Spec/Redis/Script.hs +++ b/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 | \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