{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeApplications           #-}
{-|
  Module      : Auth.Biscuit.Datalog.Executor
  Copyright   : © Clément Delafargue, 2021
  License     : BSD-3-Clause
  Maintainer  : clement@delafargue.name
  The Datalog engine, tasked with deriving new facts from existing facts and rules, as well as matching available facts against checks and policies
-}
module Auth.Biscuit.Datalog.Executor
  ( ExecutionError (..)
  , Limits (..)
  , ResultError (..)
  , Bindings
  , Name
  , ExternFuncs
  , ExternFunc (..)
  , MatchedQuery (..)
  , Scoped
  , FactGroup (..)
  , countFacts
  , toScopedFacts
  , fromScopedFacts
  , keepAuthorized'
  , defaultLimits
  , setExternFuncs
  , withExternFunc
  , withExternFuncs
  , evaluateExpression
  --
  , getFactsForRule
  , checkCheck
  , checkPolicy
  , getBindingsForRuleBody
  , getCombinations
  ) where

import           Control.Monad            (join, mfilter, zipWithM)
import           Data.Bitraversable       (bitraverse)
import           Data.Bits                (xor, (.&.), (.|.))
import qualified Data.ByteString          as ByteString
import           Data.Foldable            (fold)
import           Data.Functor.Compose     (Compose (..))
import           Data.Int                 (Int64)
import qualified Data.List                as List
import           Data.List.NonEmpty       (NonEmpty)
import qualified Data.List.NonEmpty       as NE
import           Data.Map.Strict          (Map, (!?))
import qualified Data.Map.Strict          as Map
import           Data.Maybe               (fromMaybe, isJust, mapMaybe)
import           Data.Set                 (Set)
import qualified Data.Set                 as Set
import           Data.Text                (Text, isInfixOf, unpack)
import qualified Data.Text                as Text
import qualified Data.Text.Encoding       as Text
import           Data.Void                (absurd)
import           Numeric.Natural          (Natural)
import qualified Text.Regex.TDFA          as Regex
import qualified Text.Regex.TDFA.Text     as Regex
import           Validation               (Validation (..), failure)

import           Auth.Biscuit.Datalog.AST
import           Auth.Biscuit.Utils       (allM, anyM, maybeToRight, setFilterM)

-- | A variable name
type Name = Text

-- | A list of bound variables, with the associated value
type Bindings  = Map Name Value

newtype ExternFunc = ExternFunc (Value -> Maybe Value -> Either String Value)

instance Show ExternFunc where
  show :: ExternFunc -> String
show ExternFunc
_ = String
"<extern func>"

instance Eq ExternFunc where
  ExternFunc
_ == :: ExternFunc -> ExternFunc -> Bool
== ExternFunc
_ = Bool
True

type ExternFuncs = Map Text ExternFunc

runExternFunc :: ExternFuncs -> Text -> Value -> Maybe Value -> Either String Value
runExternFunc :: ExternFuncs -> Name -> Value -> Maybe Value -> Either String Value
runExternFunc ExternFuncs
ef Name
name Value
a1 Maybe Value
a2 = do
  ExternFunc Value -> Maybe Value -> Either String Value
func <- String -> Maybe ExternFunc -> Either String ExternFunc
forall b a. b -> Maybe a -> Either b a
maybeToRight (String
"undefined external func " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
unpack Name
name) (Maybe ExternFunc -> Either String ExternFunc)
-> Maybe ExternFunc -> Either String ExternFunc
forall a b. (a -> b) -> a -> b
$ ExternFuncs
ef ExternFuncs -> Name -> Maybe ExternFunc
forall k a. Ord k => Map k a -> k -> Maybe a
!? Name
name
  Value -> Maybe Value -> Either String Value
func Value
a1 Maybe Value
a2

-- | A datalog query that was matched, along with the values
-- that matched
data MatchedQuery
  = MatchedQuery
  { MatchedQuery -> Query
matchedQuery :: Query
  , MatchedQuery -> Set Bindings
bindings     :: Set Bindings
  }
  deriving (MatchedQuery -> MatchedQuery -> Bool
(MatchedQuery -> MatchedQuery -> Bool)
-> (MatchedQuery -> MatchedQuery -> Bool) -> Eq MatchedQuery
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MatchedQuery -> MatchedQuery -> Bool
== :: MatchedQuery -> MatchedQuery -> Bool
$c/= :: MatchedQuery -> MatchedQuery -> Bool
/= :: MatchedQuery -> MatchedQuery -> Bool
Eq, Int -> MatchedQuery -> ShowS
[MatchedQuery] -> ShowS
MatchedQuery -> String
(Int -> MatchedQuery -> ShowS)
-> (MatchedQuery -> String)
-> ([MatchedQuery] -> ShowS)
-> Show MatchedQuery
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MatchedQuery -> ShowS
showsPrec :: Int -> MatchedQuery -> ShowS
$cshow :: MatchedQuery -> String
show :: MatchedQuery -> String
$cshowList :: [MatchedQuery] -> ShowS
showList :: [MatchedQuery] -> ShowS
Show)

-- | The result of matching the checks and policies against all the available
-- facts.
data ResultError
  = NoPoliciesMatched [Check]
  -- ^ No policy matched. additionally some checks may have failed
  | FailedChecks      (NonEmpty Check)
  -- ^ An allow rule matched, but at least one check failed
  | DenyRuleMatched   [Check] MatchedQuery
  -- ^ A deny rule matched. additionally some checks may have failed
  deriving (ResultError -> ResultError -> Bool
(ResultError -> ResultError -> Bool)
-> (ResultError -> ResultError -> Bool) -> Eq ResultError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResultError -> ResultError -> Bool
== :: ResultError -> ResultError -> Bool
$c/= :: ResultError -> ResultError -> Bool
/= :: ResultError -> ResultError -> Bool
Eq, Int -> ResultError -> ShowS
[ResultError] -> ShowS
ResultError -> String
(Int -> ResultError -> ShowS)
-> (ResultError -> String)
-> ([ResultError] -> ShowS)
-> Show ResultError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResultError -> ShowS
showsPrec :: Int -> ResultError -> ShowS
$cshow :: ResultError -> String
show :: ResultError -> String
$cshowList :: [ResultError] -> ShowS
showList :: [ResultError] -> ShowS
Show)

-- | An error that can happen while running a datalog verification.
-- The datalog computation itself can be aborted by runtime failsafe
-- mechanisms, or it can run to completion but fail to fullfil checks
-- and policies ('ResultError').
data ExecutionError
  = Timeout
  -- ^ Verification took too much time
  | TooManyFacts
  -- ^ Too many facts were generated during evaluation
  | TooManyIterations
  -- ^ Evaluation did not converge in the alloted number of iterations
  | InvalidRule
  -- ^ Some rules were malformed: every variable present in their head must
  -- appear in their body
  | ResultError ResultError
  -- ^ The evaluation ran to completion, but checks and policies were not
  -- fulfilled.
  | EvaluationError String
  -- ^ Datalog evaluation failed while evaluating an expression
  deriving (ExecutionError -> ExecutionError -> Bool
(ExecutionError -> ExecutionError -> Bool)
-> (ExecutionError -> ExecutionError -> Bool) -> Eq ExecutionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExecutionError -> ExecutionError -> Bool
== :: ExecutionError -> ExecutionError -> Bool
$c/= :: ExecutionError -> ExecutionError -> Bool
/= :: ExecutionError -> ExecutionError -> Bool
Eq, Int -> ExecutionError -> ShowS
[ExecutionError] -> ShowS
ExecutionError -> String
(Int -> ExecutionError -> ShowS)
-> (ExecutionError -> String)
-> ([ExecutionError] -> ShowS)
-> Show ExecutionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExecutionError -> ShowS
showsPrec :: Int -> ExecutionError -> ShowS
$cshow :: ExecutionError -> String
show :: ExecutionError -> String
$cshowList :: [ExecutionError] -> ShowS
showList :: [ExecutionError] -> ShowS
Show)

-- | Settings for the executor runtime restrictions.
-- See `defaultLimits` for default values.
data Limits
  = Limits
  { Limits -> Int
maxFacts      :: Int
  -- ^ maximum number of facts that can be produced before throwing `TooManyFacts`
  , Limits -> Int
maxIterations :: Int
  -- ^ maximum number of iterations before throwing `TooManyIterations`
  , Limits -> Int
maxTime       :: Int
  -- ^ maximum duration the verification can take (in μs)
  , Limits -> Bool
allowRegexes  :: Bool
  -- ^ whether or not allowing `.matches()` during verification (untrusted regex computation
  -- can enable DoS attacks). This security risk is mitigated by the 'maxTime' setting.
  , Limits -> ExternFuncs
externFuncs   :: ExternFuncs
  }
  deriving (Limits -> Limits -> Bool
(Limits -> Limits -> Bool)
-> (Limits -> Limits -> Bool) -> Eq Limits
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Limits -> Limits -> Bool
== :: Limits -> Limits -> Bool
$c/= :: Limits -> Limits -> Bool
/= :: Limits -> Limits -> Bool
Eq, Int -> Limits -> ShowS
[Limits] -> ShowS
Limits -> String
(Int -> Limits -> ShowS)
-> (Limits -> String) -> ([Limits] -> ShowS) -> Show Limits
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Limits -> ShowS
showsPrec :: Int -> Limits -> ShowS
$cshow :: Limits -> String
show :: Limits -> String
$cshowList :: [Limits] -> ShowS
showList :: [Limits] -> ShowS
Show)

-- | Default settings for the executor restrictions.
--   - 1000 facts
--   - 100 iterations
--   - 1000μs max
--   - regexes are allowed
defaultLimits :: Limits
defaultLimits :: Limits
defaultLimits = Limits
  { maxFacts :: Int
maxFacts = Int
1000
  , maxIterations :: Int
maxIterations = Int
100
  , maxTime :: Int
maxTime = Int
1000
  , allowRegexes :: Bool
allowRegexes = Bool
True
  , externFuncs :: ExternFuncs
externFuncs = ExternFuncs
forall a. Monoid a => a
mempty
  }

withExternFunc :: Text -> (Value -> Maybe Value -> Either String Value) -> Limits -> Limits
withExternFunc :: Name
-> (Value -> Maybe Value -> Either String Value)
-> Limits
-> Limits
withExternFunc Name
n Value -> Maybe Value -> Either String Value
f l :: Limits
l@Limits{ExternFuncs
externFuncs :: Limits -> ExternFuncs
externFuncs :: ExternFuncs
externFuncs} = Limits
l { externFuncs :: ExternFuncs
externFuncs = Name -> ExternFunc -> ExternFuncs -> ExternFuncs
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
n ((Value -> Maybe Value -> Either String Value) -> ExternFunc
ExternFunc Value -> Maybe Value -> Either String Value
f) ExternFuncs
externFuncs }

withExternFuncs :: Map Text (Value -> Maybe Value -> Either String Value) -> Limits -> Limits
withExternFuncs :: Map Name (Value -> Maybe Value -> Either String Value)
-> Limits -> Limits
withExternFuncs Map Name (Value -> Maybe Value -> Either String Value)
fs l :: Limits
l@Limits{ExternFuncs
externFuncs :: Limits -> ExternFuncs
externFuncs :: ExternFuncs
externFuncs} = Limits
l { externFuncs :: ExternFuncs
externFuncs = ExternFuncs -> ExternFuncs -> ExternFuncs
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ((Value -> Maybe Value -> Either String Value) -> ExternFunc
ExternFunc ((Value -> Maybe Value -> Either String Value) -> ExternFunc)
-> Map Name (Value -> Maybe Value -> Either String Value)
-> ExternFuncs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name (Value -> Maybe Value -> Either String Value)
fs) ExternFuncs
externFuncs }

setExternFuncs :: Map Text (Value -> Maybe Value -> Either String Value) -> Limits -> Limits
setExternFuncs :: Map Name (Value -> Maybe Value -> Either String Value)
-> Limits -> Limits
setExternFuncs Map Name (Value -> Maybe Value -> Either String Value)
fs Limits
l = Limits
l { externFuncs :: ExternFuncs
externFuncs = (Value -> Maybe Value -> Either String Value) -> ExternFunc
ExternFunc ((Value -> Maybe Value -> Either String Value) -> ExternFunc)
-> Map Name (Value -> Maybe Value -> Either String Value)
-> ExternFuncs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name (Value -> Maybe Value -> Either String Value)
fs }

type Scoped a = (Set Natural, a)

newtype FactGroup = FactGroup { FactGroup -> Map (Set Natural) (Set Fact)
getFactGroup :: Map (Set Natural) (Set Fact) }
  deriving newtype (FactGroup -> FactGroup -> Bool
(FactGroup -> FactGroup -> Bool)
-> (FactGroup -> FactGroup -> Bool) -> Eq FactGroup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FactGroup -> FactGroup -> Bool
== :: FactGroup -> FactGroup -> Bool
$c/= :: FactGroup -> FactGroup -> Bool
/= :: FactGroup -> FactGroup -> Bool
Eq)

instance Show FactGroup where
  show :: FactGroup -> String
show (FactGroup Map (Set Natural) (Set Fact)
groups) =
    let showGroup :: (Set a, Set Fact) -> String
showGroup (Set a
origin, Set Fact
facts) = [String] -> String
unlines
          [ String
"For origin: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [a] -> String
forall a. Show a => a -> String
show (Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
origin)
          , String
"Facts: \n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines (Name -> String
unpack (Name -> String) -> (Fact -> Name) -> Fact -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fact -> Name
renderFact (Fact -> String) -> [Fact] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Fact -> [Fact]
forall a. Set a -> [a]
Set.toList Set Fact
facts)
          ]
     in [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Set Natural, Set Fact) -> String
forall {a}. Show a => (Set a, Set Fact) -> String
showGroup ((Set Natural, Set Fact) -> String)
-> [(Set Natural, Set Fact)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Set Natural) (Set Fact) -> [(Set Natural, Set Fact)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Set Natural) (Set Fact)
groups

instance Semigroup FactGroup where
  FactGroup Map (Set Natural) (Set Fact)
f1 <> :: FactGroup -> FactGroup -> FactGroup
<> FactGroup Map (Set Natural) (Set Fact)
f2 = Map (Set Natural) (Set Fact) -> FactGroup
FactGroup (Map (Set Natural) (Set Fact) -> FactGroup)
-> Map (Set Natural) (Set Fact) -> FactGroup
forall a b. (a -> b) -> a -> b
$ (Set Fact -> Set Fact -> Set Fact)
-> Map (Set Natural) (Set Fact)
-> Map (Set Natural) (Set Fact)
-> Map (Set Natural) (Set Fact)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set Fact -> Set Fact -> Set Fact
forall a. Semigroup a => a -> a -> a
(<>) Map (Set Natural) (Set Fact)
f1 Map (Set Natural) (Set Fact)
f2
instance Monoid FactGroup where
  mempty :: FactGroup
mempty = Map (Set Natural) (Set Fact) -> FactGroup
FactGroup Map (Set Natural) (Set Fact)
forall a. Monoid a => a
mempty

keepAuthorized :: FactGroup -> Set Natural -> FactGroup
keepAuthorized :: FactGroup -> Set Natural -> FactGroup
keepAuthorized (FactGroup Map (Set Natural) (Set Fact)
facts) Set Natural
authorizedOrigins =
  let isAuthorized :: Set Natural -> p -> Bool
isAuthorized Set Natural
k p
_ = Set Natural
k Set Natural -> Set Natural -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Natural
authorizedOrigins
   in Map (Set Natural) (Set Fact) -> FactGroup
FactGroup (Map (Set Natural) (Set Fact) -> FactGroup)
-> Map (Set Natural) (Set Fact) -> FactGroup
forall a b. (a -> b) -> a -> b
$ (Set Natural -> Set Fact -> Bool)
-> Map (Set Natural) (Set Fact) -> Map (Set Natural) (Set Fact)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey Set Natural -> Set Fact -> Bool
forall {p}. Set Natural -> p -> Bool
isAuthorized Map (Set Natural) (Set Fact)
facts

keepAuthorized' :: Bool -> Natural -> FactGroup -> Set EvalRuleScope -> Natural -> FactGroup
keepAuthorized' :: Bool
-> Natural
-> FactGroup
-> Set EvalRuleScope
-> Natural
-> FactGroup
keepAuthorized' Bool
allowPreviousInAuthorizer Natural
blockCount FactGroup
factGroup Set EvalRuleScope
trustedBlocks Natural
currentBlockId =
  let scope :: Set EvalRuleScope
scope = if Set EvalRuleScope -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set EvalRuleScope
trustedBlocks then EvalRuleScope -> Set EvalRuleScope
forall a. a -> Set a
Set.singleton EvalRuleScope
forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
RuleScope' evalCtx ctx
OnlyAuthority
                                    else Set EvalRuleScope
trustedBlocks
      toBlockIds :: EvalRuleScope -> Set Natural
toBlockIds = \case
        EvalRuleScope
OnlyAuthority    -> Natural -> Set Natural
forall a. a -> Set a
Set.singleton Natural
0
        EvalRuleScope
Previous         -> if Bool
allowPreviousInAuthorizer Bool -> Bool -> Bool
|| Natural
currentBlockId Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< Natural
blockCount
                            then [Natural] -> Set Natural
forall a. Ord a => [a] -> Set a
Set.fromList [Natural
0..Natural
currentBlockId]
                            else Set Natural
forall a. Monoid a => a
mempty -- `Previous` is forbidden in the authorizer
                                        -- except when querying the authorizer contents
                                        -- after authorization
        BlockId (Set Natural
idx, PublicKey
_) -> Set Natural
idx
      allBlockIds :: Set Natural
allBlockIds = (EvalRuleScope -> Set Natural) -> Set EvalRuleScope -> Set Natural
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap EvalRuleScope -> Set Natural
toBlockIds Set EvalRuleScope
scope
   in FactGroup -> Set Natural -> FactGroup
keepAuthorized FactGroup
factGroup (Set Natural -> FactGroup) -> Set Natural -> FactGroup
forall a b. (a -> b) -> a -> b
$ Natural -> Set Natural -> Set Natural
forall a. Ord a => a -> Set a -> Set a
Set.insert Natural
currentBlockId (Set Natural -> Set Natural) -> Set Natural -> Set Natural
forall a b. (a -> b) -> a -> b
$ Natural -> Set Natural -> Set Natural
forall a. Ord a => a -> Set a -> Set a
Set.insert Natural
blockCount Set Natural
allBlockIds

toScopedFacts :: FactGroup -> Set (Scoped Fact)
toScopedFacts :: FactGroup -> Set (Scoped Fact)
toScopedFacts (FactGroup Map (Set Natural) (Set Fact)
factGroups) =
  let distributeScope :: t -> Set a -> Set (t, a)
distributeScope t
scope = (a -> (t, a)) -> Set a -> Set (t, a)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (t
scope,)
   in ((Set Natural, Set Fact) -> Set (Scoped Fact))
-> [(Set Natural, Set Fact)] -> Set (Scoped Fact)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Set Natural -> Set Fact -> Set (Scoped Fact))
-> (Set Natural, Set Fact) -> Set (Scoped Fact)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Set Natural -> Set Fact -> Set (Scoped Fact)
forall {t} {a}. (Ord t, Ord a) => t -> Set a -> Set (t, a)
distributeScope) ([(Set Natural, Set Fact)] -> Set (Scoped Fact))
-> [(Set Natural, Set Fact)] -> Set (Scoped Fact)
forall a b. (a -> b) -> a -> b
$ Map (Set Natural) (Set Fact) -> [(Set Natural, Set Fact)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Set Natural) (Set Fact)
factGroups

fromScopedFacts :: Set (Scoped Fact) -> FactGroup
fromScopedFacts :: Set (Scoped Fact) -> FactGroup
fromScopedFacts = Map (Set Natural) (Set Fact) -> FactGroup
FactGroup (Map (Set Natural) (Set Fact) -> FactGroup)
-> (Set (Scoped Fact) -> Map (Set Natural) (Set Fact))
-> Set (Scoped Fact)
-> FactGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Fact -> Set Fact -> Set Fact)
-> [(Set Natural, Set Fact)] -> Map (Set Natural) (Set Fact)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set Fact -> Set Fact -> Set Fact
forall a. Semigroup a => a -> a -> a
(<>) ([(Set Natural, Set Fact)] -> Map (Set Natural) (Set Fact))
-> (Set (Scoped Fact) -> [(Set Natural, Set Fact)])
-> Set (Scoped Fact)
-> Map (Set Natural) (Set Fact)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Set Natural, Set Fact) -> [(Set Natural, Set Fact)]
forall a. Set a -> [a]
Set.toList (Set (Set Natural, Set Fact) -> [(Set Natural, Set Fact)])
-> (Set (Scoped Fact) -> Set (Set Natural, Set Fact))
-> Set (Scoped Fact)
-> [(Set Natural, Set Fact)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scoped Fact -> (Set Natural, Set Fact))
-> Set (Scoped Fact) -> Set (Set Natural, Set Fact)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((Fact -> Set Fact) -> Scoped Fact -> (Set Natural, Set Fact)
forall a b. (a -> b) -> (Set Natural, a) -> (Set Natural, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fact -> Set Fact
forall a. a -> Set a
Set.singleton)

countFacts :: FactGroup -> Int
countFacts :: FactGroup -> Int
countFacts (FactGroup Map (Set Natural) (Set Fact)
facts) = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Set Fact -> Int
forall a. Set a -> Int
Set.size (Set Fact -> Int) -> [Set Fact] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Set Natural) (Set Fact) -> [Set Fact]
forall k a. Map k a -> [a]
Map.elems Map (Set Natural) (Set Fact)
facts

checkCheck :: Limits -> Natural -> Natural -> FactGroup -> EvalCheck -> Either String (Validation (NonEmpty Check) ())
checkCheck :: Limits
-> Natural
-> Natural
-> FactGroup
-> EvalCheck
-> Either String (Validation (NonEmpty Check) ())
checkCheck Limits
l Natural
blockCount Natural
checkBlockId FactGroup
facts c :: EvalCheck
c@Check{Query' 'Eval 'Representation
cQueries :: Query' 'Eval 'Representation
cQueries :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Check' evalCtx ctx -> Query' evalCtx ctx
cQueries,CheckKind
cKind :: CheckKind
cKind :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Check' evalCtx ctx -> CheckKind
cKind} = do
  let queryMatchesOne :: QueryItem' 'Eval 'Representation
-> Either String (Maybe (Set Bindings))
queryMatchesOne = Limits
-> Natural
-> Natural
-> FactGroup
-> QueryItem' 'Eval 'Representation
-> Either String (Maybe (Set Bindings))
isQueryItemSatisfied Limits
l Natural
blockCount Natural
checkBlockId FactGroup
facts
  let queryMatchesAll :: QueryItem' 'Eval 'Representation
-> Either String (Maybe (Set Bindings))
queryMatchesAll = Limits
-> Natural
-> Natural
-> FactGroup
-> QueryItem' 'Eval 'Representation
-> Either String (Maybe (Set Bindings))
isQueryItemSatisfiedForAllMatches Limits
l Natural
blockCount Natural
checkBlockId FactGroup
facts

  case CheckKind
cKind of
    CheckKind
CheckOne -> do
       Bool
hasOkQueryItem <- (QueryItem' 'Eval 'Representation -> Either String Bool)
-> Query' 'Eval 'Representation -> Either String Bool
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m Bool) -> t a -> m Bool
anyM ((Maybe (Set Bindings) -> Bool)
-> Either String (Maybe (Set Bindings)) -> Either String Bool
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Set Bindings) -> Bool
forall a. Maybe a -> Bool
isJust (Either String (Maybe (Set Bindings)) -> Either String Bool)
-> (QueryItem' 'Eval 'Representation
    -> Either String (Maybe (Set Bindings)))
-> QueryItem' 'Eval 'Representation
-> Either String Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryItem' 'Eval 'Representation
-> Either String (Maybe (Set Bindings))
queryMatchesOne) Query' 'Eval 'Representation
cQueries
       Validation (NonEmpty Check) ()
-> Either String (Validation (NonEmpty Check) ())
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Validation (NonEmpty Check) ()
 -> Either String (Validation (NonEmpty Check) ()))
-> Validation (NonEmpty Check) ()
-> Either String (Validation (NonEmpty Check) ())
forall a b. (a -> b) -> a -> b
$ if Bool
hasOkQueryItem
              then () -> Validation (NonEmpty Check) ()
forall e a. a -> Validation e a
Success ()
              else Check -> Validation (NonEmpty Check) ()
forall e a. e -> Validation (NonEmpty e) a
failure (EvalCheck -> Check
forall (elem :: EvaluationContext -> DatalogContext -> *).
ToEvaluation elem =>
elem 'Eval 'Representation -> elem 'Repr 'Representation
toRepresentation EvalCheck
c)
    CheckKind
CheckAll -> do
       Bool
hasOkQueryItem <- (QueryItem' 'Eval 'Representation -> Either String Bool)
-> Query' 'Eval 'Representation -> Either String Bool
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m Bool) -> t a -> m Bool
anyM ((Maybe (Set Bindings) -> Bool)
-> Either String (Maybe (Set Bindings)) -> Either String Bool
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Set Bindings) -> Bool
forall a. Maybe a -> Bool
isJust (Either String (Maybe (Set Bindings)) -> Either String Bool)
-> (QueryItem' 'Eval 'Representation
    -> Either String (Maybe (Set Bindings)))
-> QueryItem' 'Eval 'Representation
-> Either String Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryItem' 'Eval 'Representation
-> Either String (Maybe (Set Bindings))
queryMatchesAll) Query' 'Eval 'Representation
cQueries
       Validation (NonEmpty Check) ()
-> Either String (Validation (NonEmpty Check) ())
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Validation (NonEmpty Check) ()
 -> Either String (Validation (NonEmpty Check) ()))
-> Validation (NonEmpty Check) ()
-> Either String (Validation (NonEmpty Check) ())
forall a b. (a -> b) -> a -> b
$ if Bool
hasOkQueryItem
              then () -> Validation (NonEmpty Check) ()
forall e a. a -> Validation e a
Success ()
              else Check -> Validation (NonEmpty Check) ()
forall e a. e -> Validation (NonEmpty e) a
failure (EvalCheck -> Check
forall (elem :: EvaluationContext -> DatalogContext -> *).
ToEvaluation elem =>
elem 'Eval 'Representation -> elem 'Repr 'Representation
toRepresentation EvalCheck
c)
    CheckKind
Reject -> do
       Bool
hasOkQueryItem <- (QueryItem' 'Eval 'Representation -> Either String Bool)
-> Query' 'Eval 'Representation -> Either String Bool
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m Bool) -> t a -> m Bool
anyM ((Maybe (Set Bindings) -> Bool)
-> Either String (Maybe (Set Bindings)) -> Either String Bool
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Set Bindings) -> Bool
forall a. Maybe a -> Bool
isJust (Either String (Maybe (Set Bindings)) -> Either String Bool)
-> (QueryItem' 'Eval 'Representation
    -> Either String (Maybe (Set Bindings)))
-> QueryItem' 'Eval 'Representation
-> Either String Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryItem' 'Eval 'Representation
-> Either String (Maybe (Set Bindings))
queryMatchesOne) Query' 'Eval 'Representation
cQueries
       Validation (NonEmpty Check) ()
-> Either String (Validation (NonEmpty Check) ())
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Validation (NonEmpty Check) ()
 -> Either String (Validation (NonEmpty Check) ()))
-> Validation (NonEmpty Check) ()
-> Either String (Validation (NonEmpty Check) ())
forall a b. (a -> b) -> a -> b
$ if Bool -> Bool
not Bool
hasOkQueryItem
              then () -> Validation (NonEmpty Check) ()
forall e a. a -> Validation e a
Success ()
              else Check -> Validation (NonEmpty Check) ()
forall e a. e -> Validation (NonEmpty e) a
failure (EvalCheck -> Check
forall (elem :: EvaluationContext -> DatalogContext -> *).
ToEvaluation elem =>
elem 'Eval 'Representation -> elem 'Repr 'Representation
toRepresentation EvalCheck
c)

checkPolicy :: Limits -> Natural -> FactGroup -> EvalPolicy -> Either String (Maybe (Either MatchedQuery MatchedQuery))
checkPolicy :: Limits
-> Natural
-> FactGroup
-> EvalPolicy
-> Either String (Maybe (Either MatchedQuery MatchedQuery))
checkPolicy Limits
l Natural
blockCount FactGroup
facts (PolicyType
pType, Query' 'Eval 'Representation
query) = do
  Set Bindings
bindings <- Maybe (Set Bindings) -> Set Bindings
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Maybe (Set Bindings) -> Set Bindings)
-> ([Maybe (Set Bindings)] -> Maybe (Set Bindings))
-> [Maybe (Set Bindings)]
-> Set Bindings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Set Bindings)] -> Maybe (Set Bindings)
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Maybe (Set Bindings)] -> Set Bindings)
-> Either String [Maybe (Set Bindings)]
-> Either String (Set Bindings)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (QueryItem' 'Eval 'Representation
 -> Either String (Maybe (Set Bindings)))
-> Query' 'Eval 'Representation
-> Either String [Maybe (Set Bindings)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Limits
-> Natural
-> Natural
-> FactGroup
-> QueryItem' 'Eval 'Representation
-> Either String (Maybe (Set Bindings))
isQueryItemSatisfied Limits
l Natural
blockCount Natural
blockCount FactGroup
facts) Query' 'Eval 'Representation
query
  Maybe (Either MatchedQuery MatchedQuery)
-> Either String (Maybe (Either MatchedQuery MatchedQuery))
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Either MatchedQuery MatchedQuery)
 -> Either String (Maybe (Either MatchedQuery MatchedQuery)))
-> Maybe (Either MatchedQuery MatchedQuery)
-> Either String (Maybe (Either MatchedQuery MatchedQuery))
forall a b. (a -> b) -> a -> b
$ if Bool -> Bool
not (Set Bindings -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Bindings
bindings)
         then Either MatchedQuery MatchedQuery
-> Maybe (Either MatchedQuery MatchedQuery)
forall a. a -> Maybe a
Just (Either MatchedQuery MatchedQuery
 -> Maybe (Either MatchedQuery MatchedQuery))
-> Either MatchedQuery MatchedQuery
-> Maybe (Either MatchedQuery MatchedQuery)
forall a b. (a -> b) -> a -> b
$ case PolicyType
pType of
           PolicyType
Allow -> MatchedQuery -> Either MatchedQuery MatchedQuery
forall a b. b -> Either a b
Right (MatchedQuery -> Either MatchedQuery MatchedQuery)
-> MatchedQuery -> Either MatchedQuery MatchedQuery
forall a b. (a -> b) -> a -> b
$ MatchedQuery{matchedQuery :: Query
matchedQuery = QueryItem' 'Eval 'Representation
-> QueryItem' 'Repr 'Representation
forall (elem :: EvaluationContext -> DatalogContext -> *).
ToEvaluation elem =>
elem 'Eval 'Representation -> elem 'Repr 'Representation
toRepresentation (QueryItem' 'Eval 'Representation
 -> QueryItem' 'Repr 'Representation)
-> Query' 'Eval 'Representation -> Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query' 'Eval 'Representation
query, Set Bindings
bindings :: Set Bindings
bindings :: Set Bindings
bindings}
           PolicyType
Deny  -> MatchedQuery -> Either MatchedQuery MatchedQuery
forall a b. a -> Either a b
Left (MatchedQuery -> Either MatchedQuery MatchedQuery)
-> MatchedQuery -> Either MatchedQuery MatchedQuery
forall a b. (a -> b) -> a -> b
$ MatchedQuery{matchedQuery :: Query
matchedQuery = QueryItem' 'Eval 'Representation
-> QueryItem' 'Repr 'Representation
forall (elem :: EvaluationContext -> DatalogContext -> *).
ToEvaluation elem =>
elem 'Eval 'Representation -> elem 'Repr 'Representation
toRepresentation (QueryItem' 'Eval 'Representation
 -> QueryItem' 'Repr 'Representation)
-> Query' 'Eval 'Representation -> Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query' 'Eval 'Representation
query, Set Bindings
bindings :: Set Bindings
bindings :: Set Bindings
bindings}
         else Maybe (Either MatchedQuery MatchedQuery)
forall a. Maybe a
Nothing

isQueryItemSatisfied :: Limits -> Natural -> Natural -> FactGroup -> QueryItem' 'Eval 'Representation -> Either String (Maybe (Set Bindings))
isQueryItemSatisfied :: Limits
-> Natural
-> Natural
-> FactGroup
-> QueryItem' 'Eval 'Representation
-> Either String (Maybe (Set Bindings))
isQueryItemSatisfied Limits
l Natural
blockCount Natural
blockId FactGroup
allFacts QueryItem{[Predicate' 'InPredicate 'Representation]
qBody :: [Predicate' 'InPredicate 'Representation]
qBody :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
QueryItem' evalCtx ctx -> [Predicate' 'InPredicate ctx]
qBody, [Expression]
qExpressions :: [Expression]
qExpressions :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
QueryItem' evalCtx ctx -> [Expression' ctx]
qExpressions, Set EvalRuleScope
qScope :: Set EvalRuleScope
qScope :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
QueryItem' evalCtx ctx -> Set (RuleScope' evalCtx ctx)
qScope} = do
  let removeScope :: Set (a, Bindings) -> Set Bindings
removeScope = ((a, Bindings) -> Bindings) -> Set (a, Bindings) -> Set Bindings
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (a, Bindings) -> Bindings
forall a b. (a, b) -> b
snd
      facts :: Set (Scoped Fact)
facts = FactGroup -> Set (Scoped Fact)
toScopedFacts (FactGroup -> Set (Scoped Fact)) -> FactGroup -> Set (Scoped Fact)
forall a b. (a -> b) -> a -> b
$ Bool
-> Natural
-> FactGroup
-> Set EvalRuleScope
-> Natural
-> FactGroup
keepAuthorized' Bool
False Natural
blockCount FactGroup
allFacts Set EvalRuleScope
qScope Natural
blockId
  Set Bindings
bindings <- Set (Scoped Bindings) -> Set Bindings
forall {a}. Set (a, Bindings) -> Set Bindings
removeScope (Set (Scoped Bindings) -> Set Bindings)
-> Either String (Set (Scoped Bindings))
-> Either String (Set Bindings)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Limits
-> Set (Scoped Fact)
-> [Predicate' 'InPredicate 'Representation]
-> [Expression]
-> Either String (Set (Scoped Bindings))
getBindingsForRuleBody Limits
l Set (Scoped Fact)
facts [Predicate' 'InPredicate 'Representation]
qBody [Expression]
qExpressions
  Maybe (Set Bindings) -> Either String (Maybe (Set Bindings))
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Set Bindings) -> Either String (Maybe (Set Bindings)))
-> Maybe (Set Bindings) -> Either String (Maybe (Set Bindings))
forall a b. (a -> b) -> a -> b
$ if Set Bindings -> Int
forall a. Set a -> Int
Set.size Set Bindings
bindings Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
         then Set Bindings -> Maybe (Set Bindings)
forall a. a -> Maybe a
Just Set Bindings
bindings
         else Maybe (Set Bindings)
forall a. Maybe a
Nothing

-- | Given a set of scoped facts and a rule body, we generate a set of variable
-- bindings that satisfy the rule clauses (predicates match, and expression constraints
-- are fulfilled), and ensure that all bindings where predicates match also fulfill
-- expression constraints. This is the behaviour of `check all`.
isQueryItemSatisfiedForAllMatches :: Limits -> Natural -> Natural -> FactGroup -> QueryItem' 'Eval 'Representation -> Either String (Maybe (Set Bindings))
isQueryItemSatisfiedForAllMatches :: Limits
-> Natural
-> Natural
-> FactGroup
-> QueryItem' 'Eval 'Representation
-> Either String (Maybe (Set Bindings))
isQueryItemSatisfiedForAllMatches Limits
l Natural
blockCount Natural
blockId FactGroup
allFacts QueryItem{[Predicate' 'InPredicate 'Representation]
qBody :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
QueryItem' evalCtx ctx -> [Predicate' 'InPredicate ctx]
qBody :: [Predicate' 'InPredicate 'Representation]
qBody, [Expression]
qExpressions :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
QueryItem' evalCtx ctx -> [Expression' ctx]
qExpressions :: [Expression]
qExpressions, Set EvalRuleScope
qScope :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
QueryItem' evalCtx ctx -> Set (RuleScope' evalCtx ctx)
qScope :: Set EvalRuleScope
qScope} = do
  let removeScope :: Set (a, Bindings) -> Set Bindings
removeScope = ((a, Bindings) -> Bindings) -> Set (a, Bindings) -> Set Bindings
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (a, Bindings) -> Bindings
forall a b. (a, b) -> b
snd
      facts :: Set (Scoped Fact)
facts = FactGroup -> Set (Scoped Fact)
toScopedFacts (FactGroup -> Set (Scoped Fact)) -> FactGroup -> Set (Scoped Fact)
forall a b. (a -> b) -> a -> b
$ Bool
-> Natural
-> FactGroup
-> Set EvalRuleScope
-> Natural
-> FactGroup
keepAuthorized' Bool
False Natural
blockCount FactGroup
allFacts Set EvalRuleScope
qScope Natural
blockId
      allVariables :: Set Name
allVariables = [Predicate' 'InPredicate 'Representation] -> Set Name
forall (ctx :: DatalogContext).
[Predicate' 'InPredicate ctx] -> Set Name
extractVariables [Predicate' 'InPredicate 'Representation]
qBody
      -- bindings that match facts
      candidateBindings :: [Set (Scoped Bindings)]
candidateBindings = Set (Scoped Fact)
-> [Predicate' 'InPredicate 'Representation]
-> [Set (Scoped Bindings)]
getCandidateBindings Set (Scoped Fact)
facts [Predicate' 'InPredicate 'Representation]
qBody
      -- bindings that unify correctly (each variable has a single possible match)
      legalBindingsForFacts :: Set (Scoped Bindings)
legalBindingsForFacts = Set Name -> [Set (Scoped Bindings)] -> Set (Scoped Bindings)
reduceCandidateBindings Set Name
allVariables [Set (Scoped Bindings)]
candidateBindings
      -- bindings that fulfill the constraints
  Set (Scoped Bindings)
constraintFulfillingBindings <- (Scoped Bindings -> Either String Bool)
-> Set (Scoped Bindings) -> Either String (Set (Scoped Bindings))
forall a (m :: * -> *).
(Ord a, Monad m) =>
(a -> m Bool) -> Set a -> m (Set a)
setFilterM (\Scoped Bindings
b -> (Expression -> Either String Bool)
-> [Expression] -> Either String Bool
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m Bool) -> t a -> m Bool
allM (Limits -> Scoped Bindings -> Expression -> Either String Bool
satisfies Limits
l Scoped Bindings
b) [Expression]
qExpressions) Set (Scoped Bindings)
legalBindingsForFacts
  Maybe (Set Bindings) -> Either String (Maybe (Set Bindings))
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Set Bindings) -> Either String (Maybe (Set Bindings)))
-> Maybe (Set Bindings) -> Either String (Maybe (Set Bindings))
forall a b. (a -> b) -> a -> b
$ if Set (Scoped Bindings) -> Int
forall a. Set a -> Int
Set.size Set (Scoped Bindings)
constraintFulfillingBindings Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -- there is at least one match that fulfills the constraints
         Bool -> Bool -> Bool
&& Set (Scoped Bindings)
constraintFulfillingBindings Set (Scoped Bindings) -> Set (Scoped Bindings) -> Bool
forall a. Eq a => a -> a -> Bool
== Set (Scoped Bindings)
legalBindingsForFacts -- all matches fulfill the constraints
         then Set Bindings -> Maybe (Set Bindings)
forall a. a -> Maybe a
Just (Set Bindings -> Maybe (Set Bindings))
-> Set Bindings -> Maybe (Set Bindings)
forall a b. (a -> b) -> a -> b
$ Set (Scoped Bindings) -> Set Bindings
forall {a}. Set (a, Bindings) -> Set Bindings
removeScope Set (Scoped Bindings)
constraintFulfillingBindings
         else Maybe (Set Bindings)
forall a. Maybe a
Nothing

-- | Given a rule and a set of available (scoped) facts, we find all fact
-- combinations that match the rule body, and generate new facts by applying
-- the bindings to the rule head (while keeping track of the facts origins)
getFactsForRule :: Limits -> Set (Scoped Fact) -> EvalRule -> Either String (Set (Scoped Fact))
getFactsForRule :: Limits
-> Set (Scoped Fact)
-> EvalRule
-> Either String (Set (Scoped Fact))
getFactsForRule Limits
l Set (Scoped Fact)
facts Rule{Predicate' 'InPredicate 'Representation
rhead :: Predicate' 'InPredicate 'Representation
rhead :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Rule' evalCtx ctx -> Predicate' 'InPredicate ctx
rhead, [Predicate' 'InPredicate 'Representation]
body :: [Predicate' 'InPredicate 'Representation]
body :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Rule' evalCtx ctx -> [Predicate' 'InPredicate ctx]
body, [Expression]
expressions :: [Expression]
expressions :: forall (evalCtx :: EvaluationContext) (ctx :: DatalogContext).
Rule' evalCtx ctx -> [Expression' ctx]
expressions} = do
  Set (Scoped Bindings)
legalBindings <- Limits
-> Set (Scoped Fact)
-> [Predicate' 'InPredicate 'Representation]
-> [Expression]
-> Either String (Set (Scoped Bindings))
getBindingsForRuleBody Limits
l Set (Scoped Fact)
facts [Predicate' 'InPredicate 'Representation]
body [Expression]
expressions
  Set (Scoped Fact) -> Either String (Set (Scoped Fact))
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set (Scoped Fact) -> Either String (Set (Scoped Fact)))
-> Set (Scoped Fact) -> Either String (Set (Scoped Fact))
forall a b. (a -> b) -> a -> b
$ [Scoped Fact] -> Set (Scoped Fact)
forall a. Ord a => [a] -> Set a
Set.fromList ([Scoped Fact] -> Set (Scoped Fact))
-> [Scoped Fact] -> Set (Scoped Fact)
forall a b. (a -> b) -> a -> b
$ (Scoped Bindings -> Maybe (Scoped Fact))
-> [Scoped Bindings] -> [Scoped Fact]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Predicate' 'InPredicate 'Representation
-> Scoped Bindings -> Maybe (Scoped Fact)
applyBindings Predicate' 'InPredicate 'Representation
rhead) ([Scoped Bindings] -> [Scoped Fact])
-> [Scoped Bindings] -> [Scoped Fact]
forall a b. (a -> b) -> a -> b
$ Set (Scoped Bindings) -> [Scoped Bindings]
forall a. Set a -> [a]
Set.toList Set (Scoped Bindings)
legalBindings

-- | Given a set of scoped facts and a rule body, we generate a set of variable
-- bindings that satisfy the rule clauses (predicates match, and expression constraints
-- are fulfilled)
getBindingsForRuleBody :: Limits -> Set (Scoped Fact) -> [Predicate] -> [Expression] -> Either String (Set (Scoped Bindings))
getBindingsForRuleBody :: Limits
-> Set (Scoped Fact)
-> [Predicate' 'InPredicate 'Representation]
-> [Expression]
-> Either String (Set (Scoped Bindings))
getBindingsForRuleBody Limits
l Set (Scoped Fact)
facts [Predicate' 'InPredicate 'Representation]
body [Expression]
expressions =
  let -- gather bindings from all the facts that match the query's predicates
      candidateBindings :: [Set (Scoped Bindings)]
candidateBindings = Set (Scoped Fact)
-> [Predicate' 'InPredicate 'Representation]
-> [Set (Scoped Bindings)]
getCandidateBindings Set (Scoped Fact)
facts [Predicate' 'InPredicate 'Representation]
body
      allVariables :: Set Name
allVariables = [Predicate' 'InPredicate 'Representation] -> Set Name
forall (ctx :: DatalogContext).
[Predicate' 'InPredicate ctx] -> Set Name
extractVariables [Predicate' 'InPredicate 'Representation]
body
      -- only keep bindings combinations where each variable has a single possible match
      legalBindingsForFacts :: Set (Scoped Bindings)
legalBindingsForFacts = Set Name -> [Set (Scoped Bindings)] -> Set (Scoped Bindings)
reduceCandidateBindings Set Name
allVariables [Set (Scoped Bindings)]
candidateBindings
      -- only keep bindings that satisfy the query expressions
   in (Scoped Bindings -> Either String Bool)
-> Set (Scoped Bindings) -> Either String (Set (Scoped Bindings))
forall a (m :: * -> *).
(Ord a, Monad m) =>
(a -> m Bool) -> Set a -> m (Set a)
setFilterM (\Scoped Bindings
b -> (Expression -> Either String Bool)
-> [Expression] -> Either String Bool
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m Bool) -> t a -> m Bool
allM (Limits -> Scoped Bindings -> Expression -> Either String Bool
satisfies Limits
l Scoped Bindings
b) [Expression]
expressions) Set (Scoped Bindings)
legalBindingsForFacts

satisfies :: Limits
          -> Scoped Bindings
          -> Expression
          -> Either String Bool
satisfies :: Limits -> Scoped Bindings -> Expression -> Either String Bool
satisfies Limits
l Scoped Bindings
b Expression
e = (Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool Bool
True) (Value -> Bool) -> Either String Value -> Either String Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l (Scoped Bindings -> Bindings
forall a b. (a, b) -> b
snd Scoped Bindings
b) Expression
e

applyBindings :: Predicate -> Scoped Bindings -> Maybe (Scoped Fact)
applyBindings :: Predicate' 'InPredicate 'Representation
-> Scoped Bindings -> Maybe (Scoped Fact)
applyBindings p :: Predicate' 'InPredicate 'Representation
p@Predicate{[Term' 'NotWithinSet 'InPredicate 'Representation]
terms :: [Term' 'NotWithinSet 'InPredicate 'Representation]
terms :: forall (pof :: PredicateOrFact) (ctx :: DatalogContext).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms} (Set Natural
origins, Bindings
bindings) =
  let newTerms :: Maybe [Value]
newTerms = (Term' 'NotWithinSet 'InPredicate 'Representation -> Maybe Value)
-> [Term' 'NotWithinSet 'InPredicate 'Representation]
-> Maybe [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Term' 'NotWithinSet 'InPredicate 'Representation -> Maybe Value
replaceTerm [Term' 'NotWithinSet 'InPredicate 'Representation]
terms
      replaceTerm :: Term -> Maybe Value
      replaceTerm :: Term' 'NotWithinSet 'InPredicate 'Representation -> Maybe Value
replaceTerm (Variable VariableType 'NotWithinSet 'InPredicate
n)  = Name -> Bindings -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
VariableType 'NotWithinSet 'InPredicate
n Bindings
bindings
      replaceTerm (LInteger Int64
t)  = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger Int64
t
      replaceTerm (LString Name
t)   = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString Name
t
      replaceTerm (LDate UTCTime
t)     = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ UTCTime -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
UTCTime -> Term' inSet pof ctx
LDate UTCTime
t
      replaceTerm (LBytes ByteString
t)    = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
ByteString -> Term' inSet pof ctx
LBytes ByteString
t
      replaceTerm (LBool Bool
t)     = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool Bool
t
      replaceTerm Term' 'NotWithinSet 'InPredicate 'Representation
LNull         = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Term' inSet pof ctx
LNull
      replaceTerm (TermSet SetType 'NotWithinSet 'Representation
t)   = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ SetType 'NotWithinSet 'Representation -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
SetType inSet ctx -> Term' inSet pof ctx
TermSet SetType 'NotWithinSet 'Representation
t
      replaceTerm (TermArray ArrayType 'NotWithinSet 'Representation
t) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ ArrayType 'NotWithinSet 'Representation -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
ArrayType inSet ctx -> Term' inSet pof ctx
TermArray ArrayType 'NotWithinSet 'Representation
t
      replaceTerm (TermMap MapType 'NotWithinSet 'Representation
t)   = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ MapType 'NotWithinSet 'Representation -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
MapType inSet ctx -> Term' inSet pof ctx
TermMap MapType 'NotWithinSet 'Representation
t
      replaceTerm (Antiquote SliceType 'Representation
t) = Void -> Maybe Value
forall a. Void -> a
absurd Void
SliceType 'Representation
t
   in (\[Value]
nt -> (Set Natural
origins, Predicate' 'InPredicate 'Representation
p { terms :: [Value]
terms = [Value]
nt})) ([Value] -> Scoped Fact) -> Maybe [Value] -> Maybe (Scoped Fact)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Value]
newTerms

-- | Given a list of possible matches for each predicate,
-- give all the combinations of one match per predicate,
-- keeping track of the origin of each match
getCombinations :: [[Scoped Bindings]] -> [Scoped [Bindings]]
getCombinations :: [[Scoped Bindings]] -> [Scoped [Bindings]]
getCombinations = Compose [] ((,) (Set Natural)) [Bindings] -> [Scoped [Bindings]]
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose [] ((,) (Set Natural)) [Bindings] -> [Scoped [Bindings]])
-> ([[Scoped Bindings]]
    -> Compose [] ((,) (Set Natural)) [Bindings])
-> [[Scoped Bindings]]
-> [Scoped [Bindings]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Scoped Bindings] -> Compose [] ((,) (Set Natural)) Bindings)
-> [[Scoped Bindings]] -> Compose [] ((,) (Set Natural)) [Bindings]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [Scoped Bindings] -> Compose [] ((,) (Set Natural)) Bindings
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose

-- | merge a list of bindings, only keeping variables where
-- bindings are consistent
mergeBindings :: [Bindings] -> Bindings
mergeBindings :: [Bindings] -> Bindings
mergeBindings =
  -- group all the values unified with each variable
  let combinations :: [Bindings] -> Map Name (NonEmpty Value)
      combinations :: [Bindings] -> Map Name (NonEmpty Value)
combinations = (NonEmpty Value -> NonEmpty Value -> NonEmpty Value)
-> [Map Name (NonEmpty Value)] -> Map Name (NonEmpty Value)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith NonEmpty Value -> NonEmpty Value -> NonEmpty Value
forall a. Semigroup a => a -> a -> a
(<>) ([Map Name (NonEmpty Value)] -> Map Name (NonEmpty Value))
-> ([Bindings] -> [Map Name (NonEmpty Value)])
-> [Bindings]
-> Map Name (NonEmpty Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bindings -> Map Name (NonEmpty Value))
-> [Bindings] -> [Map Name (NonEmpty Value)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Value -> NonEmpty Value) -> Bindings -> Map Name (NonEmpty Value)
forall a b. (a -> b) -> Map Name a -> Map Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> NonEmpty Value
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
      sameValues :: NonEmpty Value -> Maybe Value
sameValues = (NonEmpty Value -> Value) -> Maybe (NonEmpty Value) -> Maybe Value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty Value -> Value
forall a. NonEmpty a -> a
NE.head (Maybe (NonEmpty Value) -> Maybe Value)
-> (NonEmpty Value -> Maybe (NonEmpty Value))
-> NonEmpty Value
-> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty Value -> Bool)
-> Maybe (NonEmpty Value) -> Maybe (NonEmpty Value)
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> (NonEmpty Value -> Int) -> NonEmpty Value -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Value -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) (Maybe (NonEmpty Value) -> Maybe (NonEmpty Value))
-> (NonEmpty Value -> Maybe (NonEmpty Value))
-> NonEmpty Value
-> Maybe (NonEmpty Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Value -> Maybe (NonEmpty Value)
forall a. a -> Maybe a
Just (NonEmpty Value -> Maybe (NonEmpty Value))
-> (NonEmpty Value -> NonEmpty Value)
-> NonEmpty Value
-> Maybe (NonEmpty Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Value -> NonEmpty Value
forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub
  -- only keep consistent matches, where each variable takes a single value
      keepConsistent :: Map k (NonEmpty Value) -> Map k Value
keepConsistent = (NonEmpty Value -> Maybe Value)
-> Map k (NonEmpty Value) -> Map k Value
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe NonEmpty Value -> Maybe Value
sameValues
   in Map Name (NonEmpty Value) -> Bindings
forall {k}. Map k (NonEmpty Value) -> Map k Value
keepConsistent (Map Name (NonEmpty Value) -> Bindings)
-> ([Bindings] -> Map Name (NonEmpty Value))
-> [Bindings]
-> Bindings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bindings] -> Map Name (NonEmpty Value)
combinations

-- | given a set of bindings for each predicate of a query,
-- only keep combinations where every variable matches exactly
-- one value. This rejects both inconsitent bindings (where the
-- same variable
reduceCandidateBindings :: Set Name
                        -> [Set (Scoped Bindings)]
                        -> Set (Scoped Bindings)
reduceCandidateBindings :: Set Name -> [Set (Scoped Bindings)] -> Set (Scoped Bindings)
reduceCandidateBindings Set Name
allVariables [Set (Scoped Bindings)]
matches =
  let allCombinations :: [(Set Natural, [Bindings])]
      allCombinations :: [Scoped [Bindings]]
allCombinations = [[Scoped Bindings]] -> [Scoped [Bindings]]
getCombinations ([[Scoped Bindings]] -> [Scoped [Bindings]])
-> [[Scoped Bindings]] -> [Scoped [Bindings]]
forall a b. (a -> b) -> a -> b
$ Set (Scoped Bindings) -> [Scoped Bindings]
forall a. Set a -> [a]
Set.toList (Set (Scoped Bindings) -> [Scoped Bindings])
-> [Set (Scoped Bindings)] -> [[Scoped Bindings]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Set (Scoped Bindings)]
matches
      isComplete :: Scoped Bindings -> Bool
      isComplete :: Scoped Bindings -> Bool
isComplete = (Set Name -> Set Name -> Bool
forall a. Eq a => a -> a -> Bool
== Set Name
allVariables) (Set Name -> Bool)
-> (Scoped Bindings -> Set Name) -> Scoped Bindings -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name)
-> (Scoped Bindings -> [Name]) -> Scoped Bindings -> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bindings -> [Name]
forall k a. Map k a -> [k]
Map.keys (Bindings -> [Name])
-> (Scoped Bindings -> Bindings) -> Scoped Bindings -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scoped Bindings -> Bindings
forall a b. (a, b) -> b
snd
   in [Scoped Bindings] -> Set (Scoped Bindings)
forall a. Ord a => [a] -> Set a
Set.fromList ([Scoped Bindings] -> Set (Scoped Bindings))
-> [Scoped Bindings] -> Set (Scoped Bindings)
forall a b. (a -> b) -> a -> b
$ (Scoped Bindings -> Bool) -> [Scoped Bindings] -> [Scoped Bindings]
forall a. (a -> Bool) -> [a] -> [a]
filter Scoped Bindings -> Bool
isComplete ([Scoped Bindings] -> [Scoped Bindings])
-> [Scoped Bindings] -> [Scoped Bindings]
forall a b. (a -> b) -> a -> b
$ ([Bindings] -> Bindings) -> Scoped [Bindings] -> Scoped Bindings
forall a b. (a -> b) -> (Set Natural, a) -> (Set Natural, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bindings] -> Bindings
mergeBindings (Scoped [Bindings] -> Scoped Bindings)
-> [Scoped [Bindings]] -> [Scoped Bindings]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Scoped [Bindings]]
allCombinations

-- | Given a set of facts and a series of predicates, return, for each fact,
-- a set of bindings corresponding to matched facts
getCandidateBindings :: Set (Scoped Fact)
                     -> [Predicate]
                     -> [Set (Scoped Bindings)]
getCandidateBindings :: Set (Scoped Fact)
-> [Predicate' 'InPredicate 'Representation]
-> [Set (Scoped Bindings)]
getCandidateBindings Set (Scoped Fact)
facts [Predicate' 'InPredicate 'Representation]
predicates =
   let mapMaybeS :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
       mapMaybeS :: forall a b. (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
mapMaybeS a -> Maybe b
f = (a -> Set b) -> Set a -> Set b
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((b -> Set b) -> Maybe b -> Set b
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap b -> Set b
forall a. a -> Set a
Set.singleton (Maybe b -> Set b) -> (a -> Maybe b) -> a -> Set b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
f)
       keepFacts :: Predicate -> Set (Scoped Bindings)
       keepFacts :: Predicate' 'InPredicate 'Representation -> Set (Scoped Bindings)
keepFacts Predicate' 'InPredicate 'Representation
p = (Scoped Fact -> Maybe (Scoped Bindings))
-> Set (Scoped Fact) -> Set (Scoped Bindings)
forall a b. (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
mapMaybeS (Predicate' 'InPredicate 'Representation
-> Scoped Fact -> Maybe (Scoped Bindings)
factMatchesPredicate Predicate' 'InPredicate 'Representation
p) Set (Scoped Fact)
facts
    in Predicate' 'InPredicate 'Representation -> Set (Scoped Bindings)
keepFacts (Predicate' 'InPredicate 'Representation -> Set (Scoped Bindings))
-> [Predicate' 'InPredicate 'Representation]
-> [Set (Scoped Bindings)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Predicate' 'InPredicate 'Representation]
predicates

isSame :: Term -> Value -> Bool
isSame :: Term' 'NotWithinSet 'InPredicate 'Representation -> Value -> Bool
isSame (LInteger Int64
t) (LInteger Int64
t') = Int64
t Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
t'
isSame (LString Name
t)  (LString Name
t')  = Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
t'
isSame (LDate UTCTime
t)    (LDate UTCTime
t')    = UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
t'
isSame (LBytes ByteString
t)   (LBytes ByteString
t')   = ByteString
t ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
t'
isSame (LBool Bool
t)    (LBool Bool
t')    = Bool
t Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
t'
isSame (TermSet SetType 'NotWithinSet 'Representation
t)  (TermSet SetType 'NotWithinSet 'Representation
t')  = Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
t Set (Term' 'WithinSet 'InFact 'Representation)
-> Set (Term' 'WithinSet 'InFact 'Representation) -> Bool
forall a. Eq a => a -> a -> Bool
== Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
t'
isSame Term' 'NotWithinSet 'InPredicate 'Representation
LNull        Value
LNull         = Bool
True
isSame Term' 'NotWithinSet 'InPredicate 'Representation
_ Value
_                        = Bool
False

-- | Given a predicate and a fact, try to match the fact to the predicate,
-- and, in case of success, return the corresponding bindings
factMatchesPredicate :: Predicate -> Scoped Fact -> Maybe (Scoped Bindings)
factMatchesPredicate :: Predicate' 'InPredicate 'Representation
-> Scoped Fact -> Maybe (Scoped Bindings)
factMatchesPredicate Predicate{name :: forall (pof :: PredicateOrFact) (ctx :: DatalogContext).
Predicate' pof ctx -> Name
name = Name
predicateName, terms :: forall (pof :: PredicateOrFact) (ctx :: DatalogContext).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms = [Term' 'NotWithinSet 'InPredicate 'Representation]
predicateTerms }
                     ( Set Natural
factOrigins
                     , Predicate{name :: forall (pof :: PredicateOrFact) (ctx :: DatalogContext).
Predicate' pof ctx -> Name
name = Name
factName, terms :: forall (pof :: PredicateOrFact) (ctx :: DatalogContext).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms = [Value]
factTerms }
                     ) =
  let namesMatch :: Bool
namesMatch = Name
predicateName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
factName
      lengthsMatch :: Bool
lengthsMatch = [Term' 'NotWithinSet 'InPredicate 'Representation] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term' 'NotWithinSet 'InPredicate 'Representation]
predicateTerms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
factTerms
      allMatches :: Maybe [Bindings]
allMatches = (Term' 'NotWithinSet 'InPredicate 'Representation
 -> Value -> Maybe Bindings)
-> [Term' 'NotWithinSet 'InPredicate 'Representation]
-> [Value]
-> Maybe [Bindings]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Term' 'NotWithinSet 'InPredicate 'Representation
-> Value -> Maybe Bindings
compatibleMatch [Term' 'NotWithinSet 'InPredicate 'Representation]
predicateTerms [Value]
factTerms
      -- given a term and a value, generate (possibly empty) bindings if
      -- they can be unified:
      --   - if the term is a variable, then it can be unified with the value,
      --     generating a new binding pair
      --   - if the term is equal to the value then it can be unified, but no bindings
      --     are generated
      --   - if the term is a different value, then they can't be unified
      compatibleMatch :: Term -> Value -> Maybe Bindings
      compatibleMatch :: Term' 'NotWithinSet 'InPredicate 'Representation
-> Value -> Maybe Bindings
compatibleMatch (Variable VariableType 'NotWithinSet 'InPredicate
vname) Value
value = Bindings -> Maybe Bindings
forall a. a -> Maybe a
Just (Name -> Value -> Bindings
forall k a. k -> a -> Map k a
Map.singleton Name
VariableType 'NotWithinSet 'InPredicate
vname Value
value)
      compatibleMatch Term' 'NotWithinSet 'InPredicate 'Representation
t Value
t' | Term' 'NotWithinSet 'InPredicate 'Representation -> Value -> Bool
isSame Term' 'NotWithinSet 'InPredicate 'Representation
t Value
t' = Bindings -> Maybe Bindings
forall a. a -> Maybe a
Just Bindings
forall a. Monoid a => a
mempty
                | Bool
otherwise   = Maybe Bindings
forall a. Maybe a
Nothing
   in if Bool
namesMatch Bool -> Bool -> Bool
&& Bool
lengthsMatch
      then (Set Natural
factOrigins,) (Bindings -> Scoped Bindings)
-> ([Bindings] -> Bindings) -> [Bindings] -> Scoped Bindings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bindings] -> Bindings
mergeBindings ([Bindings] -> Scoped Bindings)
-> Maybe [Bindings] -> Maybe (Scoped Bindings)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Bindings]
allMatches
      else Maybe (Scoped Bindings)
forall a. Maybe a
Nothing

applyVariable :: Bindings
              -> Term
              -> Either String Value
applyVariable :: Bindings
-> Term' 'NotWithinSet 'InPredicate 'Representation
-> Either String Value
applyVariable Bindings
bindings = \case
  Variable VariableType 'NotWithinSet 'InPredicate
n  -> String -> Maybe Value -> Either String Value
forall b a. b -> Maybe a -> Either b a
maybeToRight String
"Unbound variable" (Maybe Value -> Either String Value)
-> Maybe Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bindings
bindings Bindings -> Name -> Maybe Value
forall k a. Ord k => Map k a -> k -> Maybe a
!? Name
VariableType 'NotWithinSet 'InPredicate
n
  LInteger Int64
t  -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger Int64
t
  LString Name
t   -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString Name
t
  LDate UTCTime
t     -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ UTCTime -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
UTCTime -> Term' inSet pof ctx
LDate UTCTime
t
  LBytes ByteString
t    -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
ByteString -> Term' inSet pof ctx
LBytes ByteString
t
  LBool Bool
t     -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool Bool
t
  Term' 'NotWithinSet 'InPredicate 'Representation
LNull       -> Value -> Either String Value
forall a b. b -> Either a b
Right Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Term' inSet pof ctx
LNull
  TermSet SetType 'NotWithinSet 'Representation
t   -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ SetType 'NotWithinSet 'Representation -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
SetType inSet ctx -> Term' inSet pof ctx
TermSet SetType 'NotWithinSet 'Representation
t
  TermArray ArrayType 'NotWithinSet 'Representation
t   -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ ArrayType 'NotWithinSet 'Representation -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
ArrayType inSet ctx -> Term' inSet pof ctx
TermArray ArrayType 'NotWithinSet 'Representation
t
  TermMap MapType 'NotWithinSet 'Representation
t   -> Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ MapType 'NotWithinSet 'Representation -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
MapType inSet ctx -> Term' inSet pof ctx
TermMap MapType 'NotWithinSet 'Representation
t
  Antiquote SliceType 'Representation
v -> Void -> Either String Value
forall a. Void -> a
absurd Void
SliceType 'Representation
v

evalUnary :: Limits -> Unary -> Value -> Either String Value
evalUnary :: Limits -> Unary -> Value -> Either String Value
evalUnary Limits
_ Unary
Parens Value
t = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
t
evalUnary Limits
_ Unary
Negate (LBool Bool
b) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
b)
evalUnary Limits
_ Unary
Negate Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only booleans support negation"
evalUnary Limits
_ Unary
Length (LString Name
t) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Int -> Value) -> Int -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger (Int64 -> Value) -> (Int -> Int64) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Either String Value) -> Int -> Either String Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
ByteString.length (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ Name -> ByteString
Text.encodeUtf8 Name
t
evalUnary Limits
_ Unary
Length (LBytes ByteString
bs) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Int -> Value) -> Int -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger (Int64 -> Value) -> (Int -> Int64) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Either String Value) -> Int -> Either String Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
ByteString.length ByteString
bs
evalUnary Limits
_ Unary
Length (TermSet SetType 'NotWithinSet 'Representation
s) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Int -> Value) -> Int -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger (Int64 -> Value) -> (Int -> Int64) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Either String Value) -> Int -> Either String Value
forall a b. (a -> b) -> a -> b
$ Set (Term' 'WithinSet 'InFact 'Representation) -> Int
forall a. Set a -> Int
Set.size Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
s
evalUnary Limits
_ Unary
Length (TermArray ArrayType 'NotWithinSet 'Representation
s) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Int -> Value) -> Int -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger (Int64 -> Value) -> (Int -> Int64) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Either String Value) -> Int -> Either String Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
ArrayType 'NotWithinSet 'Representation
s
evalUnary Limits
_ Unary
Length (TermMap MapType 'NotWithinSet 'Representation
s) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Int -> Value) -> Int -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger (Int64 -> Value) -> (Int -> Int64) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Either String Value) -> Int -> Either String Value
forall a b. (a -> b) -> a -> b
$ Map MapKey Value -> Int
forall k a. Map k a -> Int
Map.size Map MapKey Value
MapType 'NotWithinSet 'Representation
s
evalUnary Limits
_ Unary
Length Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only strings, bytes, sets, arrays and maps support `.length()`"
evalUnary Limits
_ Unary
TypeOf (LInteger Int64
_) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Name -> Value) -> Name -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString (Name -> Either String Value) -> Name -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name
"integer"
evalUnary Limits
_ Unary
TypeOf (LString Name
_) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Name -> Value) -> Name -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString (Name -> Either String Value) -> Name -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name
"string"
evalUnary Limits
_ Unary
TypeOf (LDate UTCTime
_) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Name -> Value) -> Name -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString (Name -> Either String Value) -> Name -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name
"date"
evalUnary Limits
_ Unary
TypeOf (LBytes ByteString
_) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Name -> Value) -> Name -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString (Name -> Either String Value) -> Name -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name
"bytes"
evalUnary Limits
_ Unary
TypeOf (LBool Bool
_) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Name -> Value) -> Name -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString (Name -> Either String Value) -> Name -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name
"bool"
evalUnary Limits
_ Unary
TypeOf (TermSet SetType 'NotWithinSet 'Representation
_) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Name -> Value) -> Name -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString (Name -> Either String Value) -> Name -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name
"set"
evalUnary Limits
_ Unary
TypeOf (TermArray ArrayType 'NotWithinSet 'Representation
_) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Name -> Value) -> Name -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString (Name -> Either String Value) -> Name -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name
"array"
evalUnary Limits
_ Unary
TypeOf (TermMap MapType 'NotWithinSet 'Representation
_) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Name -> Value) -> Name -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString (Name -> Either String Value) -> Name -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name
"map"
evalUnary Limits
_ Unary
TypeOf Value
LNull = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Name -> Value) -> Name -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString (Name -> Either String Value) -> Name -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name
"null"
evalUnary Limits
_ Unary
TypeOf (Variable VariableType 'NotWithinSet 'InFact
v) = Void -> Either String Value
forall a. Void -> a
absurd Void
VariableType 'NotWithinSet 'InFact
v
evalUnary Limits
_ Unary
TypeOf (Antiquote SliceType 'Representation
v) = Void -> Either String Value
forall a. Void -> a
absurd Void
SliceType 'Representation
v
evalUnary Limits{ExternFuncs
externFuncs :: Limits -> ExternFuncs
externFuncs :: ExternFuncs
externFuncs} (UnaryFfi Name
n) Value
v = ExternFuncs -> Name -> Value -> Maybe Value -> Either String Value
runExternFunc ExternFuncs
externFuncs Name
n Value
v Maybe Value
forall a. Maybe a
Nothing

evalBinary :: Limits -> Binary -> Value -> Value -> Either String Value
-- eq / ord operations
evalBinary :: Limits -> Binary -> Value -> Value -> Either String Value
evalBinary Limits
_ Binary
Equal (LInteger Int64
i) (LInteger Int64
i')   = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Int64
i Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
i')
evalBinary Limits
_ Binary
Equal (LString Name
t) (LString Name
t')     = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
t')
evalBinary Limits
_ Binary
Equal (LDate UTCTime
t) (LDate UTCTime
t')         = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
t')
evalBinary Limits
_ Binary
Equal (LBytes ByteString
t) (LBytes ByteString
t')       = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (ByteString
t ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
t')
evalBinary Limits
_ Binary
Equal (LBool Bool
t) (LBool Bool
t')         = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool
t Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
t')
evalBinary Limits
_ Binary
Equal (TermSet SetType 'NotWithinSet 'Representation
t) (TermSet SetType 'NotWithinSet 'Representation
t')     = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
t Set (Term' 'WithinSet 'InFact 'Representation)
-> Set (Term' 'WithinSet 'InFact 'Representation) -> Bool
forall a. Eq a => a -> a -> Bool
== Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
t')
evalBinary Limits
_ Binary
Equal (TermArray ArrayType 'NotWithinSet 'Representation
t) (TermArray ArrayType 'NotWithinSet 'Representation
t') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool ([Value]
ArrayType 'NotWithinSet 'Representation
t [Value] -> [Value] -> Bool
forall a. Eq a => a -> a -> Bool
== [Value]
ArrayType 'NotWithinSet 'Representation
t')
evalBinary Limits
_ Binary
Equal (TermMap MapType 'NotWithinSet 'Representation
t) (TermMap MapType 'NotWithinSet 'Representation
t')     = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Map MapKey Value
MapType 'NotWithinSet 'Representation
t Map MapKey Value -> Map MapKey Value -> Bool
forall a. Eq a => a -> a -> Bool
== Map MapKey Value
MapType 'NotWithinSet 'Representation
t')
evalBinary Limits
_ Binary
Equal Value
_ Value
_                          = String -> Either String Value
forall a b. a -> Either a b
Left String
"Equality mismatch"
evalBinary Limits
_ Binary
NotEqual (LInteger Int64
i) (LInteger Int64
i')   = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Int64
i Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
i')
evalBinary Limits
_ Binary
NotEqual (LString Name
t) (LString Name
t')     = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
t')
evalBinary Limits
_ Binary
NotEqual (LDate UTCTime
t) (LDate UTCTime
t')         = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
/= UTCTime
t')
evalBinary Limits
_ Binary
NotEqual (LBytes ByteString
t) (LBytes ByteString
t')       = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (ByteString
t ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
t')
evalBinary Limits
_ Binary
NotEqual (LBool Bool
t) (LBool Bool
t')         = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool
t Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
t')
evalBinary Limits
_ Binary
NotEqual (TermSet SetType 'NotWithinSet 'Representation
t) (TermSet SetType 'NotWithinSet 'Representation
t')     = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
t Set (Term' 'WithinSet 'InFact 'Representation)
-> Set (Term' 'WithinSet 'InFact 'Representation) -> Bool
forall a. Eq a => a -> a -> Bool
/= Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
t')
evalBinary Limits
_ Binary
NotEqual (TermArray ArrayType 'NotWithinSet 'Representation
t) (TermArray ArrayType 'NotWithinSet 'Representation
t') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool ([Value]
ArrayType 'NotWithinSet 'Representation
t [Value] -> [Value] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Value]
ArrayType 'NotWithinSet 'Representation
t')
evalBinary Limits
_ Binary
NotEqual (TermMap MapType 'NotWithinSet 'Representation
t) (TermMap MapType 'NotWithinSet 'Representation
t')     = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Map MapKey Value
MapType 'NotWithinSet 'Representation
t Map MapKey Value -> Map MapKey Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Map MapKey Value
MapType 'NotWithinSet 'Representation
t')
evalBinary Limits
_ Binary
NotEqual Value
_ Value
_                          = String -> Either String Value
forall a b. a -> Either a b
Left String
"Inequity mismatch"
evalBinary Limits
_ Binary
HeterogeneousEqual Value
t Value
t'             = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Value
t Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
t')
evalBinary Limits
_ Binary
HeterogeneousNotEqual Value
t Value
t'          = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Value
t Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
t')
evalBinary Limits
_ Binary
LessThan (LInteger Int64
i) (LInteger Int64
i') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
i')
evalBinary Limits
_ Binary
LessThan (LDate UTCTime
t) (LDate UTCTime
t')       = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
t')
evalBinary Limits
_ Binary
LessThan Value
_ Value
_                        = String -> Either String Value
forall a b. a -> Either a b
Left String
"< mismatch"
evalBinary Limits
_ Binary
GreaterThan (LInteger Int64
i) (LInteger Int64
i') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
i')
evalBinary Limits
_ Binary
GreaterThan (LDate UTCTime
t) (LDate UTCTime
t')       = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
t')
evalBinary Limits
_ Binary
GreaterThan Value
_ Value
_                        = String -> Either String Value
forall a b. a -> Either a b
Left String
"> mismatch"
evalBinary Limits
_ Binary
LessOrEqual (LInteger Int64
i) (LInteger Int64
i') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
i')
evalBinary Limits
_ Binary
LessOrEqual (LDate UTCTime
t) (LDate UTCTime
t')       = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
t')
evalBinary Limits
_ Binary
LessOrEqual Value
_ Value
_                        = String -> Either String Value
forall a b. a -> Either a b
Left String
"<= mismatch"
evalBinary Limits
_ Binary
GreaterOrEqual (LInteger Int64
i) (LInteger Int64
i') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
i')
evalBinary Limits
_ Binary
GreaterOrEqual (LDate UTCTime
t) (LDate UTCTime
t')       = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
t')
evalBinary Limits
_ Binary
GreaterOrEqual Value
_ Value
_                        = String -> Either String Value
forall a b. a -> Either a b
Left String
">= mismatch"
-- string-related operations
evalBinary Limits
_ Binary
Prefix (LString Name
t) (LString Name
t') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Name
t' Name -> Name -> Bool
`Text.isPrefixOf` Name
t)
evalBinary Limits
_ Binary
Prefix (TermArray ArrayType 'NotWithinSet 'Representation
t) (TermArray ArrayType 'NotWithinSet 'Representation
t') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Bool -> Value) -> Bool -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Either String Value) -> Bool -> Either String Value
forall a b. (a -> b) -> a -> b
$ [Value]
ArrayType 'NotWithinSet 'Representation
t' [Value] -> [Value] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` [Value]
ArrayType 'NotWithinSet 'Representation
t
evalBinary Limits
_ Binary
Prefix Value
_ Value
_                      = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only strings and arrays support `.starts_with()`"
evalBinary Limits
_ Binary
Suffix (LString Name
t) (LString Name
t') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Name
t' Name -> Name -> Bool
`Text.isSuffixOf` Name
t)
evalBinary Limits
_ Binary
Suffix (TermArray ArrayType 'NotWithinSet 'Representation
t) (TermArray ArrayType 'NotWithinSet 'Representation
t') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Bool -> Value) -> Bool -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Either String Value) -> Bool -> Either String Value
forall a b. (a -> b) -> a -> b
$ [Value]
ArrayType 'NotWithinSet 'Representation
t' [Value] -> [Value] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isSuffixOf` [Value]
ArrayType 'NotWithinSet 'Representation
t
evalBinary Limits
_ Binary
Suffix Value
_ Value
_                      = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only strings support `.ends_with()`"
evalBinary Limits{Bool
allowRegexes :: Limits -> Bool
allowRegexes :: Bool
allowRegexes} Binary
Regex  (LString Name
t) (LString Name
r) | Bool
allowRegexes = Name -> Name -> Either String Value
regexMatch Name
t Name
r
                                                               | Bool
otherwise    = String -> Either String Value
forall a b. a -> Either a b
Left String
"Regex evaluation is disabled"
evalBinary Limits
_ Binary
Regex Value
_ Value
_                       = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only strings support `.matches()`"
-- num operations
evalBinary Limits
_ Binary
Add (LInteger Int64
i) (LInteger Int64
i') = Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger (Int64 -> Value) -> Either String Int64 -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer -> Integer -> Integer)
-> Int64 -> Int64 -> Either String Int64
checkedOp Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+) Int64
i Int64
i'
evalBinary Limits
_ Binary
Add (LString Name
t) (LString Name
t') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString (Name
t Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
t')
evalBinary Limits
_ Binary
Add Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only integers and strings support addition"
evalBinary Limits
_ Binary
Sub (LInteger Int64
i) (LInteger Int64
i') = Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger (Int64 -> Value) -> Either String Int64 -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer -> Integer -> Integer)
-> Int64 -> Int64 -> Either String Int64
checkedOp (-) Int64
i Int64
i'
evalBinary Limits
_ Binary
Sub Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only integers support subtraction"
evalBinary Limits
_ Binary
Mul (LInteger Int64
i) (LInteger Int64
i') = Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger (Int64 -> Value) -> Either String Int64 -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer -> Integer -> Integer)
-> Int64 -> Int64 -> Either String Int64
checkedOp Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*) Int64
i Int64
i'
evalBinary Limits
_ Binary
Mul Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only integers support multiplication"
evalBinary Limits
_ Binary
Div (LInteger Int64
_) (LInteger Int64
0) = String -> Either String Value
forall a b. a -> Either a b
Left String
"Divide by 0"
evalBinary Limits
_ Binary
Div (LInteger Int64
i) (LInteger Int64
i') = Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger (Int64 -> Value) -> Either String Int64 -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer -> Integer -> Integer)
-> Int64 -> Int64 -> Either String Int64
checkedOp Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div Int64
i Int64
i'
evalBinary Limits
_ Binary
Div Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only integers support division"
-- bitwise operations
evalBinary Limits
_ Binary
BitwiseAnd (LInteger Int64
i) (LInteger Int64
i') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger (Int64
i Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
.&. Int64
i')
evalBinary Limits
_ Binary
BitwiseAnd Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only integers support bitwise and"
evalBinary Limits
_ Binary
BitwiseOr  (LInteger Int64
i) (LInteger Int64
i') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger (Int64
i Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
.|. Int64
i')
evalBinary Limits
_ Binary
BitwiseOr Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only integers support bitwise or"
evalBinary Limits
_ Binary
BitwiseXor (LInteger Int64
i) (LInteger Int64
i') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger (Int64
i Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
`xor` Int64
i')
evalBinary Limits
_ Binary
BitwiseXor Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only integers support bitwise xor"
-- boolean operations
evalBinary Limits
_ Binary
And (LBool Bool
b) (LBool Bool
b') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool
b Bool -> Bool -> Bool
&& Bool
b')
evalBinary Limits
_ Binary
And Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only booleans support &&"
evalBinary Limits
_ Binary
Or (LBool Bool
b) (LBool Bool
b') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool
b Bool -> Bool -> Bool
|| Bool
b')
evalBinary Limits
_ Binary
Or Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only booleans support ||"
evalBinary Limits
_ Binary
LazyAnd Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"internal error: leftover &&"
evalBinary Limits
_ Binary
LazyOr Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"internal error: leftover ||"
-- set operations
evalBinary Limits
_ Binary
Contains (TermSet SetType 'NotWithinSet 'Representation
t) (TermSet SetType 'NotWithinSet 'Representation
t') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Set (Term' 'WithinSet 'InFact 'Representation)
-> Set (Term' 'WithinSet 'InFact 'Representation) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
t' Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
t)
evalBinary Limits
_ Binary
Contains (TermSet SetType 'NotWithinSet 'Representation
t) Value
t' = case Value -> Maybe (Term' 'WithinSet 'InFact 'Representation)
valueToSetTerm Value
t' of
    Just Term' 'WithinSet 'InFact 'Representation
t'' -> Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Term' 'WithinSet 'InFact 'Representation
-> Set (Term' 'WithinSet 'InFact 'Representation) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Term' 'WithinSet 'InFact 'Representation
t'' Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
t)
    Maybe (Term' 'WithinSet 'InFact 'Representation)
Nothing  -> String -> Either String Value
forall a b. a -> Either a b
Left String
"Sets cannot contain nested sets nor variables"
evalBinary Limits
_ Binary
Contains (LString Name
t) (LString Name
t') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Name
t' Name -> Name -> Bool
`isInfixOf` Name
t)
evalBinary Limits
_ Binary
Contains (TermArray ArrayType 'NotWithinSet 'Representation
t) Value
t' = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Bool -> Value) -> Bool -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Either String Value) -> Bool -> Either String Value
forall a b. (a -> b) -> a -> b
$ Value
t' Value -> [Value] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Value]
ArrayType 'NotWithinSet 'Representation
t
evalBinary Limits
_ Binary
Contains (TermMap MapType 'NotWithinSet 'Representation
t) (LInteger Int64
i) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Bool -> Value) -> Bool -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Either String Value) -> Bool -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int64 -> MapKey
IntKey Int64
i MapKey -> Map MapKey Value -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map MapKey Value
MapType 'NotWithinSet 'Representation
t
evalBinary Limits
_ Binary
Contains (TermMap MapType 'NotWithinSet 'Representation
t) (LString Name
s) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Bool -> Value) -> Bool -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Either String Value) -> Bool -> Either String Value
forall a b. (a -> b) -> a -> b
$ Name -> MapKey
StringKey Name
s MapKey -> Map MapKey Value -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map MapKey Value
MapType 'NotWithinSet 'Representation
t
evalBinary Limits
_ Binary
Contains (TermMap MapType 'NotWithinSet 'Representation
_) Value
_ = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool Bool
False
evalBinary Limits
_ Binary
Contains Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only sets and strings support `.contains()`"
evalBinary Limits
_ Binary
Intersection (TermSet SetType 'NotWithinSet 'Representation
t) (TermSet SetType 'NotWithinSet 'Representation
t') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ SetType 'NotWithinSet 'Representation -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
SetType inSet ctx -> Term' inSet pof ctx
TermSet (Set (Term' 'WithinSet 'InFact 'Representation)
-> Set (Term' 'WithinSet 'InFact 'Representation)
-> Set (Term' 'WithinSet 'InFact 'Representation)
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
t Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
t')
evalBinary Limits
_ Binary
Intersection Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only sets support `.intersection()`"
evalBinary Limits
_ Binary
Union (TermSet SetType 'NotWithinSet 'Representation
t) (TermSet SetType 'NotWithinSet 'Representation
t') = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ SetType 'NotWithinSet 'Representation -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
SetType inSet ctx -> Term' inSet pof ctx
TermSet (Set (Term' 'WithinSet 'InFact 'Representation)
-> Set (Term' 'WithinSet 'InFact 'Representation)
-> Set (Term' 'WithinSet 'InFact 'Representation)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
t Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
t')
evalBinary Limits
_ Binary
Union Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only sets support `.union()`"
evalBinary Limits
_ Binary
Get (TermArray ArrayType 'NotWithinSet 'Representation
t) (LInteger Int64
i) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$
  if Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< [Value] -> Int64
forall i a. Num i => [a] -> i
List.genericLength [Value]
ArrayType 'NotWithinSet 'Representation
t
  then [Value] -> Int64 -> Value
forall i a. Integral i => [a] -> i -> a
List.genericIndex [Value]
ArrayType 'NotWithinSet 'Representation
t Int64
i
  else Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Term' inSet pof ctx
LNull
evalBinary Limits
_ Binary
Get (TermMap MapType 'NotWithinSet 'Representation
t) (LInteger Int64
i) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Maybe Value -> Value) -> Maybe Value -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Term' inSet pof ctx
LNull (Maybe Value -> Either String Value)
-> Maybe Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Map MapKey Value
MapType 'NotWithinSet 'Representation
t Map MapKey Value -> MapKey -> Maybe Value
forall k a. Ord k => Map k a -> k -> Maybe a
!? Int64 -> MapKey
IntKey Int64
i
evalBinary Limits
_ Binary
Get (TermMap MapType 'NotWithinSet 'Representation
t) (LString Name
s) = Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Maybe Value -> Value) -> Maybe Value -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Term' inSet pof ctx
LNull (Maybe Value -> Either String Value)
-> Maybe Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Map MapKey Value
MapType 'NotWithinSet 'Representation
t Map MapKey Value -> MapKey -> Maybe Value
forall k a. Ord k => Map k a -> k -> Maybe a
!? Name -> MapKey
StringKey Name
s
evalBinary Limits
_ Binary
Get Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only arrays and maps support `.get()`"
evalBinary Limits
_ Binary
Any Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"internal error: leftover .any()"
evalBinary Limits
_ Binary
All Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"internal error: leftover .all()"
evalBinary Limits
_ Binary
Try Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"internal error: leftover .try_or()"
evalBinary Limits{ExternFuncs
externFuncs :: Limits -> ExternFuncs
externFuncs :: ExternFuncs
externFuncs} (BinaryFfi Name
n) Value
l Value
r = ExternFuncs -> Name -> Value -> Maybe Value -> Either String Value
runExternFunc ExternFuncs
externFuncs Name
n Value
l (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
r)

checkedOp :: (Integer -> Integer -> Integer)
          -> Int64 -> Int64
          -> Either String Int64
checkedOp :: (Integer -> Integer -> Integer)
-> Int64 -> Int64 -> Either String Int64
checkedOp Integer -> Integer -> Integer
f Int64
a Int64
b =
  let result :: Integer
result = Integer -> Integer -> Integer
f (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
a) (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
b)
   in if Integer
result Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
minBound @Int64)
      then String -> Either String Int64
forall a b. a -> Either a b
Left String
"integer underflow"
      else if Integer
result Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Int64)
      then String -> Either String Int64
forall a b. a -> Either a b
Left String
"integer overflow"
      else Int64 -> Either String Int64
forall a b. b -> Either a b
Right (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
result)

regexMatch :: Text -> Text -> Either String Value
regexMatch :: Name -> Name -> Either String Value
regexMatch Name
text Name
regexT = do
  Regex
regex  <- CompOption -> ExecOption -> Name -> Either String Regex
Regex.compile CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
Regex.defaultCompOpt ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
Regex.defaultExecOpt Name
regexT
  Maybe MatchArray
result <- Regex -> Name -> Either String (Maybe MatchArray)
Regex.execute Regex
regex Name
text
  Value -> Either String Value
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value)
-> (Bool -> Value) -> Bool -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Either String Value) -> Bool -> Either String Value
forall a b. (a -> b) -> a -> b
$ Maybe MatchArray -> Bool
forall a. Maybe a -> Bool
isJust Maybe MatchArray
result

evaluateAll :: Limits
            -> Bindings
            -> Value
            -> Expression
            -> Either String Value
evaluateAll :: Limits -> Bindings -> Value -> Expression -> Either String Value
evaluateAll Limits
l Bindings
b Value
xs' (EClosure [Name
p] Expression
e) =
  let runClosure :: Value -> Either String Bool
runClosure Value
v = do
        if Name -> Bindings -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
p Bindings
b
            then String -> Either String ()
forall a b. a -> Either a b
Left String
"Shadowed variable"
            else () -> Either String ()
forall a b. b -> Either a b
Right ()
        Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l (Name -> Value -> Bindings -> Bindings
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
p Value
v Bindings
b) Expression
e Either String Value
-> (Value -> Either String Bool) -> Either String Bool
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          LBool Bool
x -> Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
x
          Value
_ -> String -> Either String Bool
forall a b. a -> Either a b
Left String
"Expected boolean"
      makeArray :: (MapKey, Value) -> Value
      makeArray :: (MapKey, Value) -> Value
makeArray (MapKey
k,Value
v) = case MapKey
k of
        IntKey Int64
i    -> ArrayType 'NotWithinSet 'Representation -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
ArrayType inSet ctx -> Term' inSet pof ctx
TermArray [Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger Int64
i, Value
v]
        StringKey Name
s -> ArrayType 'NotWithinSet 'Representation -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
ArrayType inSet ctx -> Term' inSet pof ctx
TermArray [Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString Name
s, Value
v]
   in case Value
xs' of
    TermSet SetType 'NotWithinSet 'Representation
xs   -> Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Value) -> Either String Bool -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term' 'WithinSet 'InFact 'Representation -> Either String Bool)
-> Set (Term' 'WithinSet 'InFact 'Representation)
-> Either String Bool
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m Bool) -> t a -> m Bool
allM (Value -> Either String Bool
runClosure (Value -> Either String Bool)
-> (Term' 'WithinSet 'InFact 'Representation -> Value)
-> Term' 'WithinSet 'InFact 'Representation
-> Either String Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term' 'WithinSet 'InFact 'Representation -> Value
setValueToValue) Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
xs
    TermArray ArrayType 'NotWithinSet 'Representation
xs -> Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Value) -> Either String Bool -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Either String Bool) -> [Value] -> Either String Bool
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m Bool) -> t a -> m Bool
allM Value -> Either String Bool
runClosure [Value]
ArrayType 'NotWithinSet 'Representation
xs
    TermMap MapType 'NotWithinSet 'Representation
xs   -> Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Value) -> Either String Bool -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((MapKey, Value) -> Either String Bool)
-> [(MapKey, Value)] -> Either String Bool
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m Bool) -> t a -> m Bool
allM (Value -> Either String Bool
runClosure (Value -> Either String Bool)
-> ((MapKey, Value) -> Value)
-> (MapKey, Value)
-> Either String Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MapKey, Value) -> Value
makeArray) (Map MapKey Value -> [(MapKey, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList Map MapKey Value
MapType 'NotWithinSet 'Representation
xs)
    Value
_            -> String -> Either String Value
forall a b. a -> Either a b
Left String
"Only sets, arrays and maps support .all()"
evaluateAll Limits
_ Bindings
_ Value
_  Expression
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Expected closure"

evaluateAny :: Limits
            -> Bindings
            -> Value
            -> Expression
            -> Either String Value
evaluateAny :: Limits -> Bindings -> Value -> Expression -> Either String Value
evaluateAny Limits
l Bindings
b Value
xs' (EClosure [Name
p] Expression
e) =
  let runClosure :: Value -> Either String Bool
runClosure Value
v = do
        if Name -> Bindings -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
p Bindings
b
            then String -> Either String ()
forall a b. a -> Either a b
Left String
"Shadowed variable"
            else () -> Either String ()
forall a b. b -> Either a b
Right ()
        Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l (Name -> Value -> Bindings -> Bindings
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
p Value
v Bindings
b) Expression
e Either String Value
-> (Value -> Either String Bool) -> Either String Bool
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          LBool Bool
x -> Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
x
          Value
_ -> String -> Either String Bool
forall a b. a -> Either a b
Left String
"Expected boolean"
      makeArray :: (MapKey, Value) -> Value
      makeArray :: (MapKey, Value) -> Value
makeArray (MapKey
k,Value
v) = case MapKey
k of
        IntKey Int64
i    -> ArrayType 'NotWithinSet 'Representation -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
ArrayType inSet ctx -> Term' inSet pof ctx
TermArray [Int64 -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Int64 -> Term' inSet pof ctx
LInteger Int64
i, Value
v]
        StringKey Name
s -> ArrayType 'NotWithinSet 'Representation -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
ArrayType inSet ctx -> Term' inSet pof ctx
TermArray [Name -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Name -> Term' inSet pof ctx
LString Name
s, Value
v]
   in case Value
xs' of
    TermSet SetType 'NotWithinSet 'Representation
xs   -> Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Value) -> Either String Bool -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term' 'WithinSet 'InFact 'Representation -> Either String Bool)
-> Set (Term' 'WithinSet 'InFact 'Representation)
-> Either String Bool
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m Bool) -> t a -> m Bool
anyM (Value -> Either String Bool
runClosure (Value -> Either String Bool)
-> (Term' 'WithinSet 'InFact 'Representation -> Value)
-> Term' 'WithinSet 'InFact 'Representation
-> Either String Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term' 'WithinSet 'InFact 'Representation -> Value
setValueToValue) Set (Term' 'WithinSet 'InFact 'Representation)
SetType 'NotWithinSet 'Representation
xs
    TermArray ArrayType 'NotWithinSet 'Representation
xs -> Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Value) -> Either String Bool -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Either String Bool) -> [Value] -> Either String Bool
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m Bool) -> t a -> m Bool
anyM Value -> Either String Bool
runClosure [Value]
ArrayType 'NotWithinSet 'Representation
xs
    TermMap MapType 'NotWithinSet 'Representation
xs   -> Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Value) -> Either String Bool -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((MapKey, Value) -> Either String Bool)
-> [(MapKey, Value)] -> Either String Bool
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m Bool) -> t a -> m Bool
anyM (Value -> Either String Bool
runClosure (Value -> Either String Bool)
-> ((MapKey, Value) -> Value)
-> (MapKey, Value)
-> Either String Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MapKey, Value) -> Value
makeArray) (Map MapKey Value -> [(MapKey, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList Map MapKey Value
MapType 'NotWithinSet 'Representation
xs)
    Value
_            -> String -> Either String Value
forall a b. a -> Either a b
Left String
"Only sets, arrays and maps support .any()"
evaluateAny Limits
_ Bindings
_ Value
_  Expression
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Expected closure"

evaluateLazyAnd :: Limits
                -> Bindings
                -> Value
                -> Expression
                -> Either String Value
evaluateLazyAnd :: Limits -> Bindings -> Value -> Expression -> Either String Value
evaluateLazyAnd Limits
l Bindings
b Value
lhs' (EClosure [] Expression
e) =
  let runClosure :: Either String Bool
runClosure =
        Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l Bindings
b Expression
e Either String Value
-> (Value -> Either String Bool) -> Either String Bool
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          LBool Bool
x -> Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
x
          Value
_ -> String -> Either String Bool
forall a b. a -> Either a b
Left String
"Expected boolean"
   in case Value
lhs' of
        LBool Bool
lhs -> if Bool
lhs
                     then Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Value) -> Either String Bool -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String Bool
runClosure
                     else Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool Bool
False
        Value
_ -> String -> Either String Value
forall a b. a -> Either a b
Left String
"Expected boolean"
evaluateLazyAnd Limits
_ Bindings
_ Value
_  Expression
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Expected closure"

evaluateLazyOr :: Limits
                -> Bindings
                -> Value
                -> Expression
                -> Either String Value
evaluateLazyOr :: Limits -> Bindings -> Value -> Expression -> Either String Value
evaluateLazyOr Limits
l Bindings
b Value
lhs' (EClosure [] Expression
e) =
  let runClosure :: Either String Bool
runClosure =
        Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l Bindings
b Expression
e Either String Value
-> (Value -> Either String Bool) -> Either String Bool
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          LBool Bool
x -> Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
x
          Value
_ -> String -> Either String Bool
forall a b. a -> Either a b
Left String
"Expected boolean"
   in case Value
lhs' of
        LBool Bool
lhs -> if Bool
lhs
                     then Value -> Either String Value
forall a b. b -> Either a b
Right (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool Bool
True
                     else Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Bool -> Term' inSet pof ctx
LBool (Bool -> Value) -> Either String Bool -> Either String Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String Bool
runClosure
        Value
_ -> String -> Either String Value
forall a b. a -> Either a b
Left String
"Expected boolean"
evaluateLazyOr Limits
_ Bindings
_ Value
_  Expression
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Expected closure"

evaluateTry :: Limits
            -> Bindings
            -> Expression
            -> Expression
            -> Either String Value
evaluateTry :: Limits
-> Bindings -> Expression -> Expression -> Either String Value
evaluateTry Limits
l Bindings
b (EClosure [] Expression
e) Expression
e' = do
  Value
rhs <- Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l Bindings
b Expression
e'
  case Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l Bindings
b Expression
e of
    Right Value
r -> Value -> Either String Value
forall a b. b -> Either a b
Right Value
r
    Left String
_  -> Value -> Either String Value
forall a b. b -> Either a b
Right Value
rhs
evaluateTry Limits
_ Bindings
_ Expression
_ Expression
_                = String -> Either String Value
forall a b. a -> Either a b
Left String
"Expected closure"

-- | Given bindings for variables, reduce an expression to a single
-- datalog value
evaluateExpression :: Limits
                   -> Bindings
                   -> Expression
                   -> Either String Value
evaluateExpression :: Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l Bindings
b = \case
    EValue Term' 'NotWithinSet 'InPredicate 'Representation
term -> Bindings
-> Term' 'NotWithinSet 'InPredicate 'Representation
-> Either String Value
applyVariable Bindings
b Term' 'NotWithinSet 'InPredicate 'Representation
term
    EUnary Unary
op Expression
e -> Limits -> Unary -> Value -> Either String Value
evalUnary Limits
l Unary
op (Value -> Either String Value)
-> Either String Value -> Either String Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l Bindings
b Expression
e
    EBinary Binary
LazyAnd Expression
e Expression
e' -> do
        Value
lhs <- Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l Bindings
b Expression
e
        Limits -> Bindings -> Value -> Expression -> Either String Value
evaluateLazyAnd Limits
l Bindings
b Value
lhs Expression
e'
    EBinary Binary
LazyOr Expression
e Expression
e' -> do
        Value
lhs <- Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l Bindings
b Expression
e
        Limits -> Bindings -> Value -> Expression -> Either String Value
evaluateLazyOr Limits
l Bindings
b Value
lhs Expression
e'
    EBinary Binary
Any Expression
e Expression
e' -> do
        Value
lhs <- Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l Bindings
b Expression
e
        Limits -> Bindings -> Value -> Expression -> Either String Value
evaluateAny Limits
l Bindings
b Value
lhs Expression
e'
    EBinary Binary
All Expression
e Expression
e' -> do
        Value
lhs <- Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l Bindings
b Expression
e
        Limits -> Bindings -> Value -> Expression -> Either String Value
evaluateAll Limits
l Bindings
b Value
lhs Expression
e'
    EBinary Binary
Try Expression
e Expression
e' -> Limits
-> Bindings -> Expression -> Expression -> Either String Value
evaluateTry Limits
l Bindings
b Expression
e Expression
e'
    EBinary Binary
op Expression
e Expression
e' -> (Value -> Value -> Either String Value)
-> (Value, Value) -> Either String Value
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Limits -> Binary -> Value -> Value -> Either String Value
evalBinary Limits
l Binary
op) ((Value, Value) -> Either String Value)
-> Either String (Value, Value) -> Either String Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Expression -> Either String Value)
 -> (Expression -> Either String Value)
 -> (Expression, Expression)
 -> Either String (Value, Value))
-> (Expression -> Either String Value)
-> (Expression, Expression)
-> Either String (Value, Value)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Expression -> Either String Value)
-> (Expression -> Either String Value)
-> (Expression, Expression)
-> Either String (Value, Value)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse (Limits -> Bindings -> Expression -> Either String Value
evaluateExpression Limits
l Bindings
b) (Expression
e, Expression
e')
    EClosure [Name]
_ Expression
_ -> String -> Either String Value
forall a b. a -> Either a b
Left String
"Unexpected closure"