zk-benchmarks/framework/src/Parser.hs

-- | 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>"

--------------------------------------------------------------------------------