From 6db055b21944cddbdc8354bd0e5b464c002f0f18 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Filip=20Grali=C5=84ski?= Date: Thu, 20 Sep 2018 15:25:00 +0200 Subject: [PATCH] Add a mini-language for defining condition on submissions and their variants --- Data/SubmissionConditions.hs | 183 ++++++++++++++++++++++++++ gonito.cabal | 2 + test/Data/SubmissionConditionsSpec.hs | 62 +++++++++ 3 files changed, 247 insertions(+) create mode 100644 Data/SubmissionConditions.hs create mode 100644 test/Data/SubmissionConditionsSpec.hs diff --git a/Data/SubmissionConditions.hs b/Data/SubmissionConditions.hs new file mode 100644 index 0000000..b33846a --- /dev/null +++ b/Data/SubmissionConditions.hs @@ -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 diff --git a/gonito.cabal b/gonito.cabal index 19c5134..b22cc28 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -53,6 +53,7 @@ library Handler.ExtraPoints Handler.Runner Handler.Dashboard + Data.SubmissionConditions if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT @@ -142,6 +143,7 @@ library , attoparsec , random-strings , wai + , megaparsec executable gonito if flag(library-only) diff --git a/test/Data/SubmissionConditionsSpec.hs b/test/Data/SubmissionConditionsSpec.hs new file mode 100644 index 0000000..2da2bcd --- /dev/null +++ b/test/Data/SubmissionConditionsSpec.hs @@ -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