diff --git a/HyperNerd.cabal b/HyperNerd.cabal index f6bec78..8eadac3 100644 --- a/HyperNerd.cabal +++ b/HyperNerd.cabal @@ -151,6 +151,25 @@ 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 + + build-depends: base + , text + , random + , aeson + + hs-source-dirs: src + + default-language: Haskell2010 + executable Markov ghc-options: -threaded -Wall diff --git a/src/Bot/Expr.hs b/src/Bot/Expr.hs index 034bd1f..6f8f0bb 100644 --- a/src/Bot/Expr.hs +++ b/src/Bot/Expr.hs @@ -7,7 +7,6 @@ import Control.Applicative import Data.Char import qualified Data.Text as T import Data.Tuple -import Effect data Expr = TextExpr T.Text @@ -65,14 +64,16 @@ sepBy element sep = do args <- many (sep >> element) return (arg : args) +funcallarg :: Parser Expr +funcallarg = funcall <|> var <|> stringLiteral + funcall :: Parser Expr funcall = do _ <- charP '%' >> whitespaces name <- symbol _ <- whitespaces >> charP '(' >> whitespaces args <- - sepBy (funcall <|> var <|> stringLiteral) (whitespaces >> charP ',') <|> - return [] + sepBy funcallarg (whitespaces >> charP ',' >> whitespaces) <|> return [] _ <- whitespaces >> charP ')' return $ FunCallExpr name args @@ -117,7 +118,6 @@ expr = funcall <|> var <|> textBlock exprs :: Parser [Expr] exprs = many expr - -- TODO(#600): interpretExprs is not implemented -interpretExprs :: NameTable -> [Expr] -> Effect T.Text -interpretExprs = undefined +-- interpretExprs :: NameTable -> [Expr] -> Effect T.Text +-- interpretExprs = undefined diff --git a/src/FuzzyMain.hs b/src/FuzzyMain.hs new file mode 100644 index 0000000..e12bf4a --- /dev/null +++ b/src/FuzzyMain.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Bot.Expr +import Control.Monad +import Data.Aeson +import Data.Aeson.Types +import Data.Char +import Data.List +import qualified Data.Text as T +import System.Environment +import System.Random +import Text.Printf + +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 + +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 + +normalizeExprs :: [Expr] -> [Expr] +normalizeExprs [] = [] +normalizeExprs (TextExpr t1:TextExpr t2:rest) = + normalizeExprs (TextExpr (t1 <> t2) : rest) +normalizeExprs (_:rest) = normalizeExprs rest + +randomExprs :: FuzzParams -> IO [Expr] +randomExprs params = do + n <- randomRIO $ fpExprsRange params + replicateM n (randomExpr params) + +fuzzIteration :: FuzzParams -> IO Bool +fuzzIteration params = do + es <- normalizeExprs <$> randomExprs params + let es' = runParser exprs $ unparseExprs es + when (Right ("", es) /= es') $ do + print es + print es' + error "test" + return (Right ("", es) == es') + +fuzz :: FuzzParams -> IO () +fuzz params = do + report <- replicateM (fpFuzzCount params) (fuzzIteration params) + printf "Failures: %d\n" $ length $ filter not report + printf "Successes: %d\n" $ length $ filter id report + +mainWithArgs :: [String] -> IO () +mainWithArgs (fuzzParamsPath:_) = readFuzzParams fuzzParamsPath >>= fuzz +mainWithArgs _ = error "Usage: Fuzz " + +main :: IO () +main = getArgs >>= mainWithArgs diff --git a/test/Bot/ExprTest.hs b/test/Bot/ExprTest.hs index 4ab75fc..9ba3a06 100644 --- a/test/Bot/ExprTest.hs +++ b/test/Bot/ExprTest.hs @@ -52,6 +52,7 @@ exprsTest = , TextExpr " baz ()" ])) , ("%f(%x)", Right ("", [FunCallExpr "f" [VarExpr "x"]])) + , ("%f(%x, %y)", Right ("", [FunCallExpr "f" [VarExpr "x", VarExpr "y"]])) , ( "\"hello %x world\"" , Right ("", [TextExpr "\"hello ", VarExpr "x", TextExpr " world\""])) ]