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

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

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)

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