packages feed

jsonlogic (empty) → 0.1.0.0

raw patch · 49 files changed

+3540/−0 lines, 49 filesdep +basedep +containersdep +hedgehog

Dependencies added: base, containers, hedgehog, jsonlogic, mtl, tasty, tasty-hedgehog, tasty-hunit

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for jsonlogic++## 0.1.0.0 -- 2022-04-06++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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 **"+```
+ jsonlogic.cabal view
@@ -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
+ src/JsonLogic/Evaluator.hs view
@@ -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
+ src/JsonLogic/IO/Evaluator.hs view
@@ -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
+ src/JsonLogic/IO/Mapping.hs view
@@ -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
+ src/JsonLogic/IO/Operation.hs view
@@ -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
+ src/JsonLogic/IO/Operation/Misc.hs view
@@ -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
+ src/JsonLogic/IO/Type.hs view
@@ -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
+ src/JsonLogic/Json.hs view
@@ -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)
+ src/JsonLogic/Operation.hs view
@@ -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]
+ src/JsonLogic/Operation/Array.hs view
@@ -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
+ src/JsonLogic/Operation/Boolean.hs view
@@ -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
+ src/JsonLogic/Operation/Data.hs view
@@ -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]
+ src/JsonLogic/Operation/Misc.hs view
@@ -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
+ src/JsonLogic/Operation/Numeric.hs view
@@ -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
+ src/JsonLogic/Operation/Primitive.hs view
@@ -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
+ src/JsonLogic/Operation/String.hs view
@@ -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
+ src/JsonLogic/Operation/Utils.hs view
@@ -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]
+ src/JsonLogic/Pure/Evaluator.hs view
@@ -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
+ src/JsonLogic/Pure/Mapping.hs view
@@ -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
+ src/JsonLogic/Pure/Operation.hs view
@@ -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
+ src/JsonLogic/Pure/Type.hs view
@@ -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
+ src/JsonLogic/Type.hs view
@@ -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
+ test/Generator/Data.hs view
@@ -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<key,value>)+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]
+ test/Generator/Generic.hs view
@@ -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 [], [])
+ test/Generator/Logic.hs view
@@ -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)
+ test/Generator/Utils.hs view
@@ -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)
+ test/Operation/Array/TestArrayChecks.hs view
@@ -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])]))+    ]
+ test/Operation/Array/TestFilter.hs view
@@ -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+          )+    ]
+ test/Operation/Array/TestIn.hs view
@@ -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+    ]
+ test/Operation/Array/TestMerge.hs view
@@ -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
+ test/Operation/Array/TestReduce.hs view
@@ -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 [])]))+    ]
+ test/Operation/Boolean/TestEquality.hs view
@@ -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)
+ test/Operation/Boolean/TestIf.hs view
@@ -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)+    ]
+ test/Operation/Boolean/TestNegation.hs view
@@ -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+    ]
+ test/Operation/Data/TestMissing.hs view
@@ -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)+    ]
+ test/Operation/Data/TestMissingSome.hs view
@@ -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]
+ test/Operation/Data/TestPreserve.hs view
@@ -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+    ]
+ test/Operation/Data/TestVar.hs view
@@ -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+    ]
+ test/Operation/String/TestCat.hs view
@@ -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+    ]
+ test/Operation/String/TestSubstr.hs view
@@ -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+    ]
+ test/Test.hs view
@@ -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
+ test/TestJson.hs view
@@ -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}")+    ]
+ test/TestStringify.hs view
@@ -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)])+    ]
+ test/TestToNumber.hs view
@@ -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')+    ]
+ test/TestTruthy.hs view
@@ -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)
+ test/Utils.hs view
@@ -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)