diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for jsonlogic + +## 0.1.0.0 -- 2022-04-06 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2022 Marien Matser, Gerard van Schie, Jelle Teeuwissen + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,49 @@ +# Core + +The core JsonLogic evaluation package. +Allows for creating and adding custom operations to the evaluator in a pure and IO context. +See the example below for more information. + +## Example +```hs + +-- | The main function +-- Perform simple power function +main :: IO () +main = do + putStrLn "First number:" + first <- getLine + putStrLn "Second number:" + second <- getLine + print $ evaluate (read first) (read second) + +-- | Evaluate two numbers with pow operation using json logic. +-- The two numbers are placed into an data object and given to the evaluator with the following logic: +-- {"**":[{"var":"base"}, {"var":"exp"}]} +-- +-- >>> evaluate (read "3") (read "4") +-- Right 81.0 +evaluate :: Json -> Json -> Result Json +evaluate base expo = applyWithPow (read "{\"**\":[{\"var\":\"base\"}, {\"var\":\"exp\"}]}") (JsonObject [("base", base), ("exp", expo)]) + +-- | An evaluator that can evaluate operations with power (**). +applyWithPow :: Rule -> Data -> Result Json +applyWithPow = apply [powOperation] + +-- | The power operation. +-- Takes the power function and adds a name to it to create an operation. +powOperation :: Operation +powOperation = ("**", powFunction) + +-- | The power function. +-- Takes an subevaluator, function arguments (in this case just a list) and data to pass through. +-- 1. tries to evaluate the arguments to double values +-- (as they might be json logic evaluating to doubles, instead of direct numbers). +-- 2. if successful, returns the result of the power operation +powFunction :: Function Json +powFunction evaluator (JsonArray [base', expo']) vars = do + base <- evaluateDouble evaluator base' vars + expo <- evaluateDouble evaluator expo' vars + return $ JsonNumber $ base ** expo +powFunction _ _ _ = throw "Wrong number of arguments for **" +``` diff --git a/jsonlogic.cabal b/jsonlogic.cabal new file mode 100644 --- /dev/null +++ b/jsonlogic.cabal @@ -0,0 +1,114 @@ +cabal-version: 2.4 +name: jsonlogic +version: 0.1.0.0 + +synopsis: JsonLogic Evaluation +description: JsonLogic is a library for evaluating JSON logic. + It can be extended with additional operations +category: JSON + +bug-reports: https://github.com/JTeeuwissen/json-logic-haskell + +license: MIT +license-file: LICENSE +author: Marien Matser, Gerard van Schie, Jelle Teeuwissen +maintainer: jelleteeuwissen@hotmail.nl + +extra-source-files: + CHANGELOG.md + README.md + +flag error + description: Error on ghc warnings + manual: True + default: False + +library + exposed-modules: + JsonLogic.Json, + JsonLogic.IO.Evaluator, + JsonLogic.IO.Operation, + JsonLogic.IO.Type, + JsonLogic.Pure.Evaluator, + JsonLogic.Pure.Operation, + JsonLogic.Pure.Type + other-modules: + JsonLogic.IO.Mapping, + JsonLogic.IO.Operation.Misc, + JsonLogic.Pure.Mapping, + JsonLogic.Evaluator, + JsonLogic.Operation, + JsonLogic.Type, + JsonLogic.Operation.Array, + JsonLogic.Operation.Boolean, + JsonLogic.Operation.Data, + JsonLogic.Operation.Misc, + JsonLogic.Operation.Numeric, + JsonLogic.Operation.Primitive, + JsonLogic.Operation.String, + JsonLogic.Operation.Utils + + default-language: + Haskell2010 + ghc-options: + -Wall + hs-source-dirs: + src + build-depends: + base >= 4.14.3 && < 5, + containers >= 0.6.5 && < 0.7, + mtl >= 2.2.2 && < 2.3 + + if flag(error) + ghc-options: + -Werror + +Test-Suite jsonlogic-tests + main-is: + Test.hs + default-language: + Haskell2010 + ghc-options: + -Wall + type: + exitcode-stdio-1.0 + hs-source-dirs: + test + other-modules: + -- Generators + Generator.Data, + Generator.Generic, + Generator.Logic, + Generator.Utils, + -- Operation Tests + Operation.Array.TestArrayChecks, + Operation.Array.TestFilter, + Operation.Array.TestIn, + Operation.Array.TestMerge, + Operation.Array.TestReduce, + Operation.Boolean.TestEquality, + Operation.Boolean.TestIf, + Operation.Boolean.TestNegation, + Operation.Data.TestMissing, + Operation.Data.TestMissingSome, + Operation.Data.TestPreserve, + Operation.Data.TestVar, + Operation.String.TestCat, + Operation.String.TestSubstr, + TestJson, + TestStringify, + TestToNumber, + TestTruthy, + Utils + build-depends: + base >= 4.14.3.0, + jsonlogic, + tasty, + tasty-hunit >= 0.10.0.3, + tasty-hedgehog >= 1.2.0.0, + hedgehog >= 1.1.1, + containers + + if flag(error) + ghc-options: + -Werror diff --git a/src/JsonLogic/Evaluator.hs b/src/JsonLogic/Evaluator.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Evaluator.hs @@ -0,0 +1,28 @@ +-- | +-- Module : JsonLogic.Evaluator +-- Description : Internal JsonLogic evaluator +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Evaluator (apply) where + +import Control.Monad.Except +import Data.Map as M +import JsonLogic.Json +import JsonLogic.Type + +-- | Evaluate a rule +-- Evaluate an object or array, return other items. +apply :: Monad m => Operations m -> Rule -> Data -> Result m Json +apply ops o@(JsonObject rules) dat = case M.toList rules of + [(fName, fRule)] -> do + case M.lookup fName ops of + Nothing -> throwError $ UnrecognizedOperation fName + Just f -> f (apply ops) fRule dat + -- A rule should always contain only one field + _ -> return o -- throwError $ InvalidRule (M.keys rules) +apply ops (JsonArray rules) dat = do + result <- mapM (\rule -> apply ops rule dat) rules + return $ JsonArray result +apply _ x _ = return x diff --git a/src/JsonLogic/IO/Evaluator.hs b/src/JsonLogic/IO/Evaluator.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/IO/Evaluator.hs @@ -0,0 +1,31 @@ +-- | +-- Module : JsonLogic.IO.Evaluator +-- Description : JsonLogic IO evaluator +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.IO.Evaluator (apply, applyEmpty) where + +import qualified Data.Map as M +import qualified JsonLogic.Evaluator as E +import JsonLogic.IO.Mapping +import JsonLogic.IO.Operation (defaultOperations) +import JsonLogic.IO.Type +import JsonLogic.Json + +-- | Apply takes a list of operations, a rule and data. +-- And together with the default operations evaluates it. +-- +-- >>> apply [] (read "{\"cat\":[\"Hello, \", \"World!\"]}":: Json) JsonNull +-- Right "Hello, World!" +apply :: [Operation] -> Rule -> Data -> Result Json +apply ops = applyEmpty (ops ++ M.toList defaultOperations) + +-- | applyEmpty takes a list of operations, a rule and data. +-- And without the default operations evaluates it. +-- +-- >>> applyEmpty [] (read "{\"cat\":[\"Hello, \", \"World!\"]}":: Json) JsonNull +-- Left (UnrecognizedOperation {operationName = "cat"}) +applyEmpty :: [Operation] -> Rule -> Data -> Result Json +applyEmpty ops rule dat = toResult $ E.apply (M.map fromFunction $ M.fromList ops) rule dat diff --git a/src/JsonLogic/IO/Mapping.hs b/src/JsonLogic/IO/Mapping.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/IO/Mapping.hs @@ -0,0 +1,43 @@ +-- | +-- Module : JsonLogic.IO.Mapping +-- Description : Internal JsonLogic IO functions to map from exposed types to internal types and vice versa +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.IO.Mapping where + +import Control.Monad.Except +import qualified Data.Map as M +import JsonLogic.IO.Type +import qualified JsonLogic.Type as T + +toResult :: T.Result IO r -> Result r +toResult = runExceptT + +fromResult :: Result r -> T.Result IO r +fromResult = ExceptT + +toSubEvaluator :: T.SubEvaluator IO -> SubEvaluator +toSubEvaluator s r d = toResult $ s r d + +fromSubEvaluator :: SubEvaluator -> T.SubEvaluator IO +fromSubEvaluator s r d = fromResult $ s r d + +toFunction :: T.Function IO r -> Function r +toFunction f s r d = toResult $ f (fromSubEvaluator s) r d + +fromFunction :: Function r -> T.Function IO r +fromFunction f s r d = fromResult $ f (toSubEvaluator s) r d + +toOperation :: T.Operation IO -> Operation +toOperation (s, f) = (s, toFunction f) + +fromOperation :: Operation -> T.Operation IO +fromOperation (s, f) = (s, fromFunction f) + +toOperations :: T.Operations IO -> Operations +toOperations = M.map toFunction + +fromOperations :: Operations -> T.Operations IO +fromOperations = M.map fromFunction diff --git a/src/JsonLogic/IO/Operation.hs b/src/JsonLogic/IO/Operation.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/IO/Operation.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : JsonLogic.IO.Operation +-- Description : JsonLogic IO operations +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental + +{- ORMOLU_DISABLE -} +module JsonLogic.IO.Operation + ( defaultOperations, + arrayOperations, map, reduce, filter, all, none, some, merge, in', + booleanOperations, if', (==), (===), (!=), (!==), (!), (!!), and, or, + dataOperations, var, missing, missingSome, preserve, + miscOperations, trace, log, + numericOperations, (>), (>=), (<), (<=), max, min, sum, (+), (-), (*), (/), (%), + stringOperations, cat, substr, + evaluateDouble, evaluateInt, evaluateBool, evaluateArray, evaluateObject, evaluateString + ) +where +{- ORMOLU_ENABLE -} +import qualified Data.Map as M +import JsonLogic.IO.Mapping +import JsonLogic.IO.Operation.Misc (log, miscOperations, trace) +import JsonLogic.IO.Type +import JsonLogic.Json +import qualified JsonLogic.Operation as O +import qualified Prelude as P + +-- | A map of all the default operations. +defaultOperations :: Operations +defaultOperations = M.unions [arrayOperations, booleanOperations, dataOperations, miscOperations, numericOperations, stringOperations] + +-- | Groups of operations on similar data. +arrayOperations, booleanOperations, dataOperations, numericOperations, stringOperations :: Operations +arrayOperations = toOperations O.arrayOperations +booleanOperations = toOperations O.booleanOperations +dataOperations = toOperations O.dataOperations +numericOperations = toOperations O.numericOperations +stringOperations = toOperations O.stringOperations + +-- | Array operations. +map, reduce, filter, all, none, some, merge, in' :: Operation +map = toOperation O.map +reduce = toOperation O.reduce +filter = toOperation O.filter +all = toOperation O.all +none = toOperation O.none +some = toOperation O.some +merge = toOperation O.merge +in' = toOperation O.in' + +-- | Boolean operations. +if', (==), (===), (!=), (!==), (!), (!!), and, or :: Operation +if' = toOperation O.if' +(==) = toOperation (O.==) +(===) = toOperation (O.===) +(!=) = toOperation (O.!=) +(!==) = toOperation (O.!==) +(!) = toOperation (O.!) +(!!) = toOperation (O.!!) +and = toOperation O.and +or = toOperation O.or + +-- | Data operations. +var, missing, missingSome, preserve :: Operation +var = toOperation O.var +missing = toOperation O.missing +missingSome = toOperation O.missingSome +preserve = toOperation O.preserve + +-- | Numeric operations. +(>), (>=), (<), (<=), max, min, sum, (+), (-), (*), (/), (%) :: Operation +(>) = toOperation (O.>) +(>=) = toOperation (O.>=) +(<) = toOperation (O.<) +(<=) = toOperation (O.<=) +max = toOperation O.max +min = toOperation O.min +sum = toOperation O.sum +(+) = toOperation (O.+) +(-) = toOperation (O.-) +(*) = toOperation (O.*) +(/) = toOperation (O./) +(%) = toOperation (O.%) + +-- | String operations. +cat, substr :: Operation +cat = toOperation O.cat +substr = toOperation O.substr + +-- Primitive Evaluators + +-- | Evaluate to a double. +evaluateDouble :: Function P.Double +evaluateDouble = toFunction O.evaluateDouble + +-- | Evaluate to an int. +evaluateInt :: Function P.Int +evaluateInt = toFunction O.evaluateInt + +-- | Evaluate to a bool. +evaluateBool :: Function P.Bool +evaluateBool = toFunction O.evaluateBool + +-- | Evaluate to an array. +evaluateArray :: Function [Json] +evaluateArray = toFunction O.evaluateArray + +-- | Evaluate to an object. +evaluateObject :: Function JsonObject +evaluateObject = toFunction O.evaluateObject + +-- | Evaluate to a string. +evaluateString :: Function P.String +evaluateString = toFunction O.evaluateString diff --git a/src/JsonLogic/IO/Operation/Misc.hs b/src/JsonLogic/IO/Operation/Misc.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/IO/Operation/Misc.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedLists #-} + +-- | +-- Module : JsonLogic.IO.Operation.Misc +-- Description : JsonLogic misc IO operations +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.IO.Operation.Misc (miscOperations, trace, log) where + +import Control.Monad.Except +import JsonLogic.IO.Mapping +import JsonLogic.IO.Type +import JsonLogic.Json +import qualified JsonLogic.Operation as O +import Prelude hiding (log) + +-- | Groups of operations on similar data. +miscOperations :: Operations +miscOperations = [trace, log] + +-- | Misc operations. +trace, log :: Operation +trace = toOperation O.trace +log = ("log", evaluateLog) + +evaluateLog :: Function Json +evaluateLog evaluator args vars = runExceptT $ do + res <- ExceptT $ evaluator args vars + let val = case res of + JsonArray (item : _) -> item + oth -> oth + liftIO $ print val + return val diff --git a/src/JsonLogic/IO/Type.hs b/src/JsonLogic/IO/Type.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/IO/Type.hs @@ -0,0 +1,32 @@ +-- | +-- Module : JsonLogic.IO.Type +-- Description : JsonLogic IO types +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.IO.Type (Result, SubEvaluator, Function, Operation, Operations, throw, T.Exception (..)) where + +import Control.Monad.Except +import qualified Data.Map as M +import JsonLogic.Json +import qualified JsonLogic.Type as T + +-- | A result is an exception or a value wrapped in IO. +type Result r = IO (Either T.Exception r) + +-- | A Subevaluator takes a rule and data and returns a result of Json. +type SubEvaluator = Rule -> Data -> Result Json + +-- | A function takes a subevaluator, rule and data and returns a result. +type Function r = SubEvaluator -> Rule -> Data -> Result r + +-- | An operation is a Json function with a name. +type Operation = (String, Function Json) + +-- | Operations is a Map from the operation name to the operation function. +type Operations = M.Map String (Function Json) + +-- | Throw an evaluation exception. +throw :: String -> Result a +throw = runExceptT . throwError . T.EvalException diff --git a/src/JsonLogic/Json.hs b/src/JsonLogic/Json.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Json.hs @@ -0,0 +1,350 @@ +-- | +-- Module : JsonLogic.Json +-- Description : JsonLogic Json object with utility functions and read/show instances +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Json (Json (..), JsonObject, Rule, Data, prettyShow, stringify, isTruthy, isFalsy, parseFloat) where + +import Control.Applicative +import Data.Char (isSpace) +import Data.List (intercalate) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Text.Read + ( Read (readPrec), + ReadPrec, + get, + parens, + pfail, + readMaybe, + (+++), + ) + +-- | Json is a collection of possible Json values. +data Json + = JsonNull + | JsonBool Bool + | JsonNumber Double + | JsonString String + | JsonArray [Json] + | JsonObject JsonObject + deriving (Eq) + +-- | A Json object is a map of string-Json pairs. +type JsonObject = M.Map String Json + +-- | A rule can be any kind of Json value, but objects and arrays will be evaluated. +type Rule = Json + +-- | Data can be any kind of Json value. +type Data = Json + +-- An instance to show Json in clear format for users. +instance Show Json where + show JsonNull = "null" + show (JsonBool True) = "true" + show (JsonBool False) = "false" + show (JsonNumber d) = show d + show (JsonString s) = show s + show (JsonArray js) = show js + show (JsonObject o) = "{" ++ intercalate "," (map (\(k, v) -> show k ++ ":" ++ show v) $ M.toList o) ++ "}" + +-- Using a custom parser to read the Json according to specification. +instance Read Json where + readPrec = parens readValue + +-- | A pretty formatted show for the Json, with identation and depth +-- Use putStr so the newline characters will be interpreted in console +-- +-- >>> putStr $ prettyShow JsonNull +-- null +-- +-- >>> putStr $ prettyShow $ JsonNumber 3.0 +-- 3.0 +-- +-- >>> prettyShow (JsonArray [JsonNumber 1, JsonNumber 2]) +-- "[\n 1.0,\n 2.0\n]" +-- +-- >>> putStr $ prettyShow (JsonArray [JsonNumber 1, JsonBool True]) +-- [ +-- 1.0, +-- true +-- ] +prettyShow :: Json -> String +prettyShow = prettyShow' 0 + where + -- Pretty show with the number of spaces included + prettyShow' :: Int -> Json -> String + prettyShow' nrSpaces (JsonArray js) = + "[\n" + ++ commaSeparate (map (\j -> tab nrSpaces ++ prettyShow' (nrSpaces + 2) j) js) + ++ closingBracket nrSpaces ']' + prettyShow' nrSpaces (JsonObject o) = + "{\n" + ++ commaSeparate (map (\(k, v) -> tab nrSpaces ++ show k ++ ": " ++ prettyShow' (nrSpaces + 2) v) $ M.toList o) + ++ closingBracket nrSpaces '}' + prettyShow' _ json = show json + -- Helper functions for clarity + commaSeparate :: [String] -> String + commaSeparate = intercalate ",\n" + closingBracket :: Int -> Char -> String + closingBracket depth c = "\n" ++ replicate depth ' ' ++ [c] + tab :: Int -> String + tab depth = replicate (depth + 2) ' ' + +-- | Convert Json to string, used in string operations +-- See https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Object/toString for more information. +stringify :: Json -> String +stringify JsonNull = "" +stringify (JsonBool True) = "true" +stringify (JsonBool False) = "false" +stringify (JsonNumber d) = show d +stringify (JsonString s) = s +stringify (JsonArray js) = intercalate "," $ map stringify js +stringify (JsonObject _) = "[object Object]" + +-- | Truthy test for Json +-- See https://developer.mozilla.org/en-US/docs/Glossary/Truthy for more information. +isTruthy :: Json -> Bool +isTruthy JsonNull = False +isTruthy (JsonBool b) = b +isTruthy (JsonNumber 0.0) = False +isTruthy (JsonNumber _) = True +isTruthy (JsonString "") = False +isTruthy (JsonString _) = True +isTruthy (JsonArray []) = False +isTruthy (JsonArray _) = True +isTruthy (JsonObject _) = True + +-- | The opposite of `isTruthy` +isFalsy :: Json -> Bool +isFalsy = not . isTruthy + +-- | Convert Json to a numeric value, including NaN +-- Same as the Parsefloat function in JS +-- Parsefloat source: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/parseFloat +-- NaN source: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/NaN +parseFloat :: Json -> Double +-- Numbers stay just numbers +parseFloat (JsonNumber n) = n +-- The string "Infinity" is parsed as actual infinity +parseFloat (JsonString "Infinity") = infinity +-- First drop all whitespace, then take all "valid" characters. Drop everything after the second point and then try to parse it to a double. +parseFloat (JsonString s) = fromMaybe notANumber $ readMaybe $ dropAfterSecondPoint $ takeWhile isValid $ dropWhile isSpace s + where + -- Numbers, decimal point, +/- for sign and e/E for exponent are valid characters. + isValid x + | x `elem` valids = True + | otherwise = False + valids = ['0' .. '9'] ++ ['.', 'e', 'E', '+', '-'] + -- Break on the first decimal point, then the second, and glue the first parts together to drop evertyhing after the second point. + dropAfterSecondPoint t = case break (== '.') t of + (l, '.' : r) -> case break (== '.') r of (l', _) -> l ++ "." ++ l' + (l, _) -> l +-- For an array always take the first element. +parseFloat (JsonArray (a : _)) = parseFloat a +-- Everything else is NaN +parseFloat _ = notANumber + +-- Gives a Infinity +infinity :: Double +infinity = 1 / 0 + +-- Gives a NaN +notANumber :: Double +notANumber = 0 / 0 + +-- Parsing +-- See https://www.json.org/json-en.html + +-- Read an object, a map with strings as keys. +readObject :: ReadPrec JsonObject +readObject = do + '{' <- get + items <- + ( do + readWhitespace + return [] + ) + +++ ( do + h <- readKvp + t <- many $ do + ',' <- get + readKvp + return $ h : t + ) + '}' <- get + return $ M.fromList items + where + readKvp = do + readWhitespace + key <- readString + readWhitespace + ':' <- get + value <- readValue + return (key, value) + +-- Read an array, can contain multiple comma separated values. +readArray :: ReadPrec [Json] +readArray = do + '[' <- get + items <- + ( do + readWhitespace + return [] + ) + +++ ( do + h <- readValue + t <- many $ do + ',' <- get + readValue + return $ h : t + ) + ']' <- get + return items + +-- Read a value, wrapper around many of the other parsers. +readValue :: ReadPrec Json +readValue = do + readWhitespace + value <- + (JsonString <$> readString) + +++ (JsonNumber <$> readNumber) + +++ (JsonObject <$> readObject) + +++ (JsonArray <$> readArray) + +++ ( do + "true" <- many get + return $ JsonBool True + ) + +++ ( do + "false" <- many get + return $ JsonBool False + ) + +++ ( do + "null" <- many get + return JsonNull + ) + readWhitespace + return value + +-- Reads a string with escaping. +readString :: ReadPrec String +readString = do + '\"' <- get + xs <- + many $ + ( do + char <- get + case char of + '\\' -> pfail + '\"' -> pfail + plain -> return plain + ) + +++ ( do + '\\' <- get + char <- get + case char of + '\"' -> return '\"' + '\\' -> return '\\' + '/' -> return '/' + 'b' -> return '\b' + 'f' -> return '\f' + 'n' -> return '\n' + 'r' -> return '\r' + 't' -> return '\t' + 'u' -> do + a <- readHex + b <- readHex + c <- readHex + d <- readHex + return $ toEnum $ foldl (\l r -> l * 16 + r) 0 [a, b, c, d] + _ -> pfail + ) + '\"' <- get + return xs + where + readHex = readMap $ zip (['0' .. '9'] ++ ['A' .. 'F'] ++ ['a' .. 'f']) ([0 .. 9] ++ [10 .. 15] ++ [10 .. 15]) + +-- Reads a number, including the sign and exponent as a double. +readNumber :: ReadPrec Double +readNumber = do + -- An optional negative sign + sign <- + return id + +++ ( do + '-' <- get + return negate + ) + -- Numbers before the optional decimal. + beforeDecimal <- + ( -- Can be just 0 + do + '0' <- get + return 0 + ) + +++ ( + -- Or can be non zero, without starting with a 0 + do + nonZeroDigit <- getNonZeroDigit + digits <- many getDigit + return $ foldl (\l r -> l * 10 + r) nonZeroDigit digits + ) + -- Numbers after the optional decimal + afterDecimal <- + return id + +++ ( do + -- After decimal single or more digits + '.' <- get + digits <- some getDigit + -- Added 0 to the front of the digits to make it below 1 + return $ (+) $ foldr1 (\l r -> l + r / 10) (0 : digits) + ) + -- Or zero if no decimal + -- The number exponent + expo <- + -- Can be 1 if no exponent. + return id +++ do + -- Otherwise may start with e or E + ( do + 'e' <- get + return () + ) + +++ ( do + 'E' <- get + return () + ) + -- Then may have a sign, defaulting to positive + expBase <- + return (*) + +++ ( do + '-' <- get + return $ flip (/) + ) + +++ ( do + '+' <- get + return (*) + ) + -- Then some digits determining the size. + expDigits <- + ( do + digits <- some getDigit + return $ foldl1 (\l r -> l * 10 + r) digits + ) + return $ expBase $ 10 ** expDigits + -- Then combine everything. + return $ sign $ expo $ afterDecimal beforeDecimal + where + getDigit = readMap $ zip ['0' .. '9'] [0 .. 9] + getNonZeroDigit = readMap $ zip ['1' .. '9'] [1 .. 9] + +-- Reads whitespace and throws it away. +readWhitespace :: ReadPrec () +readWhitespace = () <$ many (readMap $ zip " \t\n\r" (repeat ())) + +-- Use a lookup table to parse characters. +readMap :: [(Char, a)] -> ReadPrec a +readMap xs = do + x <- get + maybe pfail return (lookup x xs) diff --git a/src/JsonLogic/Operation.hs b/src/JsonLogic/Operation.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Operation.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : JsonLogic.Operation +-- Description : Internal JsonLogic operations +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental + +-- Prevent Ormolu from putting everything on a separate line. +{- ORMOLU_DISABLE -} +module JsonLogic.Operation + ( defaultOperations, + arrayOperations, map, reduce, filter, all, none, some, merge, in', + booleanOperations, if', (==), (===), (!=), (!==), (!), (!!), and, or, + dataOperations, var, missing, missingSome, preserve, + miscOperations, trace, + numericOperations, (>), (>=), (<), (<=), max, min, sum, (+), (-), (*), (/), (%), + stringOperations, cat, substr, + evaluateDouble, evaluateInt, evaluateBool, evaluateArray, evaluateObject, evaluateString + ) +where +{- ORMOLU_ENABLE -} + +import Control.Monad +import qualified Data.Map as M +import JsonLogic.Operation.Array +import JsonLogic.Operation.Boolean +import JsonLogic.Operation.Data +import JsonLogic.Operation.Misc +import JsonLogic.Operation.Numeric +import JsonLogic.Operation.Primitive +import JsonLogic.Operation.String +import JsonLogic.Type + +-- Default operators +defaultOperations :: Monad m => Operations m +defaultOperations = M.unions [arrayOperations, booleanOperations, dataOperations, miscOperations, numericOperations, stringOperations] diff --git a/src/JsonLogic/Operation/Array.hs b/src/JsonLogic/Operation/Array.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Operation/Array.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} + +-- | +-- Module : JsonLogic.Operation.Array +-- Description : Internal JsonLogic operations on arrays +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Operation.Array (arrayOperations, map, reduce, filter, all, none, some, merge, in') where + +import Control.Monad +import qualified Data.List as L +import JsonLogic.Json +import JsonLogic.Operation.Primitive +import JsonLogic.Type +import Prelude hiding (all, filter, map) + +arrayOperations :: Monad m => Operations m +arrayOperations = [map, reduce, filter, all, none, some, merge, in'] + +map, reduce, filter :: Monad m => Operation m +map = ("map", evaluateMap) +reduce = ("reduce", evaluateReduce) +filter = ("filter", evaluateFilter) + +all, none, some :: Monad m => Operation m +all = ("all", evaluateArrayToBool (\case [] -> False; bools -> and bools)) +none = ("none", evaluateArrayToBool (not . or)) +some = ("some", evaluateArrayToBool or) + +merge, in' :: Monad m => Operation m +merge = ("merge", evaluateMerge) +in' = ("in", evaluateIn) + +-- Evaluation for map +evaluateMap :: Monad m => Function m Json +evaluateMap evaluator (JsonArray [xs, f]) vars = do + xs' <- evaluateArray evaluator xs vars -- This is our data we evaluate + JsonArray <$> mapM (evaluator f) xs' +evaluateMap _ _ _ = throw "Map received the wrong arguments" + +evaluateReduce :: Monad m => Function m Json +evaluateReduce evaluator (JsonArray [arrayExp, reduceFunction, initalExp]) vars = do + array <- evaluateArray evaluator arrayExp vars + initial <- evaluator initalExp vars + foldM (\acc cur -> evaluator reduceFunction (JsonObject [("current", cur), ("accumulator", acc)])) initial array +evaluateReduce _ _ _ = throw "Wrong number of arguments for reduce" + +evaluateFilter :: Monad m => Function m Json +evaluateFilter evaluator (JsonArray [xs, f]) vars = do + array <- evaluateArray evaluator xs vars + filtered <- filterM (evaluateBool evaluator f) array + return $ JsonArray filtered +evaluateFilter _ _ _ = throw "Wrong number of arguments for filter" + +evaluateArrayToBool :: Monad m => ([Bool] -> Bool) -> Function m Json +evaluateArrayToBool operator evaluator (JsonArray [xs, f]) vars = do + xs' <- evaluateArray evaluator xs vars -- This is our data we evaluate + bools <- mapM (evaluateBool evaluator f) xs' + return $ JsonBool $ operator bools +evaluateArrayToBool _ _ _ _ = throw "Map received the wrong arguments" + +-- | Merge operations flattens the array in the top level +evaluateMerge :: Monad m => Function m Json +evaluateMerge evaluator params vars = do + res <- evaluator params vars + case res of + (JsonArray js) -> return $ JsonArray $ foldr merge' [] js + -- If we get a single item, it gets put in an array + json -> return $ JsonArray [json] + where + merge' (JsonArray as) acc = as ++ acc + merge' j acc = j : acc + +evaluateIn :: Monad m => Function m Json +evaluateIn evaluator (JsonArray (sub : arr : _)) vars = do + sub' <- evaluator sub vars + arr' <- evaluator arr vars + return $ + JsonBool $ case (sub', arr') of + (el, JsonArray xs) -> el `elem` xs + (JsonString substr, JsonString s) -> substr `L.isInfixOf` s + _ -> False +evaluateIn _ _ _ = return $ JsonBool False diff --git a/src/JsonLogic/Operation/Boolean.hs b/src/JsonLogic/Operation/Boolean.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Operation/Boolean.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedLists #-} + +-- | +-- Module : JsonLogic.Operation.Boolean +-- Description : Internal JsonLogic operations on booleans +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Operation.Boolean (booleanOperations, if', (==), (===), (!=), (!==), (!), (!!), and, or) where + +import Control.Monad.Except +import JsonLogic.Json +import JsonLogic.Operation.Primitive +import JsonLogic.Operation.Utils +import JsonLogic.Type +import Prelude hiding (all, and, any, filter, map, max, min, or, sum, (!!), (&&), (==), (||)) +import qualified Prelude as P hiding (and, or) + +booleanOperations :: Monad m => Operations m +booleanOperations = [if', (==), (===), (!=), (!==), (!), (!!), and, or] + +if' :: Monad m => Operation m +if' = ("if", evaluateIf) + +-- Implementation for bool -> bool -> bool operators +(==), (===), (!=), (!==), (!), (!!), and, or :: Monad m => Operation m +(==) = ("==", looseEquals) +(===) = ("===", evaluateLogic (P.==)) +(!=) = ("!=", looseNotEquals) +(!==) = ("!==", evaluateLogic (P./=)) +(!) = ("!", evaluateFalsey) +(!!) = ("!!", evaluateTruthy) +and = ("and", evaluateLogic (P.&&)) +or = ("or", evaluateLogic (P.||)) + +evaluateIf :: Monad m => Function m Json +evaluateIf evaluator (JsonArray [c, x, y]) vars = do + res <- evaluateBool evaluator c vars + evaluator (if res then x else y) vars +evaluateIf _ _ _ = throw "Wrong number of arguments for if" + +-- Helper functions + +evaluateLogic :: Monad m => (Bool -> Bool -> Bool) -> Function m Json +evaluateLogic operator evaluator (JsonArray [x, y]) vars = do + x' <- evaluateBool evaluator x vars + y' <- evaluateBool evaluator y vars + return $ JsonBool $ x' `operator` y' +evaluateLogic _ _ _ _ = throw "Wrong number of arguments for logic operator" + +evaluateTruthy :: Monad m => Function m Json +evaluateTruthy evaluator json vars = JsonBool <$> evaluateBool evaluator (evaluateUnaryArgument json) vars + +evaluateFalsey :: Monad m => Function m Json +evaluateFalsey evaluator json vars = JsonBool . not <$> evaluateBool evaluator (evaluateUnaryArgument json) vars + +-- | Evaluate loose equals +looseEquals :: Monad m => Function m Json +looseEquals evaluator (JsonArray [x, y]) vars = do + x' <- evaluator x vars + y' <- evaluator y vars + return $ JsonBool $ looseEq x' y' +looseEquals _ _ _ = throw "Wrong number of arguments for loose not equals operator" + +looseNotEquals :: Monad m => Function m Json +looseNotEquals evaluator (JsonArray [x, y]) vars = do + x' <- evaluator x vars + y' <- evaluator y vars + return $ JsonBool $ not $ looseEq x' y' +looseNotEquals _ _ _ = throw "Wrong number of arguments for loose not equals operator" + +-- | See: https://github.com/gregsdennis/json-everything/blob/master/JsonLogic/JsonElementExtensions.cs#L117 +-- See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Equality +looseEq :: Json -> Json -> Bool +looseEq (JsonArray a) (JsonArray b) = a P.== b +looseEq (JsonObject a) (JsonObject b) = a P.== b +looseEq (JsonNumber a) (JsonNumber b) = a P.== b +looseEq (JsonString a) (JsonString b) = a P.== b +looseEq (JsonBool a) (JsonBool b) = a P.== b +looseEq JsonNull JsonNull = True +looseEq JsonNull _ = False +looseEq _ JsonNull = False +looseEq (JsonObject _) _ = False +looseEq _ (JsonObject _) = False +looseEq a@(JsonNumber _) (JsonArray b) = looseEq a (JsonString $ show b) +looseEq (JsonArray a) b@(JsonNumber _) = looseEq (JsonString $ show a) b +looseEq a@(JsonNumber _) b = a P.== numberify b +looseEq a b@(JsonNumber _) = numberify a P.== b +looseEq (JsonArray a) (JsonString b) = show a P.== b +looseEq (JsonString a) (JsonArray b) = a P.== show b +looseEq _ _ = False + +-- See https://github.com/gregsdennis/json-everything/blob/master/JsonLogic/JsonElementExtensions.cs#L84 +numberify :: Json -> Json +numberify (JsonString s) = JsonNumber (read s) +numberify n@(JsonNumber _) = n +numberify (JsonBool b) = JsonNumber $ toEnum $ fromEnum b +numberify _ = JsonNull diff --git a/src/JsonLogic/Operation/Data.hs b/src/JsonLogic/Operation/Data.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Operation/Data.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedLists #-} + +-- | +-- Module : JsonLogic.Operation.Data +-- Description : Internal JsonLogic operations on objects and data +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Operation.Data (dataOperations, var, missing, missingSome, preserve) where + +import Data.Maybe +import JsonLogic.Json +import JsonLogic.Operation.Primitive +import JsonLogic.Operation.Utils +import JsonLogic.Type + +dataOperations :: Monad m => Operations m +dataOperations = [var, missing, missingSome, preserve] + +var, missing, missingSome :: Monad m => Operation m +var = ("var", evaluateVar) +missing = ("missing", evaluateMissing) +missingSome = ("missing_some", evaluateMissingSome) + +preserve :: Monad m => Operation m +preserve = ("preserve", \_ rule _ -> return rule) + +-- Evaluates a var +evaluateVar :: Monad m => Function m Json +evaluateVar evaluator param vars = do + res <- evaluator param vars + -- Extracts default value from array if it has one + let (j, def) = getJsonWithDefault res + case j of + -- Indexing using a floored double or index object using a string + i@(JsonNumber _) -> return $ fromMaybe def $ indexWithJson i vars + i@(JsonString _) -> return $ fromMaybe def $ indexWithJson i vars + -- null and empty array return the variables directly + JsonNull -> return vars + JsonArray [] -> return vars + -- Nested array, boolean and object always resort to default value + _ -> return def + +-- | When var receives an array, the first item is the initial logic +-- If that logic fails then the second value is defaulted to +-- Any valuie after the second one is ignored +getJsonWithDefault :: Json -> (Json, Json) +getJsonWithDefault (JsonArray (x : y : _)) = (x, y) +getJsonWithDefault j = (j, JsonNull) + +-- | Evaluates which elements are missing from the Json +evaluateMissing :: Monad m => Function m Json +evaluateMissing evaluator keys' vars = do + keys <- evaluator keys' vars + -- Only keep the missing values in the json array + return . JsonArray $ missingKeys keys vars + +-- | Evaluates whether more than x items are missing from the original array +-- If so, it returns the entire list of missing items +-- Otherwise it returns an empty list +evaluateMissingSome :: Monad m => Function m Json +evaluateMissingSome evaluator (JsonArray [minKeys', keys']) vars = do + minKeys <- evaluateInt evaluator minKeys' vars + keys <- evaluator keys' vars + let miss = missingKeys keys vars + case keys of + -- Return result if at least x elements are missing or else an empty array + JsonArray js | length js - length miss >= minKeys -> return $ JsonArray [] + JsonArray _ -> return $ JsonArray miss + -- If there is only a singleton as parameter, the length is 1 + _ | 1 - length miss >= minKeys -> return $ JsonArray [] + _ -> return $ JsonArray miss +-- The parameters are invalid +evaluateMissingSome _ json _ = throw $ "Error: missing_some expects an array of two arguments, instead it got: " ++ show json + +-- | Returns the missing keys from the original array +missingKeys :: Json -> Data -> [Json] +missingKeys keys vars = [key | key <- getKeys keys, isNothing $ indexWithJson key vars] + where + -- The keys used for our search + getKeys :: Json -> [Json] + getKeys (JsonArray (arr@(JsonArray _) : _)) = getKeys arr + getKeys (JsonArray js) = js + getKeys j = [j] diff --git a/src/JsonLogic/Operation/Misc.hs b/src/JsonLogic/Operation/Misc.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Operation/Misc.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedLists #-} + +-- | +-- Module : JsonLogic.Operation.Misc +-- Description : Internal JsonLogic misc operations +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Operation.Misc (miscOperations, trace) where + +import Debug.Trace (traceShow) +import JsonLogic.Json +import JsonLogic.Type +import Prelude hiding (log) + +miscOperations :: Monad m => Operations m +miscOperations = [trace] + +trace :: Monad m => Operation m +trace = ("trace", evaluateTrace) + +evaluateTrace :: Monad m => Function m Json +evaluateTrace evaluator args vars = do + res <- evaluator args vars + let val = case res of + JsonArray (item : _) -> item + oth -> oth + traceShow val return val diff --git a/src/JsonLogic/Operation/Numeric.hs b/src/JsonLogic/Operation/Numeric.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Operation/Numeric.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedLists #-} + +-- | +-- Module : JsonLogic.Operation.Numeric +-- Description : Internal JsonLogic operations on numbers +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Operation.Numeric (numericOperations, (>), (>=), (<), (<=), max, min, sum, (+), (-), (*), (/), (%)) where + +import Control.Monad.Except +import qualified Data.Fixed as F +import JsonLogic.Json +import JsonLogic.Operation.Primitive +import JsonLogic.Type +import Prelude hiding (max, min, sum, (*), (+), (-), (/), (<), (<=), (>), (>=)) +import qualified Prelude hiding (max, min, sum) +import qualified Prelude as P + +numericOperations :: Monad m => Operations m +numericOperations = [(>), (>=), (<), (<=), max, min, sum, (+), (-), (*), (/), (%)] + +-- Implementation for double -> double -> bool operators +(>), (>=), (<), (<=) :: Monad m => Operation m +(>) = (">", evaluateComparison (P.>)) +(>=) = (">=", evaluateComparison (P.>=)) +(<) = ("<", evaluateBetween (P.<)) +(<=) = ("<=", evaluateBetween (P.<=)) + +max, min, sum :: Monad m => Operation m +max = ("max", evaluateDoubleArray P.maximum) +min = ("min", evaluateDoubleArray P.minimum) +sum = ("sum", evaluateDoubleArray P.sum) + +(+), (-), (*), (/), (%) :: Monad m => Operation m +(+) = ("+", evaluateMath (P.+)) +(-) = ("-", evaluateMath (P.-)) +(*) = ("*", evaluateMath (P.*)) +(/) = ("/", evaluateMath (P./)) +(%) = ("%", evaluateMath F.mod') + +evaluateComparison :: Monad m => (Double -> Double -> Bool) -> Function m Json +evaluateComparison operator evaluator (JsonArray [x, y]) vars = do + x' <- evaluateDouble evaluator x vars + y' <- evaluateDouble evaluator y vars + return $ JsonBool $ x' `operator` y' +evaluateComparison _ _ _ _ = throw "Wrong number of arguments for comparison operator" + +-- Adds the between operator to check whether a number is between two other numbers +evaluateBetween :: Monad m => (Double -> Double -> Bool) -> Function m Json +evaluateBetween operator evaluator (JsonArray [x, y, z]) vars = do + x' <- evaluateDouble evaluator x vars + y' <- evaluateDouble evaluator y vars + z' <- evaluateDouble evaluator z vars + return $ JsonBool $ (x' `operator` y') P.&& (y' `operator` z') +-- The regular two value case of the operator +evaluateBetween operator evaluator json vars = evaluateComparison operator evaluator json vars + +-- Function evaluators +evaluateMath :: Monad m => (Double -> Double -> Double) -> Function m Json +evaluateMath operator evaluator (JsonArray [x, y]) vars = do + x' <- evaluateDouble evaluator x vars + y' <- evaluateDouble evaluator y vars + return $ JsonNumber $ x' `operator` y' +evaluateMath _ _ _ _ = throw "Wrong number of arguments for math operator" + +-- Evaluation for max/min +evaluateDoubleArray :: Monad m => ([Double] -> Double) -> Function m Json +evaluateDoubleArray _ _ (JsonArray []) _ = throw "Can't evaluate array action an empty list" +evaluateDoubleArray operator evaluator (JsonArray arr) vars = do + arr' <- mapM (\x -> evaluateDouble evaluator x vars) arr + return $ JsonNumber $ operator arr' +evaluateDoubleArray _ _ json _ = throw $ "Can't evaluate array action on non array, namely: " ++ show json diff --git a/src/JsonLogic/Operation/Primitive.hs b/src/JsonLogic/Operation/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Operation/Primitive.hs @@ -0,0 +1,48 @@ +-- | +-- Module : JsonLogic.Operation.Primitive +-- Description : Internal JsonLogic functions to evaluate to primitive types +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Operation.Primitive (evaluateDouble, evaluateInt, evaluateBool, evaluateArray, evaluateObject, evaluateString) where + +import JsonLogic.Json +import JsonLogic.Type + +-- Primitive evaluators +evaluateDouble :: Monad m => Function m Double +evaluateDouble evaluator param vars = do + res <- evaluator param vars + return $ parseFloat res + +evaluateInt :: Monad m => Function m Int +evaluateInt evaluator param vars = do + res <- evaluateDouble evaluator param vars + if isNaN res + then throw "NotImplemented: NaN to int evaluation" + else return $ floor res + +evaluateBool :: Monad m => Function m Bool +evaluateBool evaluator param vars = do + res <- evaluator param vars + return $ isTruthy res + +evaluateArray :: Monad m => Function m [Json] +evaluateArray evaluator param vars = do + res <- evaluator param vars + case res of + JsonArray xs -> return xs + j -> throw $ "Invalid parameter type, was expecting array. Got: " ++ show j + +evaluateObject :: Monad m => Function m JsonObject +evaluateObject evaluator param vars = do + res <- evaluator param vars + case res of + JsonObject v -> return v + j -> throw $ "Invalid parameter type, was expecting object. Got: " ++ show j + +evaluateString :: Monad m => Function m String +evaluateString evaluator param vars = do + res <- evaluator param vars + return $ stringify res diff --git a/src/JsonLogic/Operation/String.hs b/src/JsonLogic/Operation/String.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Operation/String.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedLists #-} + +-- | +-- Module : JsonLogic.Operation.String +-- Description : Internal JsonLogic operations on strings +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Operation.String (stringOperations, cat, substr) where + +import JsonLogic.Json +import JsonLogic.Operation.Primitive +import JsonLogic.Type + +stringOperations :: Monad m => Operations m +stringOperations = [cat, substr] + +-- String Operations +cat, substr :: Monad m => Operation m +cat = ("cat", evaluateCat) +substr = ("substr", evaluateSubstr) + +evaluateCat :: Monad m => Function m Json +evaluateCat evaluator args vars = do + res <- evaluator args vars + case res of + (JsonArray js) -> return $ JsonString $ foldMap stringify js + json -> return $ JsonString $ stringify json + +-- | Evaluate substr operation +evaluateSubstr :: Monad m => Function m Json +evaluateSubstr evaluator param vars = do + res <- evaluator param vars + JsonString <$> case res of + -- Take everything from the index (can be negative) + JsonArray [s, i] -> do + str <- evaluateString evaluator s vars + index <- evaluateInt evaluator i vars + return $ alterSubstr drop index str + -- Take a part of the substring between the two indexes + JsonArray (s : startI : endI : _) -> do + str <- evaluateString evaluator s vars + startIndex <- evaluateInt evaluator startI vars + endIndex <- evaluateInt evaluator endI vars + return $ alterSubstr take endIndex $ alterSubstr drop startIndex str + -- No proper indexing arguments given, return the full json string + json -> evaluateString evaluator json vars + where + -- Takes part of the substring given a positive or negative index + alterSubstr :: (Int -> String -> String) -> Int -> String -> String + alterSubstr f index str + | index >= 0 = f index str + | otherwise = f (length str + index) str diff --git a/src/JsonLogic/Operation/Utils.hs b/src/JsonLogic/Operation/Utils.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Operation/Utils.hs @@ -0,0 +1,91 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} + +-- | +-- Module : JsonLogic.Operation.Utils +-- Description : Internal JsonLogic operations utilities +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Operation.Utils where + +-- IMPORTANT!! Needs singleton import for doctests +import qualified Data.Map as M +import JsonLogic.Json +import JsonLogic.Type +import Text.Read + +-- | Index a json object using a string seperated by periods. +-- +-- >>> indexWithJson (JsonString "x.y") (JsonObject $ M.singleton "x" $ JsonObject $ M.singleton "y" JsonNull) +-- Just null +-- +-- >>> indexWithJson (JsonString "x.y") (JsonObject $ M.singleton "x" JsonNull) +-- Nothing +-- +-- >>> indexWithJson (JsonString "") (JsonNumber 1) +-- Just 1.0 +-- +-- >>> indexWithJson (JsonString "1") (JsonArray [JsonString "abc", JsonString "def"]) +-- Just "def" +-- +-- >>> indexWithJson (JsonString "1.0") (JsonArray [JsonString "abc", JsonString "def"]) +-- Just "d" +-- +-- >>> indexWithJson (JsonString "abs") (JsonArray [JsonString "abc", JsonString "def"]) +-- Nothing +indexWithJson :: Rule -> Data -> Maybe Json +indexWithJson (JsonString indexString) = indexWithString (splitOnPeriod indexString) +indexWithJson (JsonNumber indexNumber) = indexWithString [show (floor indexNumber :: Int)] +indexWithJson _ = const Nothing + +indexWithString :: [String] -> Data -> Maybe Json +indexWithString [] vars = Just vars +indexWithString [x] (JsonString s) = + readMaybe x >>= (!?) s >>= Just . JsonString . singleton +indexWithString (x : xs) (JsonArray js) = + readMaybe x >>= (!?) js >>= indexWithString xs +indexWithString (x : xs) (JsonObject o) = M.lookup x o >>= indexWithString xs +indexWithString _ _ = Nothing + +-- | Splits string on periods +-- Same definition as words at: https://github.com/ghc/ghc/blob/master/libraries/base/Data/OldList.hs +-- +-- >>> splitOnPeriod "foo.bar.tea" +-- ["foo","bar","tea"] +splitOnPeriod :: String -> [String] +splitOnPeriod "" = [] +splitOnPeriod s = case dropWhile ('.' Prelude.==) s of + "." -> [] + s' -> w : splitOnPeriod s'' + where + (w, s'') = break ('.' Prelude.==) s' + +-- Safe indexing of a list +(!?) :: [a] -> Int -> Maybe a +_ !? n | n < 0 = Nothing +[] !? _ = Nothing +(x : _) !? 0 = Just x +(_ : xs) !? n = xs !? (n - 1) + +-- | Returns the single item in a list if the argument is an array, otherwise returns the argument +-- If you like, we support syntactic sugar to skip the array around single arguments +-- Should only be used for unary operations. +-- +-- >>> evaluateUnaryArgument $ JsonArray [JsonString "abc"] +-- "abc" +-- +-- >>> evaluateUnaryArgument $ JsonString "abc" +-- "abc" +evaluateUnaryArgument :: Data -> Data +evaluateUnaryArgument (JsonArray [json]) = json +evaluateUnaryArgument json = json + +-- | Put a single item in a list +-- Included in base since: base-4.15.0.0 +-- But currently on older version. +-- +-- >>> singleton "single value" +-- ["single value"] +singleton :: a -> [a] +singleton x = [x] diff --git a/src/JsonLogic/Pure/Evaluator.hs b/src/JsonLogic/Pure/Evaluator.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Pure/Evaluator.hs @@ -0,0 +1,31 @@ +-- | +-- Module : JsonLogic.Pure.Evaluator +-- Description : JsonLogic Pure evaluator +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Pure.Evaluator (apply, applyEmpty) where + +import qualified Data.Map as M +import qualified JsonLogic.Evaluator as E +import JsonLogic.Json +import JsonLogic.Pure.Mapping +import JsonLogic.Pure.Operation +import JsonLogic.Pure.Type + +-- | Apply takes a list of operations, a rule and data. +-- And together with the default operations evaluates it. +-- +-- >>> apply [] (read "{\"cat\":[\"Hello, \", \"World!\"]}":: Json) JsonNull +-- Right "Hello, World!" +apply :: [Operation] -> Rule -> Data -> Result Json +apply ops = applyEmpty (ops ++ M.toList defaultOperations) + +-- | applyEmpty takes a list of operations, a rule and data. +-- And without the default operations evaluates it. +-- +-- >>> applyEmpty [] (read "{\"cat\":[\"Hello, \", \"World!\"]}":: Json) JsonNull +-- Left (UnrecognizedOperation {operationName = "cat"}) +applyEmpty :: [Operation] -> Rule -> Data -> Result Json +applyEmpty ops rule dat = toResult $ E.apply (M.map fromFunction $ M.fromList ops) rule dat diff --git a/src/JsonLogic/Pure/Mapping.hs b/src/JsonLogic/Pure/Mapping.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Pure/Mapping.hs @@ -0,0 +1,46 @@ +-- | +-- Module : JsonLogic.Pure.Mapping +-- Description : Internal JsonLogic Pure functions to map from exposed types to internal types and vice versa +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Pure.Mapping where + +import Control.Monad.Except +import Control.Monad.Identity +import qualified Data.Map as M +import JsonLogic.Pure.Type +import qualified JsonLogic.Type as T + +-- These functions are used to remove the monad transformer from the types. + +toResult :: T.Result Identity r -> Result r +toResult = runIdentity . runExceptT + +fromResult :: Result r -> T.Result Identity r +fromResult = liftEither + +toSubEvaluator :: T.SubEvaluator Identity -> SubEvaluator +toSubEvaluator s r d = toResult $ s r d + +fromSubEvaluator :: SubEvaluator -> T.SubEvaluator Identity +fromSubEvaluator s r d = fromResult $ s r d + +toFunction :: T.Function Identity r -> Function r +toFunction f s r d = toResult $ f (fromSubEvaluator s) r d + +fromFunction :: Function r -> T.Function Identity r +fromFunction f s r d = fromResult $ f (toSubEvaluator s) r d + +toOperation :: T.Operation Identity -> Operation +toOperation (s, f) = (s, toFunction f) + +fromOperation :: Operation -> T.Operation Identity +fromOperation (s, f) = (s, fromFunction f) + +toOperations :: T.Operations Identity -> Operations +toOperations = M.map toFunction + +fromOperations :: Operations -> T.Operations Identity +fromOperations = M.map fromFunction diff --git a/src/JsonLogic/Pure/Operation.hs b/src/JsonLogic/Pure/Operation.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Pure/Operation.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- Module : JsonLogic.Pure.Operation +-- Description : JsonLogic Pure operations +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental + +{- ORMOLU_DISABLE -} +module JsonLogic.Pure.Operation + ( defaultOperations, + arrayOperations, map, reduce, filter, all, none, some, merge, in', + booleanOperations, if', (==), (===), (!=), (!==), (!), (!!), and, or, + dataOperations, var, missing, missingSome, preserve, + miscOperations, trace, + numericOperations, (>), (>=), (<), (<=), max, min, sum, (+), (-), (*), (/), (%), + stringOperations, cat, substr, + evaluateDouble, evaluateInt, evaluateBool, evaluateArray, evaluateObject, evaluateString + ) +where +{- ORMOLU_ENABLE -} +import JsonLogic.Json +import qualified JsonLogic.Operation as O +import JsonLogic.Pure.Mapping +import JsonLogic.Pure.Type +import qualified Prelude as P + +-- | A map of all the default operations. +defaultOperations :: Operations +defaultOperations = toOperations O.defaultOperations + +-- | Groups of operations on similar data. +arrayOperations, booleanOperations, dataOperations, miscOperations, numericOperations, stringOperations :: Operations +arrayOperations = toOperations O.arrayOperations +booleanOperations = toOperations O.booleanOperations +dataOperations = toOperations O.dataOperations +miscOperations = toOperations O.miscOperations +numericOperations = toOperations O.numericOperations +stringOperations = toOperations O.stringOperations + +-- | Array operations. +map, reduce, filter, all, none, some, merge, in' :: Operation +map = toOperation O.map +reduce = toOperation O.reduce +filter = toOperation O.filter +all = toOperation O.all +none = toOperation O.none +some = toOperation O.some +merge = toOperation O.merge +in' = toOperation O.in' + +-- | Boolean operations. +if', (==), (===), (!=), (!==), (!), (!!), and, or :: Operation +if' = toOperation O.if' +(==) = toOperation (O.==) +(===) = toOperation (O.===) +(!=) = toOperation (O.!=) +(!==) = toOperation (O.!==) +(!) = toOperation (O.!) +(!!) = toOperation (O.!!) +and = toOperation O.and +or = toOperation O.or + +-- | Data operations. +var, missing, missingSome, preserve :: Operation +var = toOperation O.var +missing = toOperation O.missing +missingSome = toOperation O.missingSome +preserve = toOperation O.preserve + +-- | Misc operations. +trace :: Operation +trace = toOperation O.trace + +-- | Numeric operations. +(>), (>=), (<), (<=), max, min, sum, (+), (-), (*), (/), (%) :: Operation +(>) = toOperation (O.>) +(>=) = toOperation (O.>=) +(<) = toOperation (O.<) +(<=) = toOperation (O.<=) +max = toOperation O.max +min = toOperation O.min +sum = toOperation O.sum +(+) = toOperation (O.+) +(-) = toOperation (O.-) +(*) = toOperation (O.*) +(/) = toOperation (O./) +(%) = toOperation (O.%) + +-- | String operations. +cat, substr :: Operation +cat = toOperation O.cat +substr = toOperation O.substr + +-- Primitive Evaluators + +-- | Evaluate to a double. +evaluateDouble :: Function P.Double +evaluateDouble = toFunction O.evaluateDouble + +-- | Evaluate to an int. +evaluateInt :: Function P.Int +evaluateInt = toFunction O.evaluateInt + +-- | Evaluate to a bool. +evaluateBool :: Function P.Bool +evaluateBool = toFunction O.evaluateBool + +-- | Evaluate to an array. +evaluateArray :: Function [Json] +evaluateArray = toFunction O.evaluateArray + +-- | Evaluate to an object. +evaluateObject :: Function JsonObject +evaluateObject = toFunction O.evaluateObject + +-- | Evaluate to a string. +evaluateString :: Function P.String +evaluateString = toFunction O.evaluateString diff --git a/src/JsonLogic/Pure/Type.hs b/src/JsonLogic/Pure/Type.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Pure/Type.hs @@ -0,0 +1,31 @@ +-- | +-- Module : JsonLogic.Pure.Type +-- Description : JsonLogic Pure types +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Pure.Type (Result, SubEvaluator, Function, Operation, Operations, throw, T.Exception (..)) where + +import qualified Data.Map as M +import JsonLogic.Json +import qualified JsonLogic.Type as T + +-- | A result is an exception or a value. +type Result r = Either T.Exception r + +-- | A subevaluator takes a rule and data and returns a result of Json. +type SubEvaluator = Rule -> Data -> Result Json + +-- | A function takes a subevaluator, rule and data and returns a result. +type Function r = SubEvaluator -> Rule -> Data -> Result r + +-- | An operation is a Json function with a name. +type Operation = (String, Function Json) + +-- | Operations is a Map from the operation name to the operation function. +type Operations = M.Map String (Function Json) + +-- | Throw an evaluation exception. +throw :: String -> Result a +throw = Left . T.EvalException diff --git a/src/JsonLogic/Type.hs b/src/JsonLogic/Type.hs new file mode 100644 --- /dev/null +++ b/src/JsonLogic/Type.hs @@ -0,0 +1,52 @@ +-- | +-- Module : JsonLogic.Type +-- Description : Internal JsonLogic types +-- Copyright : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022 +-- License : MIT +-- Maintainer : jelleteeuwissen@hotmail.nl +-- Stability : experimental +module JsonLogic.Type where + +import Control.Monad.Except +import qualified Data.Map as M +import JsonLogic.Json + +-- | An evaluation exception thrown by the evaluator or operations. +-- Is used in the result type. +data Exception + = -- | Exception thrown when an unknown operation is applied. + UnrecognizedOperation {operationName :: String} + | -- | Exception thrown when a rule does not contain exactly one operation. + InvalidRule {operationNames :: [String]} + | -- | Exception thrown for any other error. + EvalException {message :: String} + deriving (Show, Eq) + +-- | The result of a function can be an error or another Json value. +type Result m r = ExceptT Exception m r + +-- | Subevaluator, with rule, its context and resulting Json. +type SubEvaluator m = Rule -> Data -> Result m Json + +-- | A function takes a subevaluator, a rule and data and returns a result. +type Function m r = SubEvaluator m -> Rule -> Data -> Result m r + +-- | Operation is a function with a name. +type Operation m = (String, Function m Json) + +-- | Operations is a Map from the operation name to the operation function. +type Operations m = M.Map String (Function m Json) + +-- | The environment contains the functions and variables our environment has currently +data JsonLogicEnv m = JLEnv + { operations :: Operations m, -- All the operations (plus custom ones) + variables :: Json -- Variables defined in rules + } + +-- | Show the current environment. +instance Show (JsonLogicEnv m) where + show (JLEnv os vs) = "Operations: " ++ show (M.keys os) ++ "\nVariables: " ++ show vs + +-- | Throw an evaluation exception. +throw :: Monad m => String -> Result m a +throw = throwError . EvalException diff --git a/test/Generator/Data.hs b/test/Generator/Data.hs new file mode 100644 --- /dev/null +++ b/test/Generator/Data.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedLists #-} + +module Generator.Data where + +import Data.Map as M (fromList, insert) +import Generator.Generic + ( genGenericJsonBool, + genGenericJsonNumber, + genGenericJsonString, + genGenericNonEmptyJsonString, + ) +import Generator.Utils (genUnbalancedSizeList) +import Hedgehog (Gen, Size (Size)) +import Hedgehog.Gen (choice) +import JsonLogic.Json (Json (..), JsonObject) +import Text.Read (readMaybe) + +-- | Inserts Json into a specific path and returns it +-- If it is arrived at the end of the path then it gives the value back +insertAtPath :: + -- | The path at which to store the json + [String] -> + -- | Json data that needs to get inserted + Json -> + -- | Json object that needs to get updated + Json -> + -- | Updated Json object with inserted Json + Json +-- End of path reached +insertAtPath [] value _ = value +-- Insert value to the map +insertAtPath (p : ps) value (JsonObject o) = case readMaybe p of + Nothing -> JsonObject $ insert p (insertAtPath ps value JsonNull) o + Just i -> JsonArray $ replicate (i :: Int) JsonNull ++ [insertAtPath ps value JsonNull] +-- Insert value into an array +insertAtPath (p : ps) value (JsonArray js) = case readMaybe p of + Nothing -> JsonObject [(p, insertAtPath ps value JsonNull)] + -- Insert it into array if it already has the length + Just i + | i < length js -> + let (xs, ys) = splitAt i js + in -- Replacing the index with the new item, for this we need to drop 1 element at the end + JsonArray $ xs ++ [insertAtPath ps value JsonNull] ++ drop 1 ys + -- Otherwise append items to the list and put it at the end + | otherwise -> JsonArray $ js ++ replicate ((i :: Int) - length js) JsonNull ++ [insertAtPath ps value JsonNull] +-- It is inserting along a new path, denoted with JsonNull +insertAtPath (p : ps) value JsonNull = case readMaybe p of + Nothing -> JsonObject [(p, insertAtPath ps value JsonNull)] + Just i -> JsonArray $ replicate (i :: Int) JsonNull ++ [insertAtPath ps value JsonNull] +-- Data is always an array or an object in the top layer, everything else is wrong +insertAtPath _ _ _ = error "Error invalid Json, your json data is not an array or object" + +-- | Generate random Json given a size +genSizedRandomJson :: Size -> Gen Json +genSizedRandomJson s@(Size size) + -- If size less or equal to 0 a final item is closed + | size <= 0 = + choice + [ return JsonNull, + fst <$> genGenericJsonBool, + fst <$> genGenericJsonNumber, + fst <$> genGenericJsonString + ] + -- If size is greater than 0 we expand with an array or object + | otherwise = + choice + [ genSizedRandomJsonArray s, + JsonObject <$> genSizedRandomJsonObject s + ] + +-- | Generate a Random sized Json array +genSizedRandomJsonArray :: Size -> Gen Json +genSizedRandomJsonArray size = do + sizes <- genUnbalancedSizeList size + JsonArray <$> mapM genSizedRandomJson sizes + +-- | Generate a Random size Json array that does not contain any objects +genSizedNestedJsonArray :: Size -> Gen Json +genSizedNestedJsonArray size + | size <= 0 = + choice + [ return JsonNull, + fst <$> genGenericJsonBool, + fst <$> genGenericJsonNumber, + fst <$> genGenericJsonString + ] + | otherwise = do + sizes <- genUnbalancedSizeList size + JsonArray <$> mapM genSizedNestedJsonArray sizes + +-- | Generate sized Jsonobject entry (pair) +genSizedRandomJsonEntry :: Size -> Gen (String, Json) +genSizedRandomJsonEntry size = do + str <- snd <$> genGenericNonEmptyJsonString + json <- genSizedRandomJson size + return (str, json) + +-- | Generate random Json object with a given size +genSizedRandomJsonObject :: Size -> Gen JsonObject +genSizedRandomJsonObject size = do + sizes <- genUnbalancedSizeList size + M.fromList <$> mapM genSizedRandomJsonEntry sizes + +-- | Generate an array of given size that generates a range array +genSizedJsonNumberArray :: Size -> Gen (Json, [Double]) +genSizedJsonNumberArray (Size size) = do + let arr = [1 .. (1.0 + fromIntegral size)] :: [Double] + return (JsonArray $ map JsonNumber arr, arr) + +-- | Generate a flat array of a given size +genSizedFlatArray :: Size -> Gen Json +genSizedFlatArray (Size size) = JsonArray <$> mapM (\_ -> genSizedRandomJson $ Size 0) [0 .. size] diff --git a/test/Generator/Generic.hs b/test/Generator/Generic.hs new file mode 100644 --- /dev/null +++ b/test/Generator/Generic.hs @@ -0,0 +1,38 @@ +module Generator.Generic where + +import Hedgehog +import Hedgehog.Gen +import Hedgehog.Range as Range +import JsonLogic.Json + +-- | Generator for a JsonNull object +genGenericJsonNull :: Gen (Json, Json) +genGenericJsonNull = return (JsonNull, JsonNull) + +-- | Generator for a random JsonBool object +genGenericJsonBool :: Gen (Json, Bool) +genGenericJsonBool = do + b <- bool + return (JsonBool b, b) + +-- | Generator for a random JsonNumber object +genGenericJsonNumber :: Gen (Json, Double) +genGenericJsonNumber = do + d <- double $ Range.constantFrom 1 10 100 + return (JsonNumber d, d) + +-- | Generator for a random JsonString +genGenericJsonString :: Gen (Json, String) +genGenericJsonString = do + s <- string (Range.constant 0 10) alphaNum + return (JsonString s, s) + +-- | Generator for non-empty JsonStrings +genGenericNonEmptyJsonString :: Gen (Json, String) +genGenericNonEmptyJsonString = do + s <- string (Range.constant 1 10) alphaNum + return (JsonString s, s) + +-- | Generator for empty JsonArrays +genGenericEmptyJsonArray :: Gen (Json, [a]) +genGenericEmptyJsonArray = return (JsonArray [], []) diff --git a/test/Generator/Logic.hs b/test/Generator/Logic.hs new file mode 100644 --- /dev/null +++ b/test/Generator/Logic.hs @@ -0,0 +1,112 @@ +module Generator.Logic where + +import Data.Fixed as F +import qualified Data.Map as M +import Generator.Generic +import Generator.Utils +import Hedgehog +import Hedgehog.Gen +import JsonLogic.Json + +genArithmeticOperator :: Gen (Double -> Double -> Double, [Char]) +genArithmeticOperator = element [((+), "+"), ((-), "-"), ((*), "*"), ((/), "/"), (F.mod', "%")] + +genComparisonOperator :: Gen (Double -> Double -> Bool, [Char]) +genComparisonOperator = element [((<), "<"), ((>), ">"), ((<=), "<="), ((>=), ">=")] + +genBetweenOperator :: Gen (Double -> Double -> Bool, [Char]) +genBetweenOperator = element [((<), "<"), ((<=), "<=")] + +genLogicOperator :: Gen (Bool -> Bool -> Bool, [Char]) +genLogicOperator = element [((&&), "and"), ((||), "or"), ((==), "==="), ((/=), "!==")] + +genArrayOperator :: Gen ([Double] -> Double, [Char]) +genArrayOperator = element [(minimum, "min"), (maximum, "max"), (sum, "sum")] + +-- Generator for a Json object that evaluates to a number +genNumericJson :: Gen (Json, Double) +genNumericJson = sized sizedGenNumericJson + +sizedGenNumericJson :: Size -> Gen (Json, Double) +sizedGenNumericJson s@(Size size) + | size <= 0 = genGenericJsonNumber + | otherwise = + choice + [ createNumericObject "+" (Prelude.+) s, + createNumericObject "-" (Prelude.-) s, + createNumericObject "*" (Prelude.*) s, + createNumericObject "/" (Prelude./) s + ] + +-- Creates numeric Json generator given the operator +createNumericObject :: String -> (Double -> Double -> a) -> Size -> Gen (Json, a) +createNumericObject str op size = do + (s1, s2) <- genUnbalancedSizes size + (j1, x1) <- sizedGenNumericJson s1 + (j2, x2) <- sizedGenNumericJson s2 + return (JsonObject (M.fromList [(str, JsonArray [j1, j2])]), x1 `op` x2) + +-- Generator for a Json object that evaluates to a boolean and only contains comparisons +genComparisonJson :: Gen (Json, Bool) +genComparisonJson = sized sizedGenComparisonJson + +sizedGenComparisonJson :: Size -> Gen (Json, Bool) +sizedGenComparisonJson s@(Size size) + | size <= 0 = genGenericJsonBool + | otherwise = + choice + [ createNumericObject "<" (Prelude.<) s, + createNumericObject ">" (Prelude.>) s, + createNumericObject "<=" (Prelude.<=) s, + createNumericObject ">=" (Prelude.>=) s + ] + +-- Generator for a Json object that evaluates to a boolean and only contains logic operations +genLogicJson :: Gen (Json, Bool) +genLogicJson = sized sizedGenLogicJson + +sizedGenLogicJson :: Size -> Gen (Json, Bool) +sizedGenLogicJson s@(Size size) + | size <= 0 = genGenericJsonBool + | otherwise = + choice + [ createLogicObject "&&" (Prelude.&&) s, + createLogicObject "||" (Prelude.||) s, + createLogicObject "!==" (Prelude./=) s, + createLogicObject "===" (Prelude.==) s + ] + +-- Creates the Logic generator given the operator +createLogicObject :: String -> (Bool -> Bool -> Bool) -> Size -> Gen (Json, Bool) +createLogicObject str op size = do + (s1, s2) <- genUnbalancedSizes size + (j1, x1) <- sizedGenLogicJson s1 + (j2, x2) <- sizedGenLogicJson s2 + return (JsonObject (M.fromList [(str, JsonArray [j1, j2])]), x1 `op` x2) + +-- Generates Json that evaluates to a boolean. Contains both logic and comparison operators +genBoolJson :: Gen (Json, Bool) +genBoolJson = sized sizedGenBoolJson + +sizedGenBoolJson :: Size -> Gen (Json, Bool) +sizedGenBoolJson s@(Size size) + | size <= 0 = genGenericJsonBool + | otherwise = + choice + [ createBoolObject "&&" (Prelude.&&) s, + createBoolObject "||" (Prelude.||) s, + createBoolObject "!==" (Prelude./=) s, + createBoolObject "===" (Prelude.==) s, + createBoolObject "<" (Prelude.<) s, + createBoolObject ">" (Prelude.>) s, + createBoolObject "<=" (Prelude.<=) s, + createBoolObject ">=" (Prelude.>=) s + ] + +-- Creates a generator for json logic given an operator. Can contain out of logic and comparison operators +createBoolObject :: String -> (Bool -> Bool -> Bool) -> Size -> Gen (Json, Bool) +createBoolObject str op size = do + (s1, s2) <- genUnbalancedSizes size + (j1, x1) <- choice [sizedGenLogicJson s1, sizedGenComparisonJson s1] + (j2, x2) <- choice [sizedGenLogicJson s2, sizedGenComparisonJson s2] + return (JsonObject (M.fromList [(str, JsonArray [j1, j2])]), x1 `op` x2) diff --git a/test/Generator/Utils.hs b/test/Generator/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Generator/Utils.hs @@ -0,0 +1,40 @@ +module Generator.Utils where + +import Hedgehog +import Hedgehog.Gen +import qualified Hedgehog.Gen as Gen +import Hedgehog.Range as Range + +-- | Splits size object into two uneven sizes +genUnbalancedSizes :: Size -> Gen (Size, Size) +genUnbalancedSizes (Size size) = do + balanceOffset <- int $ Range.constant (negate size) size + let s1 = Size $ (size + balanceOffset) `div` 2 + s2 = Size $ (size - balanceOffset) `div` 2 + return (s1, s2) + +-- | Generates a list of uneven sizes +genUnbalancedSizeList :: Size -> Gen [Size] +genUnbalancedSizeList (Size size) = do + -- On average contain ~5 items + arrayLength <- int $ Range.constant 1 10 + let elementSize = size `div` arrayLength + (Size <$>) <$> genUnbalancedIntList size elementSize + +-- | Create an unequal list of integers +genUnbalancedIntList :: + -- | How many items are still remaining to get divided + Int -> + -- | The maximum size of a single entry in the list + Int -> + -- | A randomly generated list of integers + Gen [Int] +genUnbalancedIntList remaining maxInt + | remaining <= 0 = return [] + | otherwise = do + chunkSize <- int $ Range.constant 0 $ min remaining maxInt + -- Important! -1 so the size of each element will converge to 0 eventually + (:) chunkSize <$> genUnbalancedIntList (remaining - chunkSize - 1) maxInt + +increaseSizeBy :: Int -> Gen a -> Gen a +increaseSizeBy i = Gen.scale (\(Size s) -> Size $ s + i) diff --git a/test/Operation/Array/TestArrayChecks.hs b/test/Operation/Array/TestArrayChecks.hs new file mode 100644 --- /dev/null +++ b/test/Operation/Array/TestArrayChecks.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedLists #-} + +module Operation.Array.TestArrayChecks where + +import JsonLogic.Json (Json (..)) +import JsonLogic.Pure.Evaluator +import Test.Tasty +import Test.Tasty.HUnit as U + +allUnitTests :: TestTree +allUnitTests = + testGroup + "All unit tests" + [ testCase "logic{\"all\":\"[[], {\">\":[1,2]}]\"} data{}" $ + U.assertEqual + "Empty list case" + (Right $ JsonBool False) + (apply [] (JsonObject [("all", JsonArray [JsonArray [], JsonObject [(">", JsonNumber 2)]])]) JsonNull), + testCase "logic{\"all\":\"[[1,2,3], {\">\":[{\"var\":\"\"}, 0]}]\"} data{}" $ + U.assertEqual + "True case" + (Right $ JsonBool True) + (apply [] (JsonObject [("all", JsonArray [JsonArray [JsonNumber 1, JsonNumber 2, JsonNumber 3], JsonObject [(">", JsonArray [JsonObject [("var", JsonString "")], JsonNumber 0])]])]) JsonNull), + testCase "logic{\"all\":\"[{\"var\":\"x\"}, {\">=\":[{\"var\":\"\"}, 0]}]\"} data{\"x\":[-1,2,3]\"}" $ + U.assertEqual + "False case" + (Right $ JsonBool False) + (apply [] (JsonObject [("all", JsonArray [JsonObject [("var", JsonString "x")], JsonObject [(">=", JsonArray [JsonObject [("var", JsonString "")], JsonNumber 0])]])]) (JsonObject [("x", JsonArray [JsonNumber (-1), JsonNumber 2, JsonNumber 3])])) + ] + +someUnitTests :: TestTree +someUnitTests = + testGroup + "Some unit tests" + [ testCase "logic{\"some\":\"[[], {\">\":[1,2]}]\"} data{}" $ + U.assertEqual + "Empty list case" + (Right $ JsonBool False) + (apply [] (JsonObject [("some", JsonArray [JsonArray [], JsonObject [(">", JsonNumber 2)]])]) JsonNull), + testCase "logic{\"some\":\"[[1,2,3], {\"<\":[{\"var\":\"\"}, 0]}]\"} data{}" $ + U.assertEqual + "False case" + (Right $ JsonBool False) + (apply [] (JsonObject [("some", JsonArray [JsonArray [JsonNumber 1, JsonNumber 2, JsonNumber 3], JsonObject [("<", JsonArray [JsonObject [("var", JsonString "")], JsonNumber 0])]])]) JsonNull), + testCase "logic{\"some\":\"[{\"var\":\"x\"}, {\">\":[{\"var\":\"\"}, 0]}]\"} data{\"x\":[-1,0,1]\"}" $ + U.assertEqual + "True case" + (Right $ JsonBool True) + (apply [] (JsonObject [("some", JsonArray [JsonObject [("var", JsonString "x")], JsonObject [(">", JsonArray [JsonObject [("var", JsonString "")], JsonNumber 0])]])]) (JsonObject [("x", JsonArray [JsonNumber (-1), JsonNumber 0, JsonNumber 1])])), + testCase "logic{\"some\":\"[{\"var\":\"pies\"}, {\"==\":[{\"var\":\"filling\"}, \"apple\"]}]\"} data{\"pies\":[{\"filling\":\"pumpkin\",\"temp\":110},{\"filling\":\"rhubarb\",\"temp\":210},{\"filling\":\"apple\",\"temp\":310}]\"}" $ + U.assertEqual + "Object case" + (Right $ JsonBool True) + (apply [] (JsonObject [("some", JsonArray [JsonObject [("var", JsonString "pies")], JsonObject [("===", JsonArray [JsonObject [("var", JsonString "filling")], JsonString "apple"])]])]) (JsonObject [("pies", JsonArray [JsonObject [("filling", JsonString "pumpkin"), ("temp", JsonNumber 110)], JsonObject [("filling", JsonString "rhubarb"), ("temp", JsonNumber 210)], JsonObject [("filling", JsonString "apple"), ("temp", JsonNumber 310)]])])) + ] + +noneUnitTests :: TestTree +noneUnitTests = + testGroup + "None unit tests" + [ testCase "logic{\"none\":\"[[], {\">\":[1,2]}]\"} data{}" $ + U.assertEqual + "Empty list case" + (Right $ JsonBool True) + (apply [] (JsonObject [("none", JsonArray [JsonArray [], JsonObject [(">", JsonNumber 2)]])]) JsonNull), + testCase "logic{\"none\":\"[[-3,-2,-1], {\">\":[{\"var\":\"\"}, 0]}]\"} data{}" $ + U.assertEqual + "True case" + (Right $ JsonBool True) + (apply [] (JsonObject [("none", JsonArray [JsonArray [JsonNumber (-3), JsonNumber (-2), JsonNumber (-1)], JsonObject [(">", JsonArray [JsonObject [("var", JsonString "")], JsonNumber 0])]])]) JsonNull), + testCase "logic{\"none\":\"[{\"var\":\"x\"}, {\"<=\":[{\"var\":\"\"}, 0]}]\"} data{\"x\":[-1,2,3]\"}" $ + U.assertEqual + "False case" + (Right $ JsonBool False) + (apply [] (JsonObject [("none", JsonArray [JsonObject [("var", JsonString "x")], JsonObject [("<=", JsonArray [JsonObject [("var", JsonString "")], JsonNumber 0])]])]) (JsonObject [("x", JsonArray [JsonNumber (-1), JsonNumber 2, JsonNumber 3])])) + ] diff --git a/test/Operation/Array/TestFilter.hs b/test/Operation/Array/TestFilter.hs new file mode 100644 --- /dev/null +++ b/test/Operation/Array/TestFilter.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedLists #-} + +module Operation.Array.TestFilter where + +import JsonLogic.Json +import JsonLogic.Pure.Evaluator +import Test.Tasty +import Test.Tasty.HUnit as U + +filterUnitTests :: TestTree +filterUnitTests = + testGroup + "Filter unit tests" + [ testCase "Boolean filter values" $ + U.assertEqual + "Return True elements" + (Right $ JsonArray [JsonBool True, JsonBool True]) + ( apply + [] + ( JsonObject + [ ( "filter", + JsonArray + [ JsonArray [JsonBool True, JsonBool False, JsonBool True], + JsonObject [("var", JsonString "")] + ] + ) + ] + ) + JsonNull + ), + testCase "Smaller than filter values" $ + U.assertEqual + "Only the first item is < 2" + (Right $ JsonArray [JsonNumber 1]) + ( apply + [] + ( JsonObject + [ ( "filter", + JsonArray + [ JsonArray [JsonNumber 1, JsonNumber 3], + JsonObject [("<", JsonArray [JsonObject [("var", JsonString "")], JsonNumber 2])] + ] + ) + ] + ) + JsonNull + ), + testCase "applyuate array values" $ + U.assertEqual + "The array value gets applyuated to True and returned." + (Right $ JsonArray [JsonBool True]) + ( apply + [] + ( JsonObject + [ ( "filter", + JsonArray + [ JsonArray + [ JsonBool False, + JsonObject [("<", JsonArray [JsonNumber 1, JsonNumber 2])] + ], + JsonObject [("var", JsonString "")] + ] + ) + ] + ) + JsonNull + ), + testCase "Empty array" $ + U.assertEqual + "No errors occur when handed an empty array" + (Right $ JsonArray []) + ( apply + [] + ( JsonObject + [ ( "filter", + JsonArray + [ JsonArray [], + JsonObject [("var", JsonString "")] + ] + ) + ] + ) + JsonNull + ), + testCase "Two consecutive filters" $ + U.assertEqual + "Two consecutive filter more." + (Right $ JsonArray [JsonNumber 2]) + ( apply + [] + ( JsonObject + [ ( "filter", + JsonArray + [ JsonObject + [ ( "filter", + JsonArray + [ JsonArray [JsonNumber 1, JsonNumber 2, JsonNumber 3], + JsonObject [("<=", JsonArray [JsonObject [("var", JsonString "")], JsonNumber 2])] + ] + ) + ], + JsonObject [(">=", JsonArray [JsonObject [("var", JsonString "")], JsonNumber 2])] + ] + ) + ] + ) + JsonNull + ) + ] diff --git a/test/Operation/Array/TestIn.hs b/test/Operation/Array/TestIn.hs new file mode 100644 --- /dev/null +++ b/test/Operation/Array/TestIn.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedLists #-} + +module Operation.Array.TestIn where + +import qualified Data.List as L +import Generator.Generic +import Hedgehog (forAll, property, (===)) +import JsonLogic.Json (Json (..)) +import JsonLogic.Pure.Evaluator +import Test.Tasty +import Test.Tasty.HUnit as U +import Utils + +inUnitTests :: TestTree +inUnitTests = + testGroup + "In unit tests" + [ testCase "logic{\"in\":\"[\"\", \"test\"]\"} data{}" $ + U.assertEqual + "Empty string case" + (Right $ JsonBool True) + (apply [] (JsonObject [("in", JsonArray [JsonString "", JsonString "test"])]) JsonNull), + testCase "logic{\"in\":\"[\"Spring\", \"Springfield\"]\"} data{}" $ + U.assertEqual + "True case" + (Right $ JsonBool True) + (apply [] (JsonObject [("in", JsonArray [JsonString "Spring", JsonString "Springfield"])]) JsonNull), + testCase "logic{\"in\":\"[\"Test\", {\"var\":\"x\"}]\"} data{\"x\":\"testcase\"}" $ + U.assertEqual + "False case" + (Right $ JsonBool False) + (apply [] (JsonObject [("in", JsonArray [JsonString "Test", JsonObject [("var", JsonString "x")]])]) (JsonObject [("x", JsonString "testcase")])), + testCase "logic{\"in\":\"[\"\", []]\"} data{}" $ + U.assertEqual + "Empty string case" + (Right $ JsonBool False) + (apply [] (JsonObject [("in", JsonArray [JsonString "", JsonArray []])]) JsonNull), + testCase "logic{\"in\":\"[\"Ringo\", [\"John\", \"Paul\", \"George\", \"Ringo\"]]\"} data{}" $ + U.assertEqual + "True case" + (Right $ JsonBool True) + (apply [] (JsonObject [("in", JsonArray [JsonString "Ringo", JsonArray [JsonString "John", JsonString "Paul", JsonString "George", JsonString "Ringo"]])]) JsonNull), + testCase "logic{\"in\":\"[\"Ringo\", {\"var\":\"x\"}]\"} data{\"x\":[\"John\", \"Paul\", \"George\"]}" $ + U.assertEqual + "False case" + (Right $ JsonBool False) + (apply [] (JsonObject [("in", JsonArray [JsonString "Ringo", JsonObject [("var", JsonString "x")]])]) (JsonObject [("x", JsonArray [JsonString "John", JsonString "Paul", JsonString "George"])])) + ] + +inGeneratorTests :: TestTree +inGeneratorTests = + testGroup + "In generator tests" + [ hTestProperty "in strings" $ + property $ do + (jsonString1, string1) <- forAll genGenericJsonString + (jsonString2, string2) <- forAll genGenericJsonString + let rule = JsonObject [("in", JsonArray [jsonString1, jsonString2])] + expected = JsonBool (string1 `L.isInfixOf` string2) + Right expected === apply [] rule JsonNull + ] diff --git a/test/Operation/Array/TestMerge.hs b/test/Operation/Array/TestMerge.hs new file mode 100644 --- /dev/null +++ b/test/Operation/Array/TestMerge.hs @@ -0,0 +1,71 @@ +module Operation.Array.TestMerge where + +import Generator.Data +import Hedgehog as H (assert, failure, forAll, property, (===)) +import qualified Hedgehog.Gen as Gen +import JsonLogic.Json +import JsonLogic.Pure.Evaluator +import Test.Tasty +import Test.Tasty.HUnit as U +import Utils + +mergeUnitTests :: TestTree +mergeUnitTests = + testGroup + "merge unit tests" + [ testCase "logic {\"merge\":[]} data {} => []" $ + U.assertEqual + "empty case" + (Right $ jArr []) + (apply [] (jObj [("merge", jArr [])]) (jObj [])), + testCase "logic {\"merge\":[[1,2],[3,4]} data null => [1,2,3,4]" $ + U.assertEqual + "first test case on site" + (Right $ jArr [jNum 1, jNum 2, jNum 3, jNum 4]) + (apply [] (jObj [("merge", jArr [jArr [jNum 1, jNum 2], jArr [jNum 3, jNum 4]])]) jNull), + testCase "logic {\"merge\":[1,2,[3,4]} data null => [1,2,3,4]" $ + U.assertEqual + "second test case on site" + (Right $ jArr [jNum 1, jNum 2, jNum 3, jNum 4]) + (apply [] (jObj [("merge", jArr [jNum 1, jNum 2, jArr [jNum 3, jNum 4]])]) jNull), + testCase "logic {\"missing\" :{ \"merge\" : [\"vin\",{\"if\": [{\"var\":\"financing\"}, [\"apr\", \"term\"], [] ]}]}} data {\"financing\":true} => [\"vin\", \"apr\", \"term\"]" $ + U.assertEqual + "third test case on site" + (Right $ jArr [jStr "vin", jStr "apr", jStr "term"]) + (apply [] (jObj [("missing", jObj [("merge", jArr [jStr "vin", jObj [("if", jArr [jObj [("var", jStr "financing")], jArr [jStr "apr", jStr "term"], jArr []])]])])]) (jObj [("financing", jBool True)])), + testCase "logic {\"missing\" :{ \"merge\" : [\"vin\",{\"if\": [{\"var\":\"financing\"}, [\"apr\", \"term\"], [] ]}]}} data {\"financing\":false} => [\"vin\"]" $ + U.assertEqual + "fourth test case on site" + (Right $ jArr [jStr "vin"]) + (apply [] (jObj [("missing", jObj [("merge", jArr [jStr "vin", jObj [("if", jArr [jObj [("var", jStr "financing")], jArr [jStr "apr", jStr "term"], jArr []])]])])]) (jObj [("financing", jBool False)])) + ] + +mergeGeneratorTests :: TestTree +mergeGeneratorTests = + testGroup + "merge generator tests" + -- Merging a flat array does not change the array at all + [ hTestProperty "merge a flat array stays the same" $ + property $ do + jsonData <- forAll $ Gen.sized genSizedFlatArray + let rule = jObj [("merge", jsonData)] + Right jsonData === apply [] rule jsonData, + -- Merging flattens the array at one layer, but never returns a non-list + hTestProperty "merging decreases the nesting with one" $ + property $ do + jsonData <- forAll $ Gen.sized genSizedNestedJsonArray + let rule = jObj [("merge", jsonData)] + case apply [] rule jsonData of + Right res -> do + -- The depth should be at least 1 (should return a list) + H.assert $ maxJsonDepth res >= 1 + -- The depth of the resulting list decreases the maximum depth by 1 + H.assert $ maxJsonDepth res == max 1 (maxJsonDepth jsonData - 1) + -- A nested list merge never fails + _ -> H.failure + ] + +-- | Computes the maximum nesting of a Json array +maxJsonDepth :: Json -> Int +maxJsonDepth (JsonArray as) = 1 + foldl (\a b -> max a $ maxJsonDepth b) 0 as +maxJsonDepth _ = 0 diff --git a/test/Operation/Array/TestReduce.hs b/test/Operation/Array/TestReduce.hs new file mode 100644 --- /dev/null +++ b/test/Operation/Array/TestReduce.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedLists #-} + +module Operation.Array.TestReduce where + +import JsonLogic.Pure.Evaluator +import JsonLogic.Pure.Type (Exception (EvalException)) +import Test.Tasty +import Test.Tasty.HUnit as U +import Utils + +reduceUnitTests :: TestTree +reduceUnitTests = + testGroup + "reduce unit tests" + [ testCase "logic {reduce\":[{\"var\":\"integers\"}, {\"+\":[{\"var\":\"current\"}, {\"var\":\"accumulator\"}]}, 0 ]} data {\"integers\":[1,2,3,4,5]}" $ + U.assertEqual + "sums to 15" + (Right $ jNum 15) + (apply [] (jObj [("reduce", jArr [jObj [("var", jStr "integers")], jObj [("+", jArr [jObj [("var", jStr "current")], jObj [("var", jStr "accumulator")]])], jNum 0])]) (jObj [("integers", jArr [jNum 1, jNum 2, jNum 3, jNum 4, jNum 5])])), + testCase "Reduce right to left" $ + U.assertEqual + "reduces right to left" + (Right $ jNum 1.5) + (apply [] (jObj [("reduce", jArr [jObj [("var", jStr "integers")], jObj [("/", jArr [jObj [("var", jStr "current")], jObj [("var", jStr "accumulator")]])], jNum 1])]) (jObj [("integers", jArr [jNum 2, jNum 3])])), + testCase "Errors with invalid arguments" $ + U.assertEqual + "Default value missing" + (Left $ EvalException "Wrong number of arguments for reduce") + (apply [] (jObj [("reduce", jArr [jObj [("var", jStr "integers")], jObj [("/", jArr [jObj [("var", jStr "current")], jObj [("var", jStr "accumulator")]])]])]) jNull), + testCase "Evaluate initial value" $ + U.assertEqual + "Initial value evaluates to 1" + (Right $ jNum 6) + (apply [] (jObj [("reduce", jArr [jObj [("var", jStr "integers")], jObj [("+", jArr [jObj [("var", jStr "current")], jObj [("var", jStr "accumulator")]])], jObj [("var", jStr "integer")]])]) (jObj [("integer", jNum 1), ("integers", jArr [jNum 2, jNum 3])])), + testCase "Empty list" $ + U.assertEqual + "Returns initial value" + (Right $ jStr "abc") + (apply [] (jObj [("reduce", jArr [jObj [("var", jStr "integers")], jObj [("+", jArr [jObj [("var", jStr "current")], jObj [("var", jStr "accumulator")]])], jStr "abc"])]) (jObj [("integers", jArr [])])) + ] diff --git a/test/Operation/Boolean/TestEquality.hs b/test/Operation/Boolean/TestEquality.hs new file mode 100644 --- /dev/null +++ b/test/Operation/Boolean/TestEquality.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedLists #-} + +module Operation.Boolean.TestEquality where + +import JsonLogic.Json +import JsonLogic.Pure.Evaluator +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import qualified Test.Tasty.HUnit as U + +-- See https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Equality +equalityUnitTests :: TestTree +equalityUnitTests = + testGroup + "Equality unit tests" + [ testCase "Numbers" $ assertEqual (JsonNumber 1) (JsonNumber 1) True, + testCase "Strings" $ assertEqual (JsonString "hello") (JsonString "hello") True, + testCase "Strings and Numbers" $ assertEqual (JsonString "1") (JsonNumber 1) True, + testCase "Numbers and Bools" $ assertEqual (JsonNumber 0) (JsonBool False) True, + testCase "Numbers and Null" $ assertEqual (JsonNumber 0) JsonNull False, + testCase "Numbers and not not Null" $ assertEqual (JsonNumber 0) (JsonObject [("!!", JsonNull)]) True, + testCase "Objects" $ assertEqual (JsonObject [("preserve", JsonObject [("key", JsonString "value")])]) (JsonObject [("preserve", JsonObject [("key", JsonString "value")])]) True + ] + +assertEqual :: Json -> Json -> Bool -> U.Assertion +assertEqual l r b = + U.assertEqual + "Result is correct" + (Right $ JsonBool b) + (apply [] (JsonObject [("==", JsonArray [l, r])]) JsonNull) diff --git a/test/Operation/Boolean/TestIf.hs b/test/Operation/Boolean/TestIf.hs new file mode 100644 --- /dev/null +++ b/test/Operation/Boolean/TestIf.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedLists #-} + +module Operation.Boolean.TestIf where + +import JsonLogic.Json +import JsonLogic.Pure.Evaluator +import Test.Tasty +import Test.Tasty.HUnit as U + +ifUnitTests :: TestTree +ifUnitTests = + testGroup + "If unit tests" + [ testCase "if with jsonbool" $ + U.assertEqual + "condition is true and first value is returned" + (Right $ JsonNumber 1) + (apply [] (JsonObject [("if", JsonArray [JsonBool True, JsonNumber 1, JsonNumber 2])]) JsonNull), + testCase "if with rule as condition" $ + U.assertEqual + "rule is evaluated to false and second value is returned" + (Right $ JsonNumber 2) + (apply [] (JsonObject [("if", JsonArray [JsonObject [(">=", JsonArray [JsonNumber 1, JsonNumber 2])], JsonNumber 1, JsonNumber 2])]) JsonNull), + testCase "if with undefined value" $ + U.assertEqual + "only first value is and undefined is not" + (Right $ JsonBool True) + (apply [] (JsonObject [("if", JsonArray [JsonObject [("<=", JsonArray [JsonNumber 1, JsonNumber 2])], JsonBool True, JsonNumber undefined])]) JsonNull), + testCase "if with rule as value" $ + U.assertEqual + "rule gets evaluated" + (Right $ JsonBool True) + (apply [] (JsonObject [("if", JsonArray [JsonBool True, JsonObject [("<=", JsonArray [JsonNumber 1, JsonNumber 2])], JsonNumber 2])]) JsonNull) + ] diff --git a/test/Operation/Boolean/TestNegation.hs b/test/Operation/Boolean/TestNegation.hs new file mode 100644 --- /dev/null +++ b/test/Operation/Boolean/TestNegation.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedLists #-} + +module Operation.Boolean.TestNegation where + +import Generator.Data +import Hedgehog (forAll, property, (===)) +import qualified Hedgehog.Gen as Gen +import JsonLogic.Json +import JsonLogic.Pure.Evaluator +import Test.Tasty +import Test.Tasty.HUnit +import qualified Test.Tasty.HUnit as U +import Utils + +negationUnitTests :: TestTree +negationUnitTests = + testGroup + "negation unit tests" + [ testCase "logic: {\"!\": [true]} data: null" $ + U.assertEqual + "Negated true is false" + (Right (JsonBool False)) + (apply [] (JsonObject [("!", JsonArray [JsonBool True])]) JsonNull), + testCase "logic: {\"!\": true} data: null" $ + U.assertEqual + "Negated true is false" + (Right (JsonBool False)) + (apply [] (JsonObject [("!", JsonBool True)]) JsonNull), + testCase "logic: {\"!!\": [ [] ] } data: null" $ + U.assertEqual + "Empty array is false" + (Right (JsonBool False)) + (apply [] (JsonObject [("!!", JsonArray [JsonArray []])]) JsonNull), + testCase "logic: {\"!!\": [\"0\"] } data: null" $ + U.assertEqual + "Non empty array is true" + (Right (JsonBool True)) + (apply [] (JsonObject [("!!", JsonArray [JsonString "0"])]) JsonNull) + ] + +negationGeneratorTests :: TestTree +negationGeneratorTests = + testGroup + "negation generator tests" + [ hTestProperty "negation works" $ + property $ do + paramJson <- forAll $ Gen.sized genSizedRandomJson + Right (JsonBool $ isFalsy paramJson) === apply [] (JsonObject [("!", JsonObject [("preserve", paramJson)])]) JsonNull, + hTestProperty "double negation works" $ + property $ do + paramJson <- forAll $ Gen.sized genSizedRandomJson + Right (JsonBool $ isTruthy paramJson) === apply [] (JsonObject [("!!", JsonObject [("preserve", paramJson)])]) JsonNull + ] diff --git a/test/Operation/Data/TestMissing.hs b/test/Operation/Data/TestMissing.hs new file mode 100644 --- /dev/null +++ b/test/Operation/Data/TestMissing.hs @@ -0,0 +1,112 @@ +module Operation.Data.TestMissing where + +import qualified Data.Map as M +import Generator.Data +import Generator.Generic +import Generator.Utils +import Hedgehog (forAll, property, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import JsonLogic.Json +import JsonLogic.Pure.Evaluator +import Test.Tasty +import Test.Tasty.HUnit as U +import Text.Read (readMaybe) +import Utils + +missingUnitTests :: TestTree +missingUnitTests = + testGroup + "missing unit tests" + [ testCase "logic {\"missing\":[]} data {} => []" $ + U.assertEqual + "empty case" + (Right $ jArr []) + (apply [] (jObj [("missing", jArr [])]) (jObj [])), + testCase "logic {\"missing\":[\"a\", \"b\"]} data {\"a\":\"apple\", \"c\":\"carrot\"} => [\"b\"]" $ + U.assertEqual + "first test case on site" + (Right $ jArr [jStr "b"]) + (apply [] (jObj [("missing", jArr [jStr "a", jStr "b"])]) (jObj [("a", jStr "apple"), ("c", jStr "carrot")])), + testCase "logic {\"missing\":[\"a\", \"b\"]} data {\"a\":\"apple\", \"b\":\"banana\"} => []" $ + U.assertEqual + "second test case on site" + (Right $ jArr []) + (apply [] (jObj [("missing", jArr [jStr "a", jStr "b"])]) (jObj [("a", jStr "apple"), ("b", jStr "banana")])), + testCase "logic {\"missing\":[0, 1]} data [\"apple\", \"banana\"] => []" $ + U.assertEqual + "missing in lists" + (Right $ jArr []) + (apply [] (jObj [("missing", jArr [jNum 0, jNum 1])]) (jArr [jStr "apple", jStr "banana"])), + testCase "logic {\"missing\":[0, 1]} data [\"apple\"] => [1]" $ + U.assertEqual + "missing in lists" + (Right $ jArr [jNum 1]) + (apply [] (jObj [("missing", jArr [jNum 0, jNum 1])]) (jArr [jStr "apple"])), + testCase "logic {\"if\":[{\"missing\":[\"a\", \"b\"]}, \"Not enough fruit\", \"OK to proceed\"]} data {\"a\":\"apple\", \"b\":\"banana\"} => \"Ok to proceed\"" $ + U.assertEqual + "third test case on site" + (Right $ jStr "OK to proceed") + (apply [] (jObj [("if", jArr [jObj [("missing", jArr [jStr "a", jStr "b"])], jStr "Not enough fruit", jStr "OK to proceed"])]) (jObj [("a", jStr "apple"), ("b", jStr "banana")])) + ] + +missingGeneratorTests :: TestTree +missingGeneratorTests = + testGroup + "missing generator tests" + [ hTestProperty "missing over emty" $ + property $ do + -- Create rule and data + let missingEmpty = jObj [("missing", jArr [])] + dataJsonArray <- forAll $ Gen.sized genSizedRandomJsonArray + dataJsonObject <- forAll $ Gen.sized genSizedRandomJsonObject + -- Empty rule over any data returns empty array + Right (jArr []) === apply [] missingEmpty dataJsonArray + Right (jArr []) === apply [] missingEmpty (JsonObject dataJsonObject), + hTestProperty "Using integer index on array" $ + property $ do + -- Generate random data + jsonData <- forAll $ Gen.sized genSizedRandomJson + -- Create the rule + x <- forAll $ Gen.int $ Range.constant 0 30 + let rule = jObj [("missing", jArr [jNum $ fromIntegral x])] + -- Only returns empty array if the index is missing + case jsonData of + (JsonArray js) | x < length js -> Right (jArr []) === apply [] rule jsonData + (JsonString s) | x < length s -> Right (jArr []) === apply [] rule jsonData + -- If the index is a number and that index is in the dict it is indexed + (JsonObject o) | M.member (show x) o -> Right (jArr []) === apply [] rule jsonData + _ -> Right (jArr [jNum $ fromIntegral x]) === apply [] rule jsonData, + hTestProperty "Using string index on array" $ + property $ do + -- Generate random array + jsonData@(JsonArray js) <- forAll $ Gen.sized genSizedRandomJsonArray + (indexJson, indexStr) <- forAll genGenericNonEmptyJsonString + -- Item should be in result since it cannot be present + let rule = jObj [("missing", jArr [indexJson])] + case readMaybe indexStr :: Maybe Int of + -- The string is by chance a number, if it is within the range the index is succesful + Just i | i >= 0 && i < length js -> Right (jArr []) === apply [] rule jsonData + -- Index is not present since it is a string or outside the range + _ -> Right (jArr [indexJson]) === apply [] rule jsonData, + hTestProperty "Using string index on object" $ + property $ do + -- Generate data + jsonData <- forAll $ increaseSizeBy 1 $ Gen.sized genSizedRandomJsonObject + -- Choose a random item from the object + indexStr <- forAll $ Gen.element $ M.keys jsonData + let rule = jObj [("missing", jArr [jStr indexStr])] + -- The item should not be missing + Right (jArr []) === apply [] rule (JsonObject jsonData), + hTestProperty "Using integer index on object" $ + property $ do + -- Random data + jsonData <- forAll $ Gen.sized genSizedRandomJsonObject + -- Generate random index + x <- forAll $ Gen.int $ Range.constant 0 30 + let rule = jObj [("missing", jArr [jNum $ fromIntegral x])] + -- Item should be missing + if M.member (show x) jsonData + then Right (jArr []) === apply [] rule (JsonObject jsonData) + else Right (jArr [jNum $ fromIntegral x]) === apply [] rule (JsonObject jsonData) + ] diff --git a/test/Operation/Data/TestMissingSome.hs b/test/Operation/Data/TestMissingSome.hs new file mode 100644 --- /dev/null +++ b/test/Operation/Data/TestMissingSome.hs @@ -0,0 +1,103 @@ +module Operation.Data.TestMissingSome (missingSomeUnitTests, missingSomeGeneratorTests) where + +import Generator.Data +import Generator.Generic (genGenericJsonNumber) +import Generator.Utils +import Hedgehog (Gen, forAll, property, (===)) +import qualified Hedgehog as H (assert, failure) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import JsonLogic.Json +import JsonLogic.Pure.Evaluator +import Test.Tasty +import Test.Tasty.HUnit as U +import Utils + +missingSomeUnitTests :: TestTree +missingSomeUnitTests = + testGroup + "missing_some unit tests" + [ testCase "logic {\"missing_some\":[1, []]} data {} => []" $ + U.assertEqual + "empty case" + (Right $ jArr []) + (apply [] (jObj [("missing_some", jArr [jNum 0, jArr []])]) (jObj [])), + testCase "logic {\"missing_some\":[1, [\"a\", \"b\", \"c\"]]} data {\"a\":\"apple\"} => [\"b\",\"c\"]" $ + U.assertEqual + "first test case on site" + (Right $ jArr []) + (apply [] (jObj [("missing_some", jArr [jNum 1, jArr [jStr "a", jStr "b", jStr "c"]])]) (jObj [("a", jStr "apple")])), + testCase "logic {\"missing_some\":[2, [\"a\", \"b\", \"c\"]]} data {\"a\":\"apple\"} => [\"b\",\"c\"]" $ + U.assertEqual + "second test case on site" + (Right $ jArr [jStr "b", jStr "c"]) + (apply [] (jObj [("missing_some", jArr [jNum 2, jArr [jStr "a", jStr "b", jStr "c"]])]) (jObj [("a", jStr "apple")])), + testCase + ( "logic {\"if\" :[{\"merge\": [{\"missing\":[\"first_name\", \"last_name\"]},{\"missing_some\":[1, [\"cell_phone\", \"home_phone\"] ]}]}, \"We require first name, last name, and one phone number.\",\"OK to proceed\"]}" + ++ "data {\"first_name\":\"Bruce\", \"last_name\":\"Wayne\"} => \"We require first name, last name, and one phone number.\"" + ) + $ U.assertEqual + "third test case on site" + (Right $ jStr "We require first name, last name, and one phone number.") + (apply [] (jObj [("if", jArr [jObj [("merge", jArr [jObj [("missing", jArr [jStr "first_name", jStr "last_name"])], jObj [("missing_some", jArr [jNum 1, jArr [jStr "cell_phone", jStr "home_phone"]])]])], jStr "We require first name, last name, and one phone number.", jStr "OK to proceed"])]) (jObj [("first_name", jStr "Bruce"), ("last_name", jStr "Wayne")])) + ] + +missingSomeGeneratorTests :: TestTree +missingSomeGeneratorTests = + testGroup + "missing_some generator tests" + [ hTestProperty "missing_some over empty" $ + property $ do + -- Missing some over random integer + (jsonNumber, _) <- forAll genGenericJsonNumber + let missingSomeEmpty = jObj [("missing_some", jArr [jsonNumber, jArr []])] + -- Random Json data + dataJsonArray <- forAll $ Gen.sized genSizedRandomJsonArray + dataJsonObject <- forAll $ Gen.sized genSizedRandomJsonObject + -- Indexing empty missing_some over random data returns empty array + Right (jArr []) === apply [] missingSomeEmpty dataJsonArray + Right (jArr []) === apply [] missingSomeEmpty (JsonObject dataJsonObject), + hTestProperty "missing_some when all keys are present" $ + property $ do + -- Generate flat array as data + jsonData@(JsonArray js) <- forAll $ increaseSizeBy 1 $ Gen.sized genSizedFlatArray + -- Generate a random list of indexes + indexes <- forAll $ genRandomJsonIndexes (0, length js - 1) + -- Missing a random integer when all are present will result in an empty array + x <- forAll $ Gen.int $ Range.constant 0 30 + let rule = jObj [("missing_some", jArr [jNum $ fromIntegral x, jArr indexes])] + Right (jArr []) === apply [] rule jsonData, + hTestProperty "missing_some when no keys are present" $ + property $ do + -- Generate a flat array as data + jsonData@(JsonArray js) <- forAll $ increaseSizeBy 1 $ Gen.sized genSizedFlatArray + -- Generates random list of indexes + missingIndexes <- forAll $ genRandomJsonIndexes (length js, length js * 2) + -- Construct rule + nrMissing <- forAll $ Gen.int $ Range.constant 1 30 + let rule = jObj [("missing_some", jArr [jNum $ fromIntegral nrMissing, JsonArray missingIndexes])] + -- Always should return entire list of missing items + Right (jArr missingIndexes) === apply [] rule jsonData, + hTestProperty "missing_some when some keys are present" $ + property $ do + -- Generate a flat array as data + jsonData@(JsonArray js) <- forAll $ increaseSizeBy 1 $ Gen.sized genSizedFlatArray + -- On average half of the indexes are missing and half of the indexes are present + presentIndexes <- forAll $ genRandomJsonIndexes (0, length js - 1) + missingIndexes <- forAll $ genRandomJsonIndexes (length js, length js * 2) + -- The amount of items required is put in a rule + nrRequired <- forAll $ fromIntegral <$> (Gen.int $ Range.constant 0 (length js * 2) :: Gen Int) + let rule = jObj [("missing_some", jArr [jNum nrRequired, JsonArray $ presentIndexes ++ missingIndexes])] + -- Evaluate the rule with the data + case apply [] rule jsonData of + -- If there are more indexes present than the number required then it returns an empty array. + Right (JsonArray []) -> H.assert $ fromIntegral (length presentIndexes) >= nrRequired || null missingIndexes + -- Otherwise it returns all the missing items + res@(Right (JsonArray _)) -> Right (jArr missingIndexes) === res + -- Should never return any other type + _ -> H.failure + ] + +-- | Given a range, generate a random Json list with these indexes as numbers +genRandomJsonIndexes :: (Int, Int) -> Gen [Json] +genRandomJsonIndexes (lowerBound, upperBound) = map (JsonNumber . fromIntegral) <$> Gen.subsequence [lowerBound .. upperBound] diff --git a/test/Operation/Data/TestPreserve.hs b/test/Operation/Data/TestPreserve.hs new file mode 100644 --- /dev/null +++ b/test/Operation/Data/TestPreserve.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedLists #-} + +module Operation.Data.TestPreserve where + +import Generator.Data +import Hedgehog (forAll, property, (===)) +import qualified Hedgehog.Gen as Gen +import JsonLogic.Json +import JsonLogic.Pure.Evaluator +import Test.Tasty +import Utils + +preserveGeneratorTests :: TestTree +preserveGeneratorTests = + testGroup + "preserve generator tests" + [ hTestProperty "preserve works" $ + property $ do + paramJson <- forAll $ Gen.sized genSizedRandomJson + Right paramJson === apply [] (JsonObject [("preserve", paramJson)]) JsonNull + ] diff --git a/test/Operation/Data/TestVar.hs b/test/Operation/Data/TestVar.hs new file mode 100644 --- /dev/null +++ b/test/Operation/Data/TestVar.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE OverloadedLists #-} + +module Operation.Data.TestVar where + +import qualified Data.List as L +import Generator.Data +import Generator.Generic +import Hedgehog (forAll, property, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import JsonLogic.Json +import JsonLogic.Pure.Evaluator +import Test.Tasty +import Test.Tasty.HUnit as U +import Utils + +varUnitTests :: TestTree +varUnitTests = + testGroup + "Var unit tests" + -- logic {"var":""} data 1 => 1 + [ testCase "logic {\"var\":\"\"} data {\"x\":1}" $ + U.assertEqual + "Simple var case is correct" + (Right $ JsonNumber 1) + (apply [] (JsonObject [("var", JsonString "")]) (JsonNumber 1)), + -- logic {"var":"x"} data 1 => Null + testCase "logic {\"var\":\"x\"} data {\"x\":1}" $ + U.assertEqual + "Simple var case is correct" + (Right JsonNull) + (apply [] (JsonObject [("var", JsonString "x")]) (JsonNumber 1)), + -- logic {"var":true} data 1 => Null + testCase "logic {\"var\":true} data {\"x\":1}" $ + U.assertEqual + "Simple var case is correct" + (Right JsonNull) + (apply [] (JsonObject [("var", JsonBool True)]) (JsonNumber 1)), + -- logic {"var":"x"} data{"x":1} => 1 + testCase "logic {\"var\":\"x\"} data {\"x\":1}" $ + U.assertEqual + "Simple var case is correct" + (Right $ JsonNumber 1) + (apply [] (JsonObject [("var", JsonString "x")]) (JsonObject [("x", JsonNumber 1)])), + -- logic {"var":"x"} => Null + testCase "logic {\"var\":\"x\"} data {}" $ + U.assertEqual + "Empty data gives Null" + (Right JsonNull) + (apply [] (JsonObject [("var", JsonString "x")]) JsonNull), + -- logic {"var":"x"} data {"x":[1,2,3]} => [1,2,3] + testCase "logic {\"var\":\"x\"} data {\"x\":[1,2,3]\"}" $ + U.assertEqual + "Substitutes arraytype correctly" + (Right $ JsonArray [JsonNumber 1, JsonNumber 2, JsonNumber 3]) + (apply [] (JsonObject [("var", JsonString "x")]) (JsonObject [("x", JsonArray [JsonNumber 1, JsonNumber 2, JsonNumber 3])])), + -- logic {"var":"x.y"} data {"x":{"y":1}} => 1 + testCase "logic {\"var\":\"x.y\"} data {\"x\":{\"y\":1}\"}" $ + U.assertEqual + "Access nested parameter 'x.y'" + (Right $ JsonNumber 1) + (apply [] (JsonObject [("var", JsonString "x.y")]) (JsonObject [("x", JsonObject [("y", JsonNumber 1)])])), + -- logic {"var":"y"} data {"x":{"y":1}} => Null + testCase "logic {\"var\":\"y\"} data {\"x\":{\"y\":1}\"}" $ + U.assertEqual + "Parameter not accessed on correct level" + (Right JsonNull) + (apply [] (JsonObject [("var", JsonString "y")]) $ JsonObject [("x", JsonObject [("y", JsonNumber 1)])]), + -- logic {"var":{}} data 1 => Null + testCase "logic {\"var\":[]} data 1 " $ + U.assertEqual + "Indexing with an object returns null" + (Right $ JsonNumber 1) + (apply [] (JsonObject [("var", JsonArray [])]) $ JsonNumber 1), + -- logic {"var":{}} data 1 => Null + testCase "logic {\"var\":{}} data 1 " $ + U.assertEqual + "Indexing with an object returns null" + (Right JsonNull) + (apply [] (JsonObject [("var", JsonObject [])]) $ JsonNumber 1), + -- logic {"var":[["y"]]} data {"y":{"y":1}} => Null + testCase "logic {\"var\":[[\"y\"]]} data {\"y\":{\"y\":1}\"}" $ + U.assertEqual + "Indexing with nested array gives back null" + (Right JsonNull) + (apply [] (JsonObject [("var", JsonObject [])]) $ JsonObject [("y", JsonObject [("y", JsonNumber 1)])]), + -- logic {"var":["", true]} data null => Null + testCase "logic {\"var\":[\"\", true]} data null" $ + U.assertEqual + "null value does not always return backup" + (Right JsonNull) + (apply [] (JsonObject [("var", JsonArray [JsonString "", JsonBool True])]) JsonNull) + ] + +varGeneratorTests :: TestTree +varGeneratorTests = + testGroup + "Var generator tests" + [ hTestProperty "null, empty string, and empty array return entire data" $ + property $ do + -- Logic that all returns the entire data + let nullVar = JsonObject [("var", JsonNull)] + emptyStringVar = JsonObject [("var", JsonString "")] + emptyArrayVar = JsonObject [("var", JsonArray [])] + dataJson <- forAll $ Gen.sized genSizedRandomJson + -- All of them return the entire data + Right dataJson === apply [] nullVar dataJson + Right dataJson === apply [] emptyStringVar dataJson + Right dataJson === apply [] emptyArrayVar dataJson, + hTestProperty "bool, nested array, and empty object var return nothing" $ + property $ do + -- Logic that all returns null + boolJson <- forAll genGenericJsonBool + arrJson <- forAll $ Gen.sized genSizedNestedJsonArray + let boolVar = JsonObject [("var", fst boolJson)] + arrVar = JsonObject [("var", JsonArray [arrJson])] + objVar = JsonObject [("var", JsonObject [])] + dataJson <- forAll $ Gen.sized genSizedRandomJson + -- All of them return null + Right JsonNull === apply [] boolVar dataJson + Right JsonNull === apply [] arrVar dataJson + Right JsonNull === apply [] objVar dataJson, + hTestProperty "Number var returns index" $ + property $ do + -- Insert Json data at index + index <- forAll $ Gen.int $ Range.constant 0 15 + let logic = JsonObject [("var", JsonNumber $ fromIntegral index)] + -- Generate random Json and random data and inject it at the index + dataJson <- forAll $ Gen.sized genSizedRandomJson + randomJson <- forAll $ Gen.sized genSizedRandomJsonArray + resultJson <- forAll $ return $ insertAtPath [show index] dataJson randomJson + -- Check that the index returns the data + Right dataJson === apply [] logic resultJson, + hTestProperty "String var returns item" $ + property $ do + -- The member to index + (indexJson, indexStr) <- forAll genGenericNonEmptyJsonString + let logic = JsonObject [("var", indexJson)] + -- Generate random Json and random data and inject it at the string member + randomJson <- forAll $ Gen.sized genSizedRandomJsonArray + dataJson <- forAll $ Gen.sized genSizedRandomJson + resultJson <- forAll $ return $ insertAtPath [indexStr] dataJson randomJson + -- Check that the data is found at the index + Right dataJson === apply [] logic resultJson, + hTestProperty "Nested indexing for strings returns item correctly" $ + property $ do + -- Generate a list of strings denoting a path + -- f.e ["aa", "bb"] is path "aa.bb" in Json + recIndex <- forAll $ Gen.list (Range.constant 2 10) $ snd <$> genGenericNonEmptyJsonString + let logic = JsonObject [("var", JsonString $ L.intercalate "." recIndex)] + -- Generate random Json and random data and inject it at path + randomJson <- forAll $ Gen.sized genSizedRandomJsonObject + dataJson <- forAll $ Gen.sized genSizedRandomJson + resultJson <- forAll $ return $ insertAtPath recIndex dataJson (JsonObject randomJson) + -- Verify the data is found at the path in the Json + Right dataJson === apply [] logic resultJson, + hTestProperty "Default var takes first value if it returns a value" $ + property $ do + -- Use var null to always convert to a valid item + (stringJson, _) <- forAll genGenericNonEmptyJsonString + let logic = JsonObject [("var", JsonArray [JsonNull, stringJson])] + dataJson <- forAll $ Gen.sized genSizedRandomJsonArray + -- Verify we get the entire data as result and not the default + Right dataJson === apply [] logic dataJson, + hTestProperty "Defaults correctly to second value" $ + property $ do + -- Json bool so it always defaults to the stringJson + (stringJson, _) <- forAll genGenericNonEmptyJsonString + let logic = JsonObject [("var", JsonArray [JsonBool True, stringJson])] + randomJson <- forAll $ Gen.sized genSizedRandomJsonArray + -- Verify the default value as the result + Right stringJson === apply [] logic randomJson + ] diff --git a/test/Operation/String/TestCat.hs b/test/Operation/String/TestCat.hs new file mode 100644 --- /dev/null +++ b/test/Operation/String/TestCat.hs @@ -0,0 +1,93 @@ +module Operation.String.TestCat where + +import Data.List (intersperse) +import Generator.Data (genSizedFlatArray) +import Generator.Generic +import Hedgehog (forAll, property, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import JsonLogic.Json (Json (..)) +import JsonLogic.Pure.Evaluator (apply) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit as U (assertEqual, testCase) +import Utils + +catUnitTests :: TestTree +catUnitTests = + testGroup + "cat unit tests" + [ testCase "cat empty" $ + U.assertEqual + "Empty cat should return an empty string" + (Right $ jStr "") + (apply [] (jObj [("cat", jArr [])]) jNull), + testCase "cat empty lists" $ + U.assertEqual + "Empty lists should not increase length of output string" + (Right $ jStr "") + (apply [] (jObj [("cat", jArr [jArr [], jArr [], jArr []])]) jNull), + testCase "first cat example website" $ + U.assertEqual + "Result should simply concat the two strings" + (Right $ jStr "I love pie") + (apply [] (jObj [("cat", jArr [jStr "I love", jStr " pie"])]) jNull), + testCase "second cat example website" $ + U.assertEqual + "Variable substitution works correctly" + (Right $ jStr "I love apple pie") + (apply [] (jObj [("cat", jArr [jStr "I love ", jObj [("var", jStr "filling")], jStr " pie"])]) (jObj [("filling", jStr "apple"), ("temp", jNum 110)])), + testCase "cat of boolean" $ + U.assertEqual + "booleans are converted to strings correctly" + (Right $ jStr "truefalse") + (apply [] (jObj [("cat", jArr [jBool True, jBool False])]) jNull), + testCase "cat of nested array" $ + U.assertEqual + "rule gets applyuated" + (Right $ jStr "12,3,4,5false") + (apply [] (jObj [("cat", jArr [jStr "1", jArr [jStr "2", jStr "3", jStr "4", jStr "5"], jBool False])]) jNull), + testCase "cat an object" $ + U.assertEqual + "Object representation" + (Right $ jStr "[object Object]") + (apply [] (jObj [("cat", jArr [jObj []])]) jNull) + ] + +catGeneratorTests :: TestTree +catGeneratorTests = + testGroup + "Cat generator tests" + -- List of nulls results in an empty list + [ hTestProperty "cat null objects" $ + property $ do + jsonNulls <- forAll $ Gen.list (Range.constant 0 20) $ return JsonNull + let rule = jObj [("cat", jArr jsonNulls)] + Right (jStr "") === apply [] rule jNull, + -- Flat array of strings simply concatinates them + hTestProperty "cat strings" $ + property $ do + jsonStrings <- forAll $ Gen.list (Range.constant 0 20) genGenericJsonString + let rule = jObj [("cat", jArr $ map fst jsonStrings)] + expected = jStr (concatMap snd jsonStrings) + Right expected === apply [] rule jNull, + -- Concatinate list of numbers + hTestProperty "cat numbers" $ + property $ do + jsonNumbers <- forAll $ Gen.list (Range.constant 0 20) genGenericJsonNumber + let rule = jObj [("cat", jArr $ map fst jsonNumbers)] + expected = jStr (concatMap (show . snd) jsonNumbers) + Right expected === apply [] rule jNull, + -- A nested array of nulls, we know the number of comma's to be n-1 + hTestProperty "cat nested arrays" $ + property $ do + jsonNulls <- forAll $ Gen.list (Range.constant 0 20) $ return JsonNull + let rule = jObj [("cat", jArr [jArr jsonNulls])] + Right (jStr $ replicate (length jsonNulls - 1) ',') === apply [] rule jNull, + -- Any random object string representation should not change with empty lists interleaved + hTestProperty "cat nested arrays with inserted empty lists" $ + property $ do + jsonArray@(JsonArray js) <- forAll $ Gen.sized genSizedFlatArray + let rule = jObj [("cat", jsonArray)] + intercalatedRule = jObj [("cat", jArr $ intersperse (jArr []) js)] + apply [] intercalatedRule jNull === apply [] rule jNull + ] diff --git a/test/Operation/String/TestSubstr.hs b/test/Operation/String/TestSubstr.hs new file mode 100644 --- /dev/null +++ b/test/Operation/String/TestSubstr.hs @@ -0,0 +1,93 @@ +module Operation.String.TestSubstr where + +import Generator.Generic +import Hedgehog as H (assert, failure, forAll, property, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import JsonLogic.Json (Json (..)) +import JsonLogic.Pure.Evaluator (apply) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit as U (assertEqual, testCase) +import Utils + +substrUnitTests :: TestTree +substrUnitTests = + testGroup + "substr unit tests" + [ testCase "substr empty" $ + U.assertEqual + "Empty substr should return an empty string" + (Right $ jStr "") + (apply [] (jObj [("substr", jArr [])]) jNull), + testCase "first example site" $ + U.assertEqual + "logic {\"substr\": [\"jsonlogic\", 4]} => \"logic\"" + (Right $ jStr "logic") + (apply [] (jObj [("substr", jArr [jStr "jsonlogic", jNum 4])]) jNull), + testCase "second example site" $ + U.assertEqual + "logic {\"substr\": [\"jsonlogic\", -5]} => \"logic\"" + (Right $ jStr "logic") + (apply [] (jObj [("substr", jArr [jStr "jsonlogic", jNum $ -5])]) jNull), + testCase "third example site" $ + U.assertEqual + "logic {\"substr\": [\"jsonlogic\", 1, 3]} => \"son\"" + (Right $ jStr "son") + (apply [] (jObj [("substr", jArr [jStr "jsonlogic", jNum 1, jNum 3])]) jNull), + testCase "fourth example site" $ + U.assertEqual + "logic {\"substr\": [\"jsonlogic\", 4, -2]} => \"son\"" + (Right $ jStr "log") + (apply [] (jObj [("substr", jArr [jStr "jsonlogic", jNum 4, jNum $ -2])]) jNull), + testCase "two negative indexes" $ + U.assertEqual + "logic {\"substr\": [\"jsonlogic\", -5, -2]} => \"log\"" + (Right $ jStr "log") + (apply [] (jObj [("substr", jArr [jStr "jsonlogic", jNum $ -5, jNum $ -2])]) jNull) + ] + +substrGeneratorTests :: TestTree +substrGeneratorTests = + testGroup + "substr generator tests" + -- Indexing using positive does same as drop + [ hTestProperty "substr with positive value" $ + property $ do + (jsonStr, str) <- forAll genGenericJsonString + index <- forAll $ Gen.int (Range.constant 0 $ length str) + let rule = jObj [("substr", jArr [jsonStr, jNum $ fromIntegral index])] + Right (jStr $ drop index str) === apply [] rule jsonStr, + -- Indexing with negative values returns end + hTestProperty "substr with negative value" $ + property $ do + (jsonStr, str) <- forAll genGenericNonEmptyJsonString + index <- forAll $ Gen.int (Range.constant (-1) (-length str)) + let rule = jObj [("substr", jArr [jsonStr, jNum $ fromIntegral index])] + case apply [] rule jsonStr of + -- Length is the equal to the negative index + Right (JsonString res) -> H.assert $ length res == -index + _ -> H.failure, + -- The evaluation returns the same result as take . drop + hTestProperty "substr with start and final index works like take . drop" $ + property $ do + (jsonStr, str) <- forAll genGenericJsonString + -- Take and drop value + index <- forAll $ Gen.int (Range.constant 0 $ length str) + endIndex <- forAll $ Gen.int (Range.constant 0 $ length str) + -- Assert the result is the same + let rule = jObj [("substr", jArr [jsonStr, jNum $ fromIntegral index, jNum $ fromIntegral endIndex])] + Right (jStr $ take endIndex $ drop index str) === apply [] rule jsonStr, + -- The take part also works with negative indexes + hTestProperty "substr with start and final negative index" $ + property $ do + (jsonStr, str) <- forAll genGenericNonEmptyJsonString + -- Positive start index, negative end index + index <- forAll $ Gen.int (Range.constant 0 $ length str - 1) + endIndex <- forAll $ Gen.int (Range.constant (-1) (-length str)) + -- Create rule and evaluate + let rule = jObj [("substr", jArr [jsonStr, jNum $ fromIntegral index, jNum $ fromIntegral endIndex])] + case apply [] rule jsonStr of + -- Assert the length is as expected + Right (JsonString res) -> H.assert $ length res == max 0 (length str - index + endIndex) + _ -> H.failure + ] diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE OverloadedLists #-} + +import Generator.Logic (genArithmeticOperator, genArrayOperator, genBetweenOperator, genComparisonOperator, genLogicOperator) +import Hedgehog (Gen, forAll, forAllWith, property, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import JsonLogic.Json +import JsonLogic.Pure.Evaluator +import Operation.Array.TestArrayChecks +import Operation.Array.TestFilter +import Operation.Array.TestIn +import Operation.Array.TestMerge +import Operation.Array.TestReduce +import Operation.Boolean.TestEquality +import Operation.Boolean.TestIf +import Operation.Boolean.TestNegation +import Operation.Data.TestMissing +import Operation.Data.TestMissingSome +import Operation.Data.TestPreserve +import Operation.Data.TestVar +import Operation.String.TestCat +import Operation.String.TestSubstr +import Test.Tasty +import Test.Tasty.HUnit as U +import TestJson +import TestStringify +import TestToNumber +import TestTruthy +import Utils + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "Tests" + [ unitTests, + generatorTests, + hedgehogTests + ] + +unitTests :: TestTree +unitTests = + testGroup + "Unit tests" + [ simpleUnitTests, + equalityUnitTests, + ifUnitTests, + filterUnitTests, + varUnitTests, + mergeUnitTests, + mapUnitTests, + allUnitTests, + someUnitTests, + noneUnitTests, + missingUnitTests, + missingSomeUnitTests, + negationUnitTests, + -- String operations + substrUnitTests, + catUnitTests, + inUnitTests, + reduceUnitTests, + -- JS casting tests + parseUnitTests, + stringifyUnitTests, + toNumberUnitTests, + truthyUnitTests + ] + +generatorTests :: TestTree +generatorTests = + testGroup + "Generator tests" + [ truthyGeneratorTests, + toNumberGeneratorTests, + -- String operations + catGeneratorTests, + inGeneratorTests, + substrGeneratorTests, + varGeneratorTests, + missingGeneratorTests, + missingSomeGeneratorTests, + negationGeneratorTests, + mergeGeneratorTests, + preserveGeneratorTests + ] + +simpleUnitTests :: TestTree +simpleUnitTests = + testGroup + "Simple unit tests" + [ testCase "Simple plus" $ + U.assertEqual + "Result is correct" + (Right $ JsonNumber 3) + (apply [] (JsonObject [("+", JsonArray [JsonNumber 1, JsonNumber 2])]) JsonNull), + testCase "Nested plus" $ + U.assertEqual + "Result is correct" + (Right $ JsonNumber 6) + (apply [] (JsonObject [("+", JsonArray [JsonNumber 1, JsonObject [("+", JsonArray [JsonNumber 2, JsonNumber 3])]])]) JsonNull) + ] + +mapUnitTests :: TestTree +mapUnitTests = + testGroup + "Map unit tests" + -- logic{"map":[[], {"+", [1,2]} => [] + [ testCase "logic{\"map\":\"[[], {\"+\":[1, 2]}]\"} data{}" $ + U.assertEqual + "Empty list case" + (Right $ JsonArray []) + (apply [] (JsonObject [("map", JsonArray [JsonArray [], JsonObject [("+", JsonArray [JsonNumber 1, JsonNumber 2])]])]) JsonNull), + -- logic{"map":[[1,2], {"+", [{"var":""},2]} => [3,4] + testCase "logic{\"map\":\"[[1,2], {\"+\":[{\"var\":\"\"}, 2]}]\"} data{}" $ + U.assertEqual + "Empty list case" + (Right $ JsonArray [JsonNumber 3, JsonNumber 4]) + (apply [] (JsonObject [("map", JsonArray [JsonArray [JsonNumber 1, JsonNumber 2], JsonObject [("+", JsonArray [JsonObject [("var", JsonString "")], JsonNumber 2])]])]) JsonNull), + -- logic{"map":[{"var":"x"}, {"+", [{"var":""},2]} data[1,2,3]=> [3,4,5] + testCase "logic{\"map\":\"[{\"var\":\"x\"}, {\"+\":[{\"var\":\"\"}, 2]}]\"} data{\"x\":[1,2,3]\"}" $ + U.assertEqual + "Empty list case" + (Right $ JsonArray [JsonNumber 3, JsonNumber 4, JsonNumber 5]) + (apply [] (JsonObject [("map", JsonArray [JsonObject [("var", JsonString "x")], JsonObject [("+", JsonArray [JsonObject [("var", JsonString "")], JsonNumber 2])]])]) (JsonObject [("x", JsonArray [JsonNumber 1, JsonNumber 2, JsonNumber 3])])) + ] + +hedgehogTests :: TestTree +hedgehogTests = + testGroup + "Hedgehog tests" + [ hTestProperty "Simple math operations" $ + property $ do + (f, n) <- forAllWith snd genArithmeticOperator + l <- forAll genDouble + r <- forAll genDouble1 + Right (JsonNumber (f l r)) === apply [] (JsonObject [(n, JsonArray [JsonNumber l, JsonNumber r])]) JsonNull, + hTestProperty "Simple comparison operations" $ + property $ do + (f, n) <- forAllWith snd genComparisonOperator + l <- forAll genDouble + r <- forAll genDouble + Right (JsonBool (f l r)) === apply [] (JsonObject [(n, JsonArray [JsonNumber l, JsonNumber r])]) JsonNull, + hTestProperty "Between comparison operations" $ + property $ do + (f, n) <- forAllWith snd genBetweenOperator + l <- forAll genDouble + m <- forAll genDouble + r <- forAll genDouble + Right (JsonBool (f l m && f m r)) === apply [] (JsonObject [(n, JsonArray [JsonNumber l, JsonNumber m, JsonNumber r])]) JsonNull, + hTestProperty "Simple logic operations" $ + property $ do + (f, n) <- forAllWith snd genLogicOperator + l <- forAll Gen.bool + r <- forAll Gen.bool + Right (JsonBool (f l r)) === apply [] (JsonObject [(n, JsonArray [JsonBool l, JsonBool r])]) JsonNull, + hTestProperty "Simple double array operations" $ + property $ do + (f, n) <- forAllWith snd genArrayOperator + arr <- forAll genDoubleArray + Right (JsonNumber (f arr)) === apply [] (JsonObject [(n, JsonArray (map JsonNumber arr))]) JsonNull, + hTestProperty "Nested arihmetic operations" $ + property $ do + (f1, n1) <- forAllWith snd genArithmeticOperator + (f2, n2) <- forAllWith snd genArithmeticOperator + (f3, n3) <- forAllWith snd genArithmeticOperator + ll <- forAll genDouble + lr <- forAll genDouble1 + rl <- forAll genDouble + rr <- forAll genDouble1 + Right (JsonNumber (f1 (f2 ll lr) (f3 rl rr))) === apply [] (JsonObject [(n1, JsonArray [JsonObject [(n2, JsonArray [JsonNumber ll, JsonNumber lr])], JsonObject [(n3, JsonArray [JsonNumber rl, JsonNumber rr])]])]) JsonNull, + hTestProperty "Nested boolean operations" $ + property $ do + (f1, n1) <- forAllWith snd genLogicOperator + (f2, n2) <- forAllWith snd genComparisonOperator + (f3, n3) <- forAllWith snd genLogicOperator + ll <- forAll genDouble + lr <- forAll genDouble1 + rl <- forAll Gen.bool + rr <- forAll Gen.bool + Right (JsonBool (f1 (f2 ll lr) (f3 rl rr))) === apply [] (JsonObject [(n1, JsonArray [JsonObject [(n2, JsonArray [JsonNumber ll, JsonNumber lr])], JsonObject [(n3, JsonArray [JsonBool rl, JsonBool rr])]])]) JsonNull + ] + +genDouble :: Gen Double +genDouble = Gen.double $ Range.constant 0 1000 + +genDoubleArray :: Gen [Double] +genDoubleArray = Gen.list (Range.constant 1 50) genDouble + +-- Not 0 to avoid division by zero +genDouble1 :: Gen Double +genDouble1 = Gen.double $ Range.constant 1 1000 diff --git a/test/TestJson.hs b/test/TestJson.hs new file mode 100644 --- /dev/null +++ b/test/TestJson.hs @@ -0,0 +1,57 @@ +module TestJson where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import qualified Test.Tasty.HUnit as U +import Utils + +parseUnitTests :: TestTree +parseUnitTests = + testGroup + "Read json unit tests" + [ testCase "read null" $ + U.assertEqual + "Result is correct" + jNull + (read "null"), + testCase "read true" $ + U.assertEqual + "Result is correct" + (jBool True) + (read "true"), + testCase "read false" $ + U.assertEqual + "Result is correct" + (jBool False) + (read "false"), + testCase "read 1" $ + U.assertEqual + "Result is correct" + (jNum 1.0) + (read "1.0"), + testCase "read 1.2e-3" $ + U.assertEqual + "Result is correct" + (jNum 0.0012) + (read "1.2e-3"), + testCase "read \"string\"" $ + U.assertEqual + "Result is correct" + (jStr "string") + (read "\"string\""), + testCase "[1,2]" $ + U.assertEqual + "Result is correct" + (jArr [jNum 1, jNum 2]) + (read "[1.0,2.0]"), + testCase "{\"var\":\"x\"}" $ + U.assertEqual + "Result is correct" + (jObj [("var", jStr "x")]) + (read "{\"var\":\"x\"}"), + testCase "{\"var\":\"x\",\"hi\":null}" $ + U.assertEqual + "Result is correct" + (jObj [("var", jStr "x"), ("hi", jNull)]) + (read "{\"var\":\"x\",\"hi\":null}") + ] diff --git a/test/TestStringify.hs b/test/TestStringify.hs new file mode 100644 --- /dev/null +++ b/test/TestStringify.hs @@ -0,0 +1,53 @@ +module TestStringify where + +import JsonLogic.Json (stringify) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import qualified Test.Tasty.HUnit as U +import Utils + +stringifyUnitTests :: TestTree +stringifyUnitTests = + testGroup + "Show json unit tests" + [ testCase "show null" $ + U.assertEqual + "Result is correct" + "" + (stringify jNull), + testCase "show true" $ + U.assertEqual + "Result is correct" + "true" + (stringify $ jBool True), + testCase "show false" $ + U.assertEqual + "Result is correct" + "false" + (stringify $ jBool False), + testCase "show 1" $ + U.assertEqual + "Result is correct" + "1.0" + (stringify $ jNum 1.0), + testCase "show \"string\"" $ + U.assertEqual + "Result is correct" + "string" + (stringify $ jStr "string"), + testCase "[1,2]" $ + U.assertEqual + "Result is correct" + "1.0,2.0" + (stringify $ jArr [jNum 1, jNum 2]), + testCase "{\"var\":\"x\"}" $ + U.assertEqual + "Result is correct" + "[object Object]" + (stringify $ jObj [("var", jStr "x")]), + testCase "{\"var\":\"x\",\"hi\":null}" $ + U.assertEqual + "Result is correct" + "[object Object]" + (stringify $ jObj [("var", jStr "x"), ("hi", jNull)]) + ] diff --git a/test/TestToNumber.hs b/test/TestToNumber.hs new file mode 100644 --- /dev/null +++ b/test/TestToNumber.hs @@ -0,0 +1,58 @@ +module TestToNumber where + +import Generator.Data (genSizedNestedJsonArray) +import Generator.Generic (genGenericJsonNumber) +import Generator.Utils (increaseSizeBy) +import Hedgehog (forAll, property) +import qualified Hedgehog as H (assert) +import qualified Hedgehog.Gen as Gen +import Hedgehog.Range as Range +import JsonLogic.Json (Json (JsonArray), parseFloat) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) +import Utils + +toNumberUnitTests :: TestTree +toNumberUnitTests = + testGroup + "Number conversion unit tests" + -- Simple unit tests that are deterministic + [ testCase "test for null" $ assertBool "NaN == null" (isNaN $ parseFloat jNull), + testCase "test for bool" $ assertBool "0 == false" (isNaN $ parseFloat $ jBool False), + testCase "test for bool" $ assertBool "1 == true" (isNaN $ parseFloat $ jBool True), + testCase "test for number" $ assertEqual "1.0 == 1.0" 1 $ parseFloat $ jNum 1.0, + testCase "test for string" $ assertBool "0 == \"\"" (isNaN $ parseFloat $ jStr ""), + testCase "test for string" $ assertEqual "2 == 2" 2 $ parseFloat $ jStr "2", + testCase "test for string" $ assertEqual "1.2 == 1.2" 1.2 $ parseFloat $ jStr "1.2", + testCase "test for string" $ assertEqual "1.2 == 1.2.3 " 1.2 $ parseFloat $ jStr "1.2.3 ", + testCase "test for string" $ assertEqual "1 == 1abc " 1 $ parseFloat $ jStr "1abc", + testCase "test for string" $ assertEqual "100 == 1e2 " 100 $ parseFloat $ jStr "1e2", + testCase "test for array" $ assertBool "0 == []" (isNaN $ parseFloat $ jArr []), + testCase "test for array" $ assertEqual "2 == [2]" 2 $ parseFloat $ jArr [jNum 2], + testCase "test for object" $ assertBool "NaN == {}" (isNaN $ parseFloat $ jObj []) + ] + +toNumberGeneratorTests :: TestTree +toNumberGeneratorTests = + testGroup + "toNumber generator tests" + [ hTestProperty "parsing works for integer strings" $ + property $ do + (json, n) <- forAll genGenericJsonNumber + H.assert $ parseFloat (jStr $ show json) == n, + hTestProperty "parsing does not work for non integer strings" $ + property $ do + -- Generate string that only contains letters + s <- forAll $ Gen.string (Range.constant 1 10) Gen.alpha + H.assert $ isNaN $ parseFloat $ jStr s, + hTestProperty "parsing always returns value of first item." $ + property $ do + -- Array with more than 1 item always results in nothing + arr@(JsonArray as) <- forAll $ increaseSizeBy 1 $ Gen.sized genSizedNestedJsonArray + H.assert $ case as of + [] -> isNaN $ parseFloat arr + (x : _) -> + let x' = parseFloat x + arr' = parseFloat arr + in (isNaN x' && isNaN arr') || (x' == arr') + ] diff --git a/test/TestTruthy.hs b/test/TestTruthy.hs new file mode 100644 --- /dev/null +++ b/test/TestTruthy.hs @@ -0,0 +1,66 @@ +module TestTruthy (truthyUnitTests, truthyGeneratorTests) where + +import Generator.Data (genSizedRandomJsonArray, genSizedRandomJsonObject) +import Generator.Generic +import Hedgehog (forAll, property) +import qualified Hedgehog as H (assert) +import qualified Hedgehog.Gen as Gen +import JsonLogic.Json +import Test.Tasty +import qualified Test.Tasty.HUnit as U +import Utils + +truthyUnitTests :: TestTree +truthyUnitTests = + testGroup + "Truthy and falsy unit tests from site" + [ U.testCase "test for number" $ U.assertBool "falsy 0" $ falsyAssertion $ jNum 0.0, + U.testCase "test for number" $ U.assertBool "truthy 1" $ truthyAssertion $ jNum 1.0, + U.testCase "test for number" $ U.assertBool "truthy -1" $ truthyAssertion $ jNum $ -1.0, + U.testCase "test for array" $ U.assertBool "falsy []" $ falsyAssertion $ jArr [], + U.testCase "test for array" $ U.assertBool "truthy [1,2]" $ truthyAssertion $ jArr [jNum 1.0, jNum 2.0], + U.testCase "test for string" $ U.assertBool "falsy \"\"" $ falsyAssertion $ jStr "", + U.testCase "test for string" $ U.assertBool "truthy \"anything\"" $ truthyAssertion $ jStr "anything", + U.testCase "test for string" $ U.assertBool "\"0\"" $ truthyAssertion $ jStr "0", + U.testCase "test for null" $ U.assertBool "null" $ falsyAssertion jNull + ] + +truthyGeneratorTests :: TestTree +truthyGeneratorTests = + testGroup + "Truthy generator tests" + [ hTestProperty "truthy for bools" $ + property $ do + (json, b) <- forAll genGenericJsonBool + if b + then H.assert $ truthyAssertion json + else H.assert $ falsyAssertion json, + hTestProperty "truthy for numbers" $ + property $ do + (json, n) <- forAll genGenericJsonNumber + case n of + 0.0 -> H.assert $ falsyAssertion json + _ -> H.assert $ truthyAssertion json, + hTestProperty "truthy for strings" $ + property $ do + (json, s) <- forAll genGenericJsonString + case s of + "" -> H.assert $ falsyAssertion json + _ -> H.assert $ truthyAssertion json, + hTestProperty "truthy for arrays" $ + property $ do + jsonArr <- forAll $ Gen.sized genSizedRandomJsonArray + case jsonArr of + JsonArray [] -> H.assert $ falsyAssertion jsonArr + _ -> H.assert $ truthyAssertion jsonArr, + hTestProperty "truthy for objects" $ + property $ do + jsonObj <- forAll $ Gen.sized genSizedRandomJsonObject + H.assert $ truthyAssertion (JsonObject jsonObj) + ] + +truthyAssertion :: Json -> Bool +truthyAssertion json = isTruthy json && not (isFalsy json) + +falsyAssertion :: Json -> Bool +falsyAssertion json = isFalsy json && not (isTruthy json) diff --git a/test/Utils.hs b/test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Utils.hs @@ -0,0 +1,29 @@ +-- | This module is to provide shorter names for the json constructors for the tests +module Utils where + +import qualified Data.Map as M (fromList) +import Hedgehog.Internal.Property +import JsonLogic.Json (Json (..)) +import Test.Tasty +import qualified Test.Tasty.Hedgehog as H + +jNull :: Json +jNull = JsonNull + +jBool :: Bool -> Json +jBool = JsonBool + +jNum :: Double -> Json +jNum = JsonNumber + +jStr :: String -> Json +jStr = JsonString + +jArr :: [Json] -> Json +jArr = JsonArray + +jObj :: [(String, Json)] -> Json +jObj = JsonObject . M.fromList + +hTestProperty :: TestName -> Property -> TestTree +hTestProperty name = H.testPropertyNamed name (PropertyName name)