Skip to content

Commit bb7bd2c

Browse files
reximrexim
authored
Merge pull request #810 from tsoding/801
(#801) Improve Bot.Expr Fuzzer
2 parents 36f2605 + 419be1b commit bb7bd2c

File tree

6 files changed

+173
-147
lines changed

6 files changed

+173
-147
lines changed

‎HyperNerd.cabal‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -92,6 +92,7 @@ executable HyperNerd
9292
, Entity
9393
, HyperNerd.Comonad
9494
, HyperNerd.Functor
95+
, HyperNerd.Parser
9596
, Markov
9697
, Property
9798
, Reaction
@@ -160,11 +161,13 @@ executable Fuzzy
160161
main-is: FuzzyMain.hs
161162

162163
other-modules: Bot.Expr
164+
, HyperNerd.Parser
163165

164166
build-depends: base
165167
, text
166168
, random
167169
, aeson
170+
, bytestring
168171

169172
hs-source-dirs: src
170173

@@ -263,7 +266,7 @@ test-suite HyperNerdTest
263266
, Data.Either.Extra
264267
, Free
265268
, Bot.Expr
266-
, Bot.ExprTest
269+
, HyperNerd.Parser
267270

268271
other-extensions: OverloadedStrings
269272

‎src/Bot/Expr.hs‎

Lines changed: 4 additions & 62 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,3 @@
1-
{-# LANGUAGE DeriveFunctor #-}
21
{-# LANGUAGE OverloadedStrings #-}
32

43
module Bot.Expr where
@@ -8,6 +7,8 @@ import Data.Char
87
import qualified Data.Text as T
98
import Data.Tuple
109

10+
import HyperNerd.Parser
11+
1112
data Expr
1213
= TextExpr T.Text
1314
| FunCallExpr T.Text
@@ -17,37 +18,6 @@ data Expr
1718

1819
type NameTable = ()
1920

20-
data ParserStop
21-
= EOF
22-
| SyntaxError T.Text
23-
deriving (Eq, Show)
24-
25-
newtype Parser a = Parser
26-
{ runParser :: T.Text -> Either ParserStop (T.Text, a)
27-
} deriving (Functor)
28-
29-
instance Applicative Parser where
30-
pure x = Parser $ \text -> Right (text, x)
31-
(Parser f) <*> (Parser x) =
32-
Parser $ \input1 -> do
33-
(input2, f') <- f input1
34-
(input3, x') <- x input2
35-
return (input3, f' x')
36-
37-
instance Monad Parser where
38-
Parser a >>= f =
39-
Parser $ \input1 -> do
40-
(input2, b) <- a input1
41-
runParser (f b) input2
42-
43-
instance Alternative Parser where
44-
empty = Parser $ const $ Left EOF
45-
(Parser p1) <|> (Parser p2) =
46-
Parser $ \input ->
47-
case (p1 input, p2 input) of
48-
(Left _, x) -> x
49-
(x, _) -> x
50-
5121
symbol :: Parser T.Text
5222
symbol = notNull "Symbol name cannot be empty" $ takeWhileP isAlphaNum
5323

@@ -58,52 +28,24 @@ stringLiteral = do
5828
_ <- charP '"'
5929
return $ TextExpr value
6030

61-
sepBy :: Parser a -> Parser b -> Parser [a]
62-
sepBy element sep = do
63-
arg <- element
64-
args <- many (sep >> element)
65-
return (arg : args)
66-
6731
funcallarg :: Parser Expr
6832
funcallarg = funcall <|> var <|> stringLiteral
6933

7034
funcall :: Parser Expr
7135
funcall = do
72-
_ <- charP '%' >> whitespaces
36+
_ <- charP '%'
7337
name <- symbol
7438
_ <- whitespaces >> charP '(' >> whitespaces
7539
args <-
7640
sepBy funcallarg (whitespaces >> charP ',' >> whitespaces) <|> return []
7741
_ <- whitespaces >> charP ')'
7842
return $ FunCallExpr name args
7943

80-
charP :: Char -> Parser Char
81-
charP a =
82-
Parser $ \input ->
83-
case T.uncons input of
84-
Just (b, rest)
85-
| a == b -> Right (rest, b)
86-
_ -> Left $ SyntaxError ("Expected `" <> T.pack [a] <> "`")
87-
88-
takeWhileP :: (Char -> Bool) -> Parser T.Text
89-
takeWhileP p = Parser $ \input -> return $ swap $ T.span p input
90-
91-
syntaxError :: T.Text -> Parser a
92-
syntaxError message = Parser $ \_ -> Left $ SyntaxError message
93-
94-
notNull :: T.Text -> Parser T.Text -> Parser T.Text
95-
notNull message next =
96-
next >>=
97-
(\value ->
98-
if T.null value
99-
then syntaxError message
100-
else return value)
101-
10244
whitespaces :: Parser T.Text
10345
whitespaces = takeWhileP isSpace
10446

10547
var :: Parser Expr
106-
var = charP '%' >> whitespaces >> (VarExpr <$> symbol)
48+
var = charP '%' *> (VarExpr <$> symbol) <* charP '%'
10749

10850
textBlock :: Parser Expr
10951
textBlock =

‎src/FuzzyMain.hs‎

Lines changed: 97 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -6,13 +6,69 @@ import Bot.Expr
66
import Control.Monad
77
import Data.Aeson
88
import Data.Aeson.Types
9+
import qualified Data.ByteString.Lazy as BS
910
import Data.Char
11+
import Data.Foldable
1012
import Data.List
1113
import qualified Data.Text as T
14+
import HyperNerd.Parser
1215
import System.Environment
1316
import System.Random
1417
import Text.Printf
1518

19+
data FuzzStat = FuzzStat
20+
{ fsTextCount :: Int
21+
, fsMaxTextLen :: Int
22+
, fsMinTextLen :: Int
23+
, fsVarCount :: Int
24+
, fsFunCount :: Int
25+
, fsMaxFunArgsCount :: Int
26+
, fsMinFunArgsCount :: Int
27+
} deriving (Show, Eq)
28+
29+
instance Semigroup FuzzStat where
30+
s1 <> s2 =
31+
FuzzStat
32+
{ fsTextCount = fsTextCount s1 + fsTextCount s2
33+
, fsMaxTextLen = fsMaxTextLen s1 `max` fsMaxTextLen s2
34+
, fsMinTextLen = fsMinTextLen s1 `min` fsMinTextLen s2
35+
, fsVarCount = fsVarCount s1 + fsVarCount s2
36+
, fsFunCount = fsFunCount s1 + fsFunCount s2
37+
, fsMaxFunArgsCount = fsMaxFunArgsCount s1 `max` fsMaxFunArgsCount s2
38+
, fsMinFunArgsCount = fsMinFunArgsCount s1 `min` fsMinFunArgsCount s2
39+
}
40+
41+
instance Monoid FuzzStat where
42+
mempty =
43+
FuzzStat
44+
{ fsTextCount = 0
45+
, fsMaxTextLen = minBound
46+
, fsMinTextLen = maxBound
47+
, fsVarCount = 0
48+
, fsFunCount = 0
49+
, fsMaxFunArgsCount = minBound
50+
, fsMinFunArgsCount = maxBound
51+
}
52+
53+
statOfExprs :: [Expr] -> FuzzStat
54+
statOfExprs = foldMap statOfExpr
55+
56+
statOfExpr :: Expr -> FuzzStat
57+
statOfExpr (TextExpr text) =
58+
mempty
59+
{ fsTextCount = 1
60+
, fsMinTextLen = T.length text
61+
, fsMaxTextLen = T.length text
62+
}
63+
statOfExpr (VarExpr _) = mempty {fsVarCount = 1}
64+
statOfExpr (FunCallExpr _ args) =
65+
mempty
66+
{ fsFunCount = 1
67+
, fsMaxFunArgsCount = length args
68+
, fsMinFunArgsCount = length args
69+
} <>
70+
statOfExprs args
71+
1672
data FuzzParams = FuzzParams
1773
{ fpFuzzCount :: Int
1874
, fpExprsRange :: (Int, Int)
@@ -42,6 +98,9 @@ instance FromJSON FuzzParams where
4298
readFuzzParams :: FilePath -> IO FuzzParams
4399
readFuzzParams = fmap (either error id) . eitherDecodeFileStrict
44100

101+
saveFuzzParams :: FuzzParams -> FilePath -> IO ()
102+
saveFuzzParams params filePath = BS.writeFile filePath $ encode params
103+
45104
defaultFuzzParams :: FuzzParams
46105
defaultFuzzParams =
47106
FuzzParams
@@ -61,7 +120,7 @@ unparseFunCallArgs = T.concat . intersperse "," . map unparseFunCallArg
61120

62121
unparseExpr :: Expr -> T.Text
63122
unparseExpr (TextExpr text) = text
64-
unparseExpr (VarExpr name) = "%" <> name
123+
unparseExpr (VarExpr name) = "%" <> name <> "%"
65124
unparseExpr (FunCallExpr name args) =
66125
"%" <> name <> "(" <> unparseFunCallArgs args <> ")"
67126

@@ -104,36 +163,54 @@ randomExpr params = do
104163
1 -> randomVarExpr params
105164
_ -> randomFunCallExpr params
106165

107-
normalizeExprs :: [Expr] -> [Expr]
108-
normalizeExprs [] = []
109-
normalizeExprs (TextExpr t1:TextExpr t2:rest) =
110-
normalizeExprs (TextExpr (t1 <> t2) : rest)
111-
normalizeExprs (_:rest) = normalizeExprs rest
112-
113166
randomExprs :: FuzzParams -> IO [Expr]
114-
randomExprs params = do
115-
n <- randomRIO $ fpExprsRange params
116-
replicateM n (randomExpr params)
117-
118-
fuzzIteration :: FuzzParams -> IO Bool
167+
randomExprs params = randomRIO (fpExprsRange params) >>= f []
168+
where
169+
normalizeExprs :: [Expr] -> [Expr]
170+
normalizeExprs [] = []
171+
normalizeExprs (TextExpr t1:TextExpr t2:rest) =
172+
normalizeExprs (TextExpr (t1 <> t2) : rest)
173+
normalizeExprs (x:rest) = x : normalizeExprs rest
174+
f :: [Expr] -> Int -> IO [Expr]
175+
f es n
176+
| m >= n = return es
177+
| otherwise = do
178+
es' <- replicateM (n - m) (randomExpr params)
179+
f (normalizeExprs (es ++ es')) n
180+
where
181+
m = length es
182+
183+
fuzzIteration :: FuzzParams -> IO FuzzStat
119184
fuzzIteration params = do
120-
es <- normalizeExprs <$> randomExprs params
185+
es <- randomExprs params
121186
let es' = runParser exprs $ unparseExprs es
122187
when (Right ("", es) /= es') $ do
123188
print es
124189
print es'
125-
error "test"
126-
return (Right ("", es) == es')
190+
error "Failed"
191+
return $ statOfExprs es
127192

128193
fuzz :: FuzzParams -> IO ()
129194
fuzz params = do
130-
report <- replicateM (fpFuzzCount params) (fuzzIteration params)
131-
printf "Failures: %d\n" $ length $ filter not report
132-
printf "Successes: %d\n" $ length $ filter id report
195+
stats <- replicateM (fpFuzzCount params) (fuzzIteration params)
196+
print $ fold stats
133197

134198
mainWithArgs :: [String] -> IO ()
135-
mainWithArgs (fuzzParamsPath:_) = readFuzzParams fuzzParamsPath >>= fuzz
136-
mainWithArgs _ = error "Usage: Fuzz <fuzz.json>"
199+
mainWithArgs ("genconf":configFilePath:_) = do
200+
saveFuzzParams defaultFuzzParams configFilePath
201+
printf "Generated default configuration at %s" configFilePath
202+
mainWithArgs ("runconf":fuzzParamsPath:_) =
203+
readFuzzParams fuzzParamsPath >>= fuzz
204+
mainWithArgs ("genexpr":configFilePath:_) = do
205+
putStrLn "Generating expression:"
206+
params <- readFuzzParams configFilePath
207+
randomExprs params >>= print
208+
mainWithArgs _ =
209+
error
210+
"Usage: \n\
211+
\ Fuzz genconf <fuzz.json>\n\
212+
\ Fuzz runconf <fuzz.json>\n\
213+
\ Fuzz genexpr <fuzz.json>"
137214

138215
main :: IO ()
139216
main = getArgs >>= mainWithArgs

‎src/HyperNerd/Parser.hs‎

Lines changed: 67 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,67 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE DeriveFunctor #-}
3+
4+
module HyperNerd.Parser where
5+
6+
import Control.Applicative
7+
import qualified Data.Text as T
8+
import Data.Tuple
9+
10+
data ParserStop
11+
= EOF
12+
| SyntaxError T.Text
13+
deriving (Eq, Show)
14+
15+
newtype Parser a = Parser
16+
{ runParser :: T.Text -> Either ParserStop (T.Text, a)
17+
} deriving (Functor)
18+
19+
instance Applicative Parser where
20+
pure x = Parser $ \text -> Right (text, x)
21+
(Parser f) <*> (Parser x) =
22+
Parser $ \input1 -> do
23+
(input2, f') <- f input1
24+
(input3, x') <- x input2
25+
return (input3, f' x')
26+
27+
instance Monad Parser where
28+
Parser a >>= f =
29+
Parser $ \input1 -> do
30+
(input2, b) <- a input1
31+
runParser (f b) input2
32+
33+
instance Alternative Parser where
34+
empty = Parser $ const $ Left EOF
35+
(Parser p1) <|> (Parser p2) =
36+
Parser $ \input ->
37+
case (p1 input, p2 input) of
38+
(Left _, x) -> x
39+
(x, _) -> x
40+
41+
sepBy :: Parser a -> Parser b -> Parser [a]
42+
sepBy element sep = do
43+
arg <- element
44+
args <- many (sep >> element)
45+
return (arg : args)
46+
47+
takeWhileP :: (Char -> Bool) -> Parser T.Text
48+
takeWhileP p = Parser $ \input -> return $ swap $ T.span p input
49+
50+
charP :: Char -> Parser Char
51+
charP a =
52+
Parser $ \input ->
53+
case T.uncons input of
54+
Just (b, rest)
55+
| a == b -> Right (rest, b)
56+
_ -> Left $ SyntaxError ("Expected `" <> T.pack [a] <> "`")
57+
58+
notNull :: T.Text -> Parser T.Text -> Parser T.Text
59+
notNull message next =
60+
next >>=
61+
(\value ->
62+
if T.null value
63+
then syntaxError message
64+
else return value)
65+
66+
syntaxError :: T.Text -> Parser a
67+
syntaxError message = Parser $ \_ -> Left $ SyntaxError message

0 commit comments

Comments
 (0)