From db50c5c2c0a1c4e117651266961e798b906597ae Mon Sep 17 00:00:00 2001 From: rexim Date: Fri, 1 Nov 2019 01:07:11 +0700 Subject: [PATCH 1/4] (#801) Simplify the syntax of Custom Command DSL There are no variable anymore. Only function calls. --- HyperNerd.cabal | 2 ++ src/Bot/Expr.hs | 38 +++++++++++++++++++++++--------------- test/Bot/ExprTest.hs | 33 +++++++++++++++++++++++++++++++++ test/Test.hs | 2 ++ 4 files changed, 60 insertions(+), 15 deletions(-) create mode 100644 test/Bot/ExprTest.hs diff --git a/HyperNerd.cabal b/HyperNerd.cabal index 78ca243..0c0fc8b 100644 --- a/HyperNerd.cabal +++ b/HyperNerd.cabal @@ -168,6 +168,7 @@ executable Fuzzy , random , aeson , bytestring + , process hs-source-dirs: src @@ -243,6 +244,7 @@ test-suite HyperNerdTest , Bot.PollTest , Bot.Friday , Bot.FridayTest + , Bot.ExprTest , Bot.GitHub , Data.Maybe.Extra , Data.Time.Extra diff --git a/src/Bot/Expr.hs b/src/Bot/Expr.hs index b6f139e..c5f6a6b 100644 --- a/src/Bot/Expr.hs +++ b/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,47 @@ 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 diff --git a/test/Bot/ExprTest.hs b/test/Bot/ExprTest.hs new file mode 100644 index 0000000..2ffb444 --- /dev/null +++ b/test/Bot/ExprTest.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Bot.ExprTest where + +import Test.HUnit +import Bot.Expr +import HyperNerd.Parser +import qualified Data.Text as T + +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 "%%%%%%"])) + ] diff --git a/test/Test.hs b/test/Test.hs index 1e8738c..323dc3c 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -14,6 +14,7 @@ import qualified Bot.LinksTest import qualified Bot.LogTest import qualified Bot.PollTest import qualified Bot.TwitchTest +import qualified Bot.ExprTest import qualified CommandTest import qualified Data.Time.ExtraTest import qualified Sqlite.EntityPersistenceTest @@ -30,6 +31,7 @@ main = do , Bot.PollTest.spec , Bot.TwitchTest.spec , Bot.FridayTest.spec + , Bot.ExprTest.spec , CommandTest.spec , Sqlite.EntityPersistenceTest.spec , Data.Time.ExtraTest.spec From 3584be00202d6a1de5a2c277c7d353c80d0b4af9 Mon Sep 17 00:00:00 2001 From: rexim Date: Fri, 1 Nov 2019 01:14:39 +0700 Subject: [PATCH 2/4] (#801) Remove fuzzer --- HyperNerd.cabal | 22 ----- src/FuzzyMain.hs | 216 ----------------------------------------------- 2 files changed, 238 deletions(-) delete mode 100644 src/FuzzyMain.hs diff --git a/HyperNerd.cabal b/HyperNerd.cabal index 0c0fc8b..43019d3 100644 --- a/HyperNerd.cabal +++ b/HyperNerd.cabal @@ -152,28 +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 - , process - - hs-source-dirs: src - - default-language: Haskell2010 - executable Markov ghc-options: -threaded -Wall diff --git a/src/FuzzyMain.hs b/src/FuzzyMain.hs deleted file mode 100644 index 244cd63..0000000 --- a/src/FuzzyMain.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Bot.Expr -import Control.Monad -import Data.Aeson -import Data.Aeson.Types -import qualified Data.ByteString.Lazy as BS -import Data.Char -import Data.Foldable -import Data.List -import qualified Data.Text as T -import HyperNerd.Parser -import System.Environment -import System.Random -import Text.Printf - -data FuzzStat = FuzzStat - { fsTextCount :: Int - , fsMaxTextLen :: Int - , fsMinTextLen :: Int - , fsVarCount :: Int - , fsFunCount :: Int - , fsMaxFunArgsCount :: Int - , fsMinFunArgsCount :: Int - } deriving (Show, Eq) - -instance Semigroup FuzzStat where - s1 <> s2 = - FuzzStat - { fsTextCount = fsTextCount s1 + fsTextCount s2 - , fsMaxTextLen = fsMaxTextLen s1 `max` fsMaxTextLen s2 - , fsMinTextLen = fsMinTextLen s1 `min` fsMinTextLen s2 - , fsVarCount = fsVarCount s1 + fsVarCount s2 - , fsFunCount = fsFunCount s1 + fsFunCount s2 - , fsMaxFunArgsCount = fsMaxFunArgsCount s1 `max` fsMaxFunArgsCount s2 - , fsMinFunArgsCount = fsMinFunArgsCount s1 `min` fsMinFunArgsCount s2 - } - -instance Monoid FuzzStat where - mempty = - FuzzStat - { fsTextCount = 0 - , fsMaxTextLen = minBound - , fsMinTextLen = maxBound - , fsVarCount = 0 - , fsFunCount = 0 - , fsMaxFunArgsCount = minBound - , fsMinFunArgsCount = maxBound - } - -statOfExprs :: [Expr] -> FuzzStat -statOfExprs = foldMap statOfExpr - -statOfExpr :: Expr -> FuzzStat -statOfExpr (TextExpr text) = - mempty - { fsTextCount = 1 - , fsMinTextLen = T.length text - , fsMaxTextLen = T.length text - } -statOfExpr (VarExpr _) = mempty {fsVarCount = 1} -statOfExpr (FunCallExpr _ args) = - mempty - { fsFunCount = 1 - , fsMaxFunArgsCount = length args - , fsMinFunArgsCount = length args - } <> - statOfExprs args - -data FuzzParams = FuzzParams - { fpFuzzCount :: Int - , fpExprsRange :: (Int, Int) - , fpFunCallArgsRange :: (Int, Int) - , fpWordLenRange :: (Int, Int) - , fpTextWordCountRange :: (Int, Int) - } deriving (Show, Eq) - -instance ToJSON FuzzParams where - toJSON params = - object - [ "FuzzCount" .= fpFuzzCount params - , "ExprsRange" .= fpExprsRange params - , "FunCallArgsRange" .= fpFunCallArgsRange params - , "WordLenRange" .= fpWordLenRange params - , "TextWordCountRange" .= fpTextWordCountRange params - ] - -instance FromJSON FuzzParams where - parseJSON (Object params) = - FuzzParams <$> params .: "FuzzCount" <*> params .: "ExprsRange" <*> - params .: "FunCallArgsRange" <*> - params .: "WordLenRange" <*> - params .: "TextWordCountRange" - parseJSON invalid = typeMismatch "FuzzParams" invalid - -readFuzzParams :: FilePath -> IO FuzzParams -readFuzzParams = fmap (either error id) . eitherDecodeFileStrict - -saveFuzzParams :: FuzzParams -> FilePath -> IO () -saveFuzzParams params filePath = BS.writeFile filePath $ encode params - -defaultFuzzParams :: FuzzParams -defaultFuzzParams = - FuzzParams - { fpFuzzCount = 100 - , fpExprsRange = (1, 100) - , fpFunCallArgsRange = (0, 2) - , fpWordLenRange = (2, 10) - , fpTextWordCountRange = (3, 5) - } - -unparseFunCallArg :: Expr -> T.Text -unparseFunCallArg (TextExpr text) = "\"" <> text <> "\"" -unparseFunCallArg e = unparseExpr e - -unparseFunCallArgs :: [Expr] -> T.Text -unparseFunCallArgs = T.concat . intersperse "," . map unparseFunCallArg - -unparseExpr :: Expr -> T.Text -unparseExpr (TextExpr text) = text -unparseExpr (VarExpr name) = "%" <> name <> "%" -unparseExpr (FunCallExpr name args) = - "%" <> name <> "(" <> unparseFunCallArgs args <> ")" - -unparseExprs :: [Expr] -> T.Text -unparseExprs = T.concat . map unparseExpr - -randomChar :: IO Char -randomChar = do - x <- randomRIO (0, ord 'z' - ord 'a') - return $ chr (x + ord 'a') - -randomText :: FuzzParams -> IO T.Text -randomText params = do - n <- randomRIO $ fpTextWordCountRange params - T.concat . intersperse " " <$> replicateM n (randomWord params) - -randomWord :: FuzzParams -> IO T.Text -randomWord params = do - n <- randomRIO $ fpWordLenRange params - T.pack <$> replicateM n randomChar - -randomTextExpr :: FuzzParams -> IO Expr -randomTextExpr params = TextExpr <$> randomText params - -randomVarExpr :: FuzzParams -> IO Expr -randomVarExpr params = VarExpr <$> randomWord params - -randomFunCallExpr :: FuzzParams -> IO Expr -randomFunCallExpr params = do - name <- randomWord params - n <- randomRIO $ fpFunCallArgsRange params - args <- replicateM n (randomExpr params) - return $ FunCallExpr name args - -randomExpr :: FuzzParams -> IO Expr -randomExpr params = do - n <- randomRIO (0, 2) :: IO Int - case n of - 0 -> randomTextExpr params - 1 -> randomVarExpr params - _ -> randomFunCallExpr params - -randomExprs :: FuzzParams -> IO [Expr] -randomExprs params = randomRIO (fpExprsRange params) >>= f [] - where - normalizeExprs :: [Expr] -> [Expr] - normalizeExprs [] = [] - normalizeExprs (TextExpr t1:TextExpr t2:rest) = - normalizeExprs (TextExpr (t1 <> t2) : rest) - normalizeExprs (x:rest) = x : normalizeExprs rest - f :: [Expr] -> Int -> IO [Expr] - f es n - | m >= n = return es - | otherwise = do - es' <- replicateM (n - m) (randomExpr params) - f (normalizeExprs (es ++ es')) n - where - m = length es - -fuzzIteration :: FuzzParams -> IO FuzzStat -fuzzIteration params = do - es <- randomExprs params - let es' = runParser exprs $ unparseExprs es - when (Right ("", es) /= es') $ do - print es - print es' - error "Failed" - return $ statOfExprs es - -fuzz :: FuzzParams -> IO () -fuzz params = do - stats <- replicateM (fpFuzzCount params) (fuzzIteration params) - print $ fold stats - -mainWithArgs :: [String] -> IO () -mainWithArgs ("genconf":configFilePath:_) = do - saveFuzzParams defaultFuzzParams configFilePath - printf "Generated default configuration at %s" configFilePath -mainWithArgs ("runconf":fuzzParamsPath:_) = - readFuzzParams fuzzParamsPath >>= fuzz -mainWithArgs ("genexpr":configFilePath:_) = do - putStrLn "Generating expression:" - params <- readFuzzParams configFilePath - randomExprs params >>= print -mainWithArgs _ = - error - "Usage: \n\ - \ Fuzz genconf \n\ - \ Fuzz runconf \n\ - \ Fuzz genexpr " - -main :: IO () -main = getArgs >>= mainWithArgs From e54f9b23ea55f1c3bf3f3582b0777ed1c17ebbf1 Mon Sep 17 00:00:00 2001 From: rexim Date: Fri, 1 Nov 2019 01:16:26 +0700 Subject: [PATCH 3/4] (#801) Fix hindent remarks --- src/Bot/Expr.hs | 1 - test/Bot/ExprTest.hs | 6 +++--- test/Test.hs | 2 +- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Bot/Expr.hs b/src/Bot/Expr.hs index c5f6a6b..27fb25e 100644 --- a/src/Bot/Expr.hs +++ b/src/Bot/Expr.hs @@ -67,7 +67,6 @@ exprs = normalizeExprs <$> many expr 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 diff --git a/test/Bot/ExprTest.hs b/test/Bot/ExprTest.hs index 2ffb444..7b6a770 100644 --- a/test/Bot/ExprTest.hs +++ b/test/Bot/ExprTest.hs @@ -1,11 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} + module Bot.ExprTest where -import Test.HUnit import Bot.Expr -import HyperNerd.Parser import qualified Data.Text as T +import HyperNerd.Parser +import Test.HUnit spec :: Test spec = diff --git a/test/Test.hs b/test/Test.hs index 323dc3c..68d444a 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,5 +1,6 @@ module Main where +import qualified Bot.ExprTest {- Test Suite Conventions ~~~~~~~~~~~~~~~~~~~~~~~~~ 1. If the module we are testing is called `Foo.Bar.Baz`, @@ -14,7 +15,6 @@ import qualified Bot.LinksTest import qualified Bot.LogTest import qualified Bot.PollTest import qualified Bot.TwitchTest -import qualified Bot.ExprTest import qualified CommandTest import qualified Data.Time.ExtraTest import qualified Sqlite.EntityPersistenceTest From 2c5d273e44d65454f6ea302bdfe471855d8eed59 Mon Sep 17 00:00:00 2001 From: rexim Date: Fri, 1 Nov 2019 01:31:09 +0700 Subject: [PATCH 4/4] (#801) Fix the build --- test/Test.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/Test.hs b/test/Test.hs index 68d444a..a4be5d0 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,6 +1,7 @@ module Main where import qualified Bot.ExprTest + {- Test Suite Conventions ~~~~~~~~~~~~~~~~~~~~~~~~~ 1. If the module we are testing is called `Foo.Bar.Baz`,