Merge pull request #811 from tsoding/801

(#801) Finish off the fuzzer fiesta

Author: rexim

HyperNerd.cabal

@@ -152,27 +152,6 @@ executable HyperNerd
   -- Base language which the package is written in.
   default-language:    Haskell2010
 
-executable Fuzzy
-  ghc-options:         -threaded
-                       -Wall
-                       -fwarn-incomplete-patterns
-                       -fwarn-incomplete-uni-patterns
-
-  main-is:             FuzzyMain.hs
-
-  other-modules:       Bot.Expr
-                     , HyperNerd.Parser
-
-  build-depends:       base
-                     , text
-                     , random
-                     , aeson
-                     , bytestring
-
-  hs-source-dirs:      src
-
-  default-language:    Haskell2010
-
 executable Markov
   ghc-options:         -threaded
                        -Wall
@@ -243,6 +222,7 @@ test-suite HyperNerdTest
                      , Bot.PollTest
                      , Bot.Friday
                      , Bot.FridayTest
+                     , Bot.ExprTest
                      , Bot.GitHub
                      , Data.Maybe.Extra
                      , Data.Time.Extra

src/Bot/Expr.hs

@@ -13,7 +13,6 @@ data Expr
   = TextExpr T.Text
   | FunCallExpr T.Text
                 [Expr]
-  | VarExpr T.Text
   deriving (Eq, Show)
 
 type NameTable = ()
@@ -28,38 +27,46 @@ stringLiteral = do
   _ <- charP '"'
   return $ TextExpr value
 
-funcallarg :: Parser Expr
-funcallarg = funcall <|> var <|> stringLiteral
+funCallArg :: Parser Expr
+funCallArg = funCall <|> stringLiteral
 
-funcall :: Parser Expr
-funcall = do
-  _ <- charP '%'
-  name <- symbol
-  _ <- whitespaces >> charP '(' >> whitespaces
+funCallArgList :: Parser [Expr]
+funCallArgList = do
+  _ <- charP '(' <* whitespaces
   args <-
-    sepBy funcallarg (whitespaces >> charP ',' >> whitespaces) <|> return []
+    sepBy funCallArg (whitespaces >> charP ',' >> whitespaces) <|> return []
   _ <- whitespaces >> charP ')'
+  return args
+
+funCall :: Parser Expr
+funCall = do
+  name <- charP '%' *> symbol
+  args <- funCallArgList <|> return []
   return $ FunCallExpr name args
 
 whitespaces :: Parser T.Text
 whitespaces = takeWhileP isSpace
 
-var :: Parser Expr
-var = charP '%' *> (VarExpr <$> symbol) <* charP '%'
-
 textBlock :: Parser Expr
 textBlock =
   Parser $ \input ->
     case T.uncons input of
       Nothing -> Left EOF
-      Just ('%', _) -> Left (SyntaxError "Text block does not start with %")
+      Just ('%', input') ->
+        return $ fmap (TextExpr . T.cons '%') $ swap $ T.span (/= '%') input'
       _ -> return $ fmap TextExpr $ swap $ T.span (/= '%') input
 
 expr :: Parser Expr
-expr = funcall <|> var <|> textBlock
+expr = funCall <|> textBlock
 
 exprs :: Parser [Expr]
-exprs = many expr
+exprs = normalizeExprs <$> many expr
+  where
+    normalizeExprs :: [Expr] -> [Expr]
+    normalizeExprs [] = []
+    normalizeExprs (TextExpr t1:TextExpr t2:rest) =
+      normalizeExprs (TextExpr (t1 <> t2) : rest)
+    normalizeExprs (x:rest) = x : normalizeExprs rest
 -- TODO(#600): interpretExprs is not implemented
 -- interpretExprs :: NameTable -> [Expr] -> Effect T.Text
 -- interpretExprs = undefined

src/FuzzyMain.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bot.ExprTest where
+
+import Bot.Expr
+import qualified Data.Text as T
+import HyperNerd.Parser
+import Test.HUnit
+
+spec :: Test
+spec =
+  TestLabel "Parsing Custom Command DSL" $
+  TestList $
+  map
+    (\(input, expected) ->
+       TestCase $
+       assertEqual
+         ("Cannot parse `" <> input <> "` as Custom Command DSL")
+         expected
+         (runParser exprs $ T.pack input))
+    [ ("Hello world", Right ("", [TextExpr "Hello world"]))
+    , ("%Hello world", Right ("", [FunCallExpr "Hello" [], TextExpr " world"]))
+    , ("%Helloworld", Right ("", [FunCallExpr "Helloworld" []]))
+    , ("%Hello()world", Right ("", [FunCallExpr "Hello" [], TextExpr "world"]))
+    , ( "%Hello()%world"
+      , Right ("", [FunCallExpr "Hello" [], FunCallExpr "world" []]))
+    , ( "%Hello ()%world"
+      , Right
+          ("", [FunCallExpr "Hello" [], TextExpr " ()", FunCallExpr "world" []]))
+    , ( "% Hello ()%world"
+      , Right ("", [TextExpr "% Hello ()", FunCallExpr "world" []]))
+    , ("%%%%%%", Right ("", [TextExpr "%%%%%%"]))
+    ]

test/Bot/ExprTest.hs

@@ -1,5 +1,7 @@
 module Main where
 
+import qualified Bot.ExprTest
+
 {- Test Suite Conventions
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 1. If the module we are testing is called `Foo.Bar.Baz`,
@@ -30,6 +32,7 @@ main = do
       , Bot.PollTest.spec
       , Bot.TwitchTest.spec
       , Bot.FridayTest.spec
+      , Bot.ExprTest.spec
       , CommandTest.spec
       , Sqlite.EntityPersistenceTest.spec
       , Data.Time.ExtraTest.spec