mirror of
https://github.com/logos-storage/zk-benchmarks.git
synced 2026-01-11 18:23:08 +00:00
362 lines
9.5 KiB
Haskell
362 lines
9.5 KiB
Haskell
|
|
-- | Parsing the @bench.cfg@ files.
|
|
--
|
|
-- Example config file:
|
|
--
|
|
-- > name: "Poseidon2 Groth16 benchmarks"
|
|
-- > timeout: 300
|
|
-- > rerunFrom: build
|
|
-- > params:
|
|
-- > [ PROVER: [ snarkjs, rapidsnark ]
|
|
-- > , INPUT_SIZE: [ 256, 512, 1024, 2048 ]
|
|
-- > , WHICH: [ hash_sponge, hash_sponge_rate2, hash_merkle ]
|
|
-- > ]
|
|
-- > tags: Groth16, Poseidon2, $PROVER
|
|
--
|
|
|
|
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
module Parser where
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
import Data.Char
|
|
import Data.Maybe
|
|
-- import Data.List
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import Control.Monad
|
|
import Control.Applicative
|
|
|
|
import "parsec1" Text.ParserCombinators.Parsec
|
|
|
|
import Types
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
exampleConfigString :: String
|
|
exampleConfigString = unlines
|
|
[ "name: \"Poseidon2 Groth16 benchmarks\" "
|
|
, "timeout: 300"
|
|
, "rerunFrom: build "
|
|
, "params:"
|
|
, " [ PROVER: [ snarkjs, \"rapidsnark\" ]"
|
|
, " , INPUT_SIZE: [ 256, 512, 1024, "
|
|
, " 2048 ]"
|
|
, " , WHICH: [ hash_sponge, hash_sponge_rate2, hash_merkle ]"
|
|
, " ]"
|
|
, "tags: Groth16, Poseidon2, $PROVER, \"stringy tag\" "
|
|
, "comment: "
|
|
, " foo"
|
|
, " bar"
|
|
, " baz"
|
|
, "author: \"X. Middlename Y.\""
|
|
]
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
data CfgField
|
|
= Field_name
|
|
| Field_timeout
|
|
| Field_rerun
|
|
| Field_params
|
|
| Field_tags
|
|
| Field_author
|
|
| Field_comment
|
|
deriving Show
|
|
|
|
recognizeField :: String -> Maybe CfgField
|
|
recognizeField s = case filter (/='_') (map toLower s) of
|
|
"name" -> Just Field_name
|
|
"timeout" -> Just Field_timeout
|
|
"rerun" -> Just Field_rerun
|
|
"rerunfrom" -> Just Field_rerun
|
|
"params" -> Just Field_params
|
|
"tags" -> Just Field_tags
|
|
"author" -> Just Field_author
|
|
"comment" -> Just Field_comment
|
|
"comments" -> Just Field_comment
|
|
_ -> Nothing
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
naturalP :: Parser Integer
|
|
naturalP = do
|
|
xs <- many1 digit
|
|
return (read xs)
|
|
|
|
numberP :: Parser Integer
|
|
numberP = naturalP
|
|
|
|
identP :: Parser String
|
|
identP = do
|
|
c <- letter <|> oneOf "_"
|
|
cs <- many (alphaNum <|> oneOf "_")
|
|
return (c:cs)
|
|
|
|
singleWordP :: Parser String
|
|
singleWordP = do
|
|
c <- letter <|> oneOf "_"
|
|
cs <- many (alphaNum <|> oneOf "_-")
|
|
return (c:cs)
|
|
|
|
quotedStringP :: Parser String
|
|
quotedStringP = do
|
|
char '"'
|
|
xs <- many (noneOf "\"\n\r")
|
|
char '"'
|
|
return xs
|
|
|
|
tagP :: Parser Tag
|
|
tagP = (FixedTag <$> quotedStringP) <|> nakedTagP
|
|
|
|
nakedTagP :: Parser Tag
|
|
nakedTagP = do
|
|
c <- letter <|> oneOf "_$"
|
|
cs <- many (alphaNum <|> oneOf "_-+!?@#%^/&*=:")
|
|
return $ case c of
|
|
'$' -> ParamTag cs
|
|
_ -> FixedTag (c:cs)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | A list delimited by @[@ and @]@
|
|
listP :: Parser a -> Parser [a]
|
|
listP userP = (char '[' >> spaces >> start) where
|
|
finish = do
|
|
char ']'
|
|
return []
|
|
start = finish <|> do
|
|
x <- userP ; spaces
|
|
xs <- continue
|
|
return (x:xs)
|
|
continue = finish <|> do
|
|
char ',' ; spaces
|
|
x <- userP ; spaces
|
|
xs <- continue
|
|
return (x:xs)
|
|
|
|
-- | A list without delimiters
|
|
nakedListP :: Parser a -> Parser [a]
|
|
nakedListP userP = start where
|
|
start = do
|
|
x <- userP ; onlySpaces
|
|
xs <- continue
|
|
return (x:xs)
|
|
continue = (newlineP >> return []) <|> do
|
|
char ',' ; spaces
|
|
x <- userP ; onlySpaces
|
|
xs <- continue
|
|
return (x:xs)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
postEOF :: Parser a -> Parser a
|
|
postEOF userP = do
|
|
x <- userP
|
|
spaces
|
|
eof
|
|
return x
|
|
|
|
postNewline :: Parser a -> Parser a
|
|
postNewline userP = do
|
|
x <- userP
|
|
onlySpaces
|
|
newlineP
|
|
return x
|
|
|
|
postSpaces :: Parser a -> Parser a
|
|
postSpaces userP = do
|
|
x <- userP
|
|
spaces
|
|
return x
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
onlySpaces :: Parser ()
|
|
onlySpaces = void $ many (oneOf " \t")
|
|
|
|
newlineP :: Parser ()
|
|
newlineP = try (void $ string "\r\n")
|
|
<|> (void $ oneOf "\r\n")
|
|
<|> eof
|
|
|
|
singleLineP :: Parser String
|
|
singleLineP = quotedStringP <|> many (noneOf "\r\n")
|
|
|
|
multiLineP_ :: Parser String
|
|
multiLineP_ = unlines <$> multiLineP
|
|
|
|
multiLineP :: Parser [String]
|
|
multiLineP = loop where
|
|
loop = do
|
|
l <- tillEndOfLine
|
|
ls <- indented
|
|
return (l:ls)
|
|
indented = do
|
|
newlineP
|
|
continue <|> return []
|
|
continue = do
|
|
_ <- many1 (oneOf " \t")
|
|
loop
|
|
tillEndOfLine = many (noneOf "\r\n")
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
phaseP :: Parser Phase
|
|
phaseP = do
|
|
s <- identP
|
|
case (map toLower s) of
|
|
"build" -> return Build
|
|
"setup" -> return Setup
|
|
"witness" -> return Witness
|
|
"run" -> return Run
|
|
_ -> fail ("unknown phase " ++ quote s)
|
|
|
|
tagsP :: Parser [Tag]
|
|
tagsP = listP tagP <|> nakedListP tagP
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
simpleValP :: Parser Value
|
|
simpleValP = (StringV <$> (quotedStringP <|> singleWordP))
|
|
<|> (NumberV <$> numberP)
|
|
|
|
type ParamRange = KeyVal String [Value]
|
|
|
|
paramP :: Parser ParamRange
|
|
paramP = do
|
|
key <- identP ; spaces
|
|
char ':' ; spaces
|
|
vals <- listP simpleValP
|
|
return (MkKeyVal key vals)
|
|
|
|
paramsP :: Parser [ParamRange]
|
|
paramsP = listP paramP
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
data KeyVal k a
|
|
= MkKeyVal k a
|
|
deriving (Eq,Show)
|
|
|
|
data Value
|
|
= StringV String
|
|
| NumberV Integer
|
|
| PhaseV Phase
|
|
| TagV Tag
|
|
| ListV [Value]
|
|
| KeyValV (KeyVal String Value)
|
|
deriving (Eq,Show)
|
|
|
|
paramRangeToValue :: ParamRange -> Value
|
|
paramRangeToValue (MkKeyVal key list) = KeyValV (MkKeyVal key (ListV list))
|
|
|
|
type Entry = KeyVal CfgField Value
|
|
|
|
entryP :: Parser Entry
|
|
entryP =
|
|
postSpaces $ do
|
|
key <- identP ; spaces
|
|
char ':' ; spaces
|
|
(fld,val) <- case recognizeField key of
|
|
Nothing -> fail ("invalid configuration key " ++ quote key)
|
|
Just fld -> do
|
|
rhs <- fieldValueP fld
|
|
return (fld,rhs)
|
|
return (MkKeyVal fld val)
|
|
where
|
|
|
|
fieldValueP :: CfgField -> Parser Value
|
|
fieldValueP fld = case fld of
|
|
Field_name -> StringV <$> singleLineP
|
|
Field_timeout -> NumberV <$> numberP
|
|
Field_rerun -> PhaseV <$> phaseP
|
|
Field_params -> ListV <$> (map paramRangeToValue <$> paramsP)
|
|
Field_tags -> ListV <$> (map TagV <$> tagsP )
|
|
Field_author -> StringV <$> singleLineP
|
|
Field_comment -> StringV <$> multiLineP_
|
|
|
|
configP :: Parser [Entry]
|
|
configP = spaces >> postEOF (many1 entryP)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
fromTagV :: Value -> Maybe Tag
|
|
fromTagV (TagV tag) = Just tag
|
|
fromTagV _ = Nothing
|
|
|
|
fromSimpleV :: Value -> Maybe String
|
|
fromSimpleV (StringV s) = Just s
|
|
fromSimpleV (NumberV x) = Just (show x)
|
|
fromSimpleV _ = Nothing
|
|
|
|
fromParamV :: Value -> Maybe (String,[String])
|
|
fromParamV (KeyValV kv) = case kv of
|
|
MkKeyVal s (ListV list) -> Just (s, mapMaybe fromSimpleV list)
|
|
MkKeyVal s value -> (\y -> (s,[y])) <$> fromSimpleV value
|
|
fromParamV _ = Nothing
|
|
|
|
-- fromParamsV :: Value -> Maybe [(String,[String])]
|
|
-- fromParamsV (ListV list) = Just (catMaybes $ fromParamV list)
|
|
-- fromParamsV _ = Nothing
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
type ErrM a = Either String a
|
|
|
|
err :: String -> ErrM a
|
|
err = Left
|
|
|
|
entriesToBenchmark :: [Entry] -> ErrM Benchmark
|
|
entriesToBenchmark = entriesToBenchmark' dummyBenchmark
|
|
|
|
entriesToBenchmark' :: Benchmark -> [Entry] -> ErrM Benchmark
|
|
entriesToBenchmark' oldBenchmark = foldM handle oldBenchmark where
|
|
|
|
handle :: Benchmark -> KeyVal CfgField Value -> ErrM Benchmark
|
|
handle old (MkKeyVal key val) = case key of
|
|
|
|
Field_name -> case val of
|
|
StringV s -> return $ old { _benchName = Just s }
|
|
_ -> err "unexpected type for field `name`"
|
|
|
|
Field_timeout -> case val of
|
|
NumberV t -> return $ old { _benchTimeout = MkSeconds (fromInteger t) }
|
|
_ -> err "unexpected type for field `timeout`"
|
|
|
|
Field_rerun -> case val of
|
|
PhaseV p -> return $ old { _benchRerunFrom = p }
|
|
_ -> err "unexpected type for field `rerun_from`"
|
|
|
|
Field_params -> case val of
|
|
ListV list -> return $ old { _benchParams = Map.fromList (mapMaybe fromParamV list) }
|
|
_ -> err "unexpected type for field `rparams`"
|
|
|
|
Field_tags -> case val of
|
|
ListV list -> return $ old { _benchTags = mapMaybe fromTagV list }
|
|
_ -> err "unexpected type for field `tags`"
|
|
|
|
Field_author -> case val of
|
|
StringV s -> return $ old { _benchAuthor = Just s }
|
|
_ -> err "unexpected type for field `author`"
|
|
|
|
Field_comment -> case val of
|
|
StringV s -> return $ old { _benchComment = Just s }
|
|
_ -> err "unexpected type for field `comment`"
|
|
|
|
_ -> err $ "unknown field " ++ show key
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
parseConfig :: FilePath -> String -> ErrM Benchmark
|
|
parseConfig fpath str = case parse configP fpath str of
|
|
Left err -> Left (show err)
|
|
Right entries -> entriesToBenchmark entries
|
|
|
|
parseConfig_ :: String -> ErrM Benchmark
|
|
parseConfig_ = parseConfig "<config>"
|
|
|
|
--------------------------------------------------------------------------------
|