Add a mini-language for defining condition on submissions and their variants

This commit is contained in:
Filip Graliński 2018-09-20 15:25:00 +02:00
parent ef6e892680
commit 6db055b219
3 changed files with 247 additions and 0 deletions

View File

@ -0,0 +1,183 @@
-- | Handling simple submission conditions operating on tags and parameters
module Data.SubmissionConditions where
import Import hiding (many, try)
import Control.Monad (void)
import Data.Void
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Expr
import qualified Text.Megaparsec.Char.Lexer as L
import Data.Text as T hiding (empty)
import Text.Read (readMaybe)
import qualified Data.Map as Map
data VariantEntry = VariantEntry {
variantEntryTags :: [Tag],
variantEntryParams :: [Parameter]
}
type VariantEntryMap = Map Text Text
entryToMap :: VariantEntry -> VariantEntryMap
entryToMap entry = Map.fromList ((Import.map (\t -> (tagName t, "TAG")) tags)
++ (Import.map (\p -> (parameterName p, parameterValue p)) params))
where tags = variantEntryTags entry
params = variantEntryParams entry
data SubmissionCondition =
Simple SubmissionSimpleCondition
| Neg SubmissionCondition
| BBinary BBinaryOp SubmissionCondition SubmissionCondition
deriving (Show, Eq)
data BBinaryOp = And | Or
deriving (Show, Eq)
data SubmissionSimpleCondition =
Existence ValueHolder
| SBinary Atom SBinaryOp Atom
deriving (Show, Eq)
data SBinaryOp = Equal | NotEqual | Less | Greater | LessOrEqual | GreaterOrEqual
deriving (Show, Eq)
data Atom =
ReadFrom ValueHolder
| IntegerAtom Integer
| DoubleAtom Double
| StringAtom Text
deriving (Show, Eq)
data ValueHolder = ValueHolder Text
deriving (Show, Eq)
type Parser = Parsec Void Text
spaceConsumer = L.space space1 empty empty
symbol :: Text -> Parser Text
symbol = L.symbol spaceConsumer
lexeme :: Parser a -> Parser a
lexeme = L.lexeme spaceConsumer
parens :: Parser a -> Parser a
parens = between (symbol "(") (symbol ")")
conditionP :: Parser SubmissionCondition
conditionP = makeExprParser bTerm bOperators
bTerm =
(parens conditionP)
<|>
(Simple <$> simpleConditionP)
bOperators :: [[Operator Parser SubmissionCondition]]
bOperators =
[ [Prefix (Neg <$ symbol "!") ]
, [InfixL (BBinary And <$ symbol "&&")
, InfixL (BBinary Or <$ symbol "||") ]
]
simpleConditionP :: Parser SubmissionSimpleCondition
simpleConditionP =
(try (SBinary <$> valP <*> sopP <*> valP))
<|>
(Existence <$> valueHolderP)
sopP :: Parser SBinaryOp
sopP =
(try (symbol "==" *> pure Equal))
<|>
symbol "=" *> pure Equal
<|>
symbol "!=" *> pure NotEqual
<|>
symbol "/=" *> pure NotEqual
<|>
(try (symbol "<>" *> pure NotEqual))
<|>
(try (symbol "<=" *> pure LessOrEqual))
<|>
(try (symbol ">=" *> pure GreaterOrEqual))
<|>
symbol "<" *> pure Less
<|>
symbol ">" *> pure Greater
valP :: Parser Atom
valP =
(ReadFrom <$> valueHolderP)
<|>
(try $ lexeme $ DoubleAtom <$> L.signed spaceConsumer L.float)
<|>
(lexeme $ IntegerAtom <$> L.signed spaceConsumer L.decimal)
<|>
(StringAtom <$> literalP)
literalP :: Parser Text
literalP = quotedP '"' <|> quotedP '\''
quotedP :: Char -> Parser Text
quotedP q = lexeme (T.pack <$> ((char q) *> (many $ notChar q) <* (char q)))
valueHolderP :: Parser ValueHolder
valueHolderP = lexeme $ ValueHolder <$> T.pack <$> ((:) <$> letterChar <*> many (alphaNumChar <|> char '-'))
parseCondition :: Text -> Maybe (SubmissionCondition)
parseCondition = parseMaybe (spaceConsumer *> conditionP)
checkCondition :: Maybe SubmissionCondition -> VariantEntry -> Bool
checkCondition mCondition = checkCondition' mCondition . entryToMap
checkCondition' :: Maybe SubmissionCondition -> VariantEntryMap -> Bool
checkCondition' Nothing _ = False
checkCondition' (Just condition) entry = checkCondition'' condition entry
checkCondition'' :: SubmissionCondition -> VariantEntryMap -> Bool
checkCondition'' (Simple simpleCondition) entry = checkSimpleCondition simpleCondition entry
checkCondition'' (Neg condition) entry = not (checkCondition'' (condition) entry)
checkCondition'' (BBinary op condA condB) entry =
(rfy op) (checkCondition'' condA entry) (checkCondition'' condB entry)
where rfy And = (&&)
rfy Or = (||)
data Val = IntegerVal Integer | DoubleVal Double | StringVal Text | NoVal
checkSimpleCondition :: SubmissionSimpleCondition -> VariantEntryMap -> Bool
checkSimpleCondition (Existence (ValueHolder holder)) entry = Map.member holder entry
checkSimpleCondition (SBinary valA op valB) entry = rop (getValue valA entry) (getValue valB entry)
where rop NoVal _ = False -- no value always brings false value
rop _ NoVal = False -- therefore (x < y) is not equal to !(x >= y)
rop (IntegerVal x) (IntegerVal y) = (rfy op) x y
rop (IntegerVal x) (DoubleVal y) = (rfy op) (fromIntegral x) y
rop (DoubleVal x) (IntegerVal y) = (rfy op) x (fromIntegral y)
rop (DoubleVal x) (DoubleVal y) = (rfy op) x y
rop (StringVal x) (StringVal y) = (rfy op) x y
rop _ _ = False
rfy :: Ord a => SBinaryOp -> a -> a -> Bool
rfy Equal = (==)
rfy NotEqual = (/=)
rfy Less = (<)
rfy Greater = (>)
rfy LessOrEqual = (<=)
rfy GreaterOrEqual = (>=)
getValue :: Atom -> VariantEntryMap -> Val
getValue (IntegerAtom i) _ = IntegerVal i
getValue (DoubleAtom d) _ = DoubleVal d
getValue (StringAtom t) _ = StringVal t
getValue (ReadFrom (ValueHolder holder)) entry = case Map.lookup holder entry of
Just v ->
let s = T.unpack v
in case readMaybe s of
Just i -> IntegerVal i
Nothing -> case readMaybe s of
Just d -> DoubleVal d
Nothing -> StringVal v
Nothing -> NoVal

View File

@ -53,6 +53,7 @@ library
Handler.ExtraPoints Handler.ExtraPoints
Handler.Runner Handler.Runner
Handler.Dashboard Handler.Dashboard
Data.SubmissionConditions
if flag(dev) || flag(library-only) if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT cpp-options: -DDEVELOPMENT
@ -142,6 +143,7 @@ library
, attoparsec , attoparsec
, random-strings , random-strings
, wai , wai
, megaparsec
executable gonito executable gonito
if flag(library-only) if flag(library-only)

View File

@ -0,0 +1,62 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.SubmissionConditionsSpec (spec) where
import Test.Hspec
import Import
import Database.Persist.Sql (toSqlKey)
import Data.SubmissionConditions
spec :: Spec
spec = do
describe "simple conditions" $ do
it "just param" $ do
parseCondition "nb-foo" `shouldBe` (Just $ Simple $ Existence $ ValueHolder "nb-foo")
it "with operators" $ do
parseCondition "baz<8.5" `shouldBe` (Just $ Simple $ SBinary (ReadFrom $ ValueHolder "baz")
Less
(DoubleAtom 8.5))
parseCondition "baz<=10" `shouldBe` (Just $ Simple $ SBinary (ReadFrom $ ValueHolder "baz")
LessOrEqual
(IntegerAtom 10))
it "with spaces" $ do
parseCondition "foo > 3.2" `shouldBe` (Just $ Simple $ SBinary (ReadFrom $ ValueHolder "foo")
Greater
(DoubleAtom 3.2))
parseCondition "foo = -3" `shouldBe` (Just $ Simple $ SBinary (ReadFrom $ ValueHolder "foo")
Equal
(IntegerAtom (-3)))
parseCondition " baz == ' a b c' " `shouldBe` (Just $ Simple $ SBinary (ReadFrom $ ValueHolder "baz")
Equal
(StringAtom " a b c"))
it "boolean conditions" $ do
parseCondition "!nb-epochs && x <> 5|| y='a'" `shouldBe` (
Just $ BBinary Or (BBinary And (Neg (Simple $ Existence $ ValueHolder "nb-epochs"))
(Simple $ SBinary (ReadFrom $ ValueHolder "x")
NotEqual
(IntegerAtom 5)))
(Simple $ SBinary (ReadFrom $ ValueHolder "y")
Equal
(StringAtom "a")))
it "with parens" $ do
parseCondition "foo && (x != 10 || !y)" `shouldBe` (
Just $ BBinary And (Simple $ Existence $ ValueHolder "foo")
(BBinary Or (Simple $ SBinary (ReadFrom $ ValueHolder "x")
NotEqual
(IntegerAtom 10))
(Neg $ Simple $ Existence $ ValueHolder "y")))
describe "running conditions" $ do
it "simple condition" $ do
let fakeKey :: Key Variant = toSqlKey 1
let sampleEntry = VariantEntry {
variantEntryTags = [Tag "foo" Nothing, Tag "neural-network" (Just "description")],
variantEntryParams = [Parameter fakeKey "z" "80", Parameter fakeKey "learning-rate" "0.0001", Parameter fakeKey "type" "supervised"]
}
checkCondition (parseCondition "z < 100") sampleEntry `shouldBe` True
checkCondition (parseCondition "other <= 3.14") sampleEntry `shouldBe` False
checkCondition (parseCondition "other > 3.14") sampleEntry `shouldBe` False
checkCondition (parseCondition "learning-rate < 0.03 && (type == 'unsupervised' || foo) && !stupid") sampleEntry `shouldBe` True
checkCondition (parseCondition "z<>80||!foo") sampleEntry `shouldBe` False