{-# 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     : MIT
  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
  , MatchedQuery (..)
  , Scoped
  , FactGroup (..)
  , countFacts
  , toScopedFacts
  , fromScopedFacts
  , keepAuthorized'
  , defaultLimits
  , 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           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               (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           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       (maybeToRight)

-- | A variable name
type Name = Text

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

-- | 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.
  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.
  }
  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
--   - facts and rules are allowed in blocks
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
  }

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 (Text -> String
unpack (Text -> String) -> (Fact -> Text) -> Fact -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fact -> Text
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

-- todo handle Check All
checkCheck :: Limits -> Natural -> Natural -> FactGroup -> EvalCheck -> Validation (NonEmpty Check) ()
checkCheck :: Limits
-> Natural
-> Natural
-> FactGroup
-> EvalCheck
-> 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} =
  let isQueryItemOk :: QueryItem' 'Eval 'Representation -> Maybe (Set Bindings)
isQueryItemOk = case CheckKind
cKind of
        CheckKind
One -> Limits
-> Natural
-> Natural
-> FactGroup
-> QueryItem' 'Eval 'Representation
-> Maybe (Set Bindings)
isQueryItemSatisfied Limits
l Natural
blockCount Natural
checkBlockId FactGroup
facts
        CheckKind
All -> Limits
-> Natural
-> Natural
-> FactGroup
-> QueryItem' 'Eval 'Representation
-> Maybe (Set Bindings)
isQueryItemSatisfiedForAllMatches Limits
l Natural
blockCount Natural
checkBlockId FactGroup
facts
   in if (QueryItem' 'Eval 'Representation -> Bool)
-> Query' 'Eval 'Representation -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe (Set Bindings) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Set Bindings) -> Bool)
-> (QueryItem' 'Eval 'Representation -> Maybe (Set Bindings))
-> QueryItem' 'Eval 'Representation
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryItem' 'Eval 'Representation -> Maybe (Set Bindings)
isQueryItemOk) Query' 'Eval 'Representation
cQueries
      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 -> Maybe (Either MatchedQuery MatchedQuery)
checkPolicy :: Limits
-> Natural
-> FactGroup
-> EvalPolicy
-> Maybe (Either MatchedQuery MatchedQuery)
checkPolicy Limits
l Natural
blockCount FactGroup
facts (PolicyType
pType, Query' 'Eval 'Representation
query) =
  let bindings :: Set Bindings
bindings = [Set Bindings] -> Set Bindings
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Set Bindings] -> Set Bindings) -> [Set Bindings] -> Set Bindings
forall a b. (a -> b) -> a -> b
$ (QueryItem' 'Eval 'Representation -> Maybe (Set Bindings))
-> Query' 'Eval 'Representation -> [Set Bindings]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Limits
-> Natural
-> Natural
-> FactGroup
-> QueryItem' 'Eval 'Representation
-> Maybe (Set Bindings)
isQueryItemSatisfied Limits
l Natural
blockCount Natural
blockCount FactGroup
facts) Query' 'Eval 'Representation
query
   in 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 -> Maybe (Set Bindings)
isQueryItemSatisfied :: Limits
-> Natural
-> Natural
-> FactGroup
-> QueryItem' 'Eval 'Representation
-> 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} =
  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
      bindings :: Set Bindings
bindings = Set (Scoped Bindings) -> Set Bindings
forall {a}. Set (a, Bindings) -> Set Bindings
removeScope (Set (Scoped Bindings) -> Set Bindings)
-> Set (Scoped Bindings) -> Set Bindings
forall a b. (a -> b) -> a -> b
$ Limits
-> Set (Scoped Fact)
-> [Predicate' 'InPredicate 'Representation]
-> [Expression]
-> Set (Scoped Bindings)
getBindingsForRuleBody Limits
l Set (Scoped Fact)
facts [Predicate' 'InPredicate 'Representation]
qBody [Expression]
qExpressions
   in 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 -> Maybe (Set Bindings)
isQueryItemSatisfiedForAllMatches :: Limits
-> Natural
-> Natural
-> FactGroup
-> QueryItem' 'Eval 'Representation
-> 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} =
  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 Text
allVariables = [Predicate' 'InPredicate 'Representation] -> Set Text
forall (ctx :: DatalogContext).
[Predicate' 'InPredicate ctx] -> Set Text
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 Text -> [Set (Scoped Bindings)] -> Set (Scoped Bindings)
reduceCandidateBindings Set Text
allVariables [Set (Scoped Bindings)]
candidateBindings
      -- bindings that fulfill the constraints
      constraintFulfillingBindings :: Set (Scoped Bindings)
constraintFulfillingBindings = (Scoped Bindings -> Bool)
-> Set (Scoped Bindings) -> Set (Scoped Bindings)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\Scoped Bindings
b -> (Expression -> Bool) -> [Expression] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Limits -> Scoped Bindings -> Expression -> Bool
satisfies Limits
l Scoped Bindings
b) [Expression]
qExpressions) Set (Scoped Bindings)
legalBindingsForFacts
   in 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 -> Set (Scoped Fact)
getFactsForRule :: Limits -> Set (Scoped Fact) -> EvalRule -> 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} =
  let legalBindings :: Set (Scoped Bindings)
      legalBindings :: Set (Scoped Bindings)
legalBindings = Limits
-> Set (Scoped Fact)
-> [Predicate' 'InPredicate 'Representation]
-> [Expression]
-> Set (Scoped Bindings)
getBindingsForRuleBody Limits
l Set (Scoped Fact)
facts [Predicate' 'InPredicate 'Representation]
body [Expression]
expressions
      newFacts :: [Scoped Fact]
newFacts = (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
   in [Scoped Fact] -> Set (Scoped Fact)
forall a. Ord a => [a] -> Set a
Set.fromList [Scoped Fact]
newFacts

-- | 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] -> Set (Scoped Bindings)
getBindingsForRuleBody :: Limits
-> Set (Scoped Fact)
-> [Predicate' 'InPredicate 'Representation]
-> [Expression]
-> 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 Text
allVariables = [Predicate' 'InPredicate 'Representation] -> Set Text
forall (ctx :: DatalogContext).
[Predicate' 'InPredicate ctx] -> Set Text
extractVariables [Predicate' 'InPredicate 'Representation]
body
      -- only keep bindings combinations where each variable has a single possible match
      legalBindingsForFacts :: Set (Scoped Bindings)
legalBindingsForFacts = Set Text -> [Set (Scoped Bindings)] -> Set (Scoped Bindings)
reduceCandidateBindings Set Text
allVariables [Set (Scoped Bindings)]
candidateBindings
      -- only keep bindings that satisfy the query expressions
   in (Scoped Bindings -> Bool)
-> Set (Scoped Bindings) -> Set (Scoped Bindings)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\Scoped Bindings
b -> (Expression -> Bool) -> [Expression] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Limits -> Scoped Bindings -> Expression -> Bool
satisfies Limits
l Scoped Bindings
b) [Expression]
expressions) Set (Scoped Bindings)
legalBindingsForFacts

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

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)  = Text -> Bindings -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
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 Text
t)   = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Text -> Term' inSet pof ctx
LString Text
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 (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 (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 Text (NonEmpty Value)
combinations = (NonEmpty Value -> NonEmpty Value -> NonEmpty Value)
-> [Map Text (NonEmpty Value)] -> Map Text (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 Text (NonEmpty Value)] -> Map Text (NonEmpty Value))
-> ([Bindings] -> [Map Text (NonEmpty Value)])
-> [Bindings]
-> Map Text (NonEmpty Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bindings -> Map Text (NonEmpty Value))
-> [Bindings] -> [Map Text (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 Text (NonEmpty Value)
forall a b. (a -> b) -> Map Text a -> Map Text 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 Text (NonEmpty Value) -> Bindings
forall {k}. Map k (NonEmpty Value) -> Map k Value
keepConsistent (Map Text (NonEmpty Value) -> Bindings)
-> ([Bindings] -> Map Text (NonEmpty Value))
-> [Bindings]
-> Bindings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bindings] -> Map Text (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 Text -> [Set (Scoped Bindings)] -> Set (Scoped Bindings)
reduceCandidateBindings Set Text
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 Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== Set Text
allVariables) (Set Text -> Bool)
-> (Scoped Bindings -> Set Text) -> Scoped Bindings -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text)
-> (Scoped Bindings -> [Text]) -> Scoped Bindings -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bindings -> [Text]
forall k a. Map k a -> [k]
Map.keys (Bindings -> [Text])
-> (Scoped Bindings -> Bindings) -> Scoped Bindings -> [Text]
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 Text
t)  (LString Text
t')  = Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
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
_ 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 -> Text
name = Text
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 -> Text
name = Text
factName, terms :: forall (pof :: PredicateOrFact) (ctx :: DatalogContext).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms = [Value]
factTerms }
                     ) =
  let namesMatch :: Bool
namesMatch = Text
predicateName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
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 (Text -> Value -> Bindings
forall k a. k -> a -> Map k a
Map.singleton Text
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 -> Text -> Maybe Value
forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
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 Text
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
$ Text -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Text -> Term' inSet pof ctx
LString Text
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
  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
  Antiquote SliceType 'Representation
v -> Void -> Either String Value
forall a. Void -> a
absurd Void
SliceType 'Representation
v

evalUnary :: Unary -> Value -> Either String Value
evalUnary :: Unary -> Value -> Either String Value
evalUnary 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 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 Unary
Negate Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only booleans support negation"
evalUnary Unary
Length (LString Text
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
$ Text -> Int
Text.length Text
t
evalUnary 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 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 Unary
Length Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only strings, bytes and sets support `.length()`"

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 Text
t) (LString Text
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 (Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
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 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 Text
t) (LString Text
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 (Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
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 Value
_ Value
_                        = String -> Either String Value
forall a b. a -> Either a b
Left String
"Inequity mismatch"
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 Text
t) (LString Text
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 (Text
t' Text -> Text -> Bool
`Text.isPrefixOf` Text
t)
evalBinary Limits
_ Binary
Prefix Value
_ Value
_                      = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only strings support `.starts_with()`"
evalBinary Limits
_ Binary
Suffix (LString Text
t) (LString Text
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 (Text
t' Text -> Text -> Bool
`Text.isSuffixOf` Text
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 Text
t) (LString Text
r) | Bool
allowRegexes = Text -> Text -> Either String Value
regexMatch Text
t Text
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 Text
t) (LString Text
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
$ Text -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: DatalogContext).
Text -> Term' inSet pof ctx
LString (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 ||"
-- 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 Text
t) (LString Text
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 (Text
t' Text -> Text -> Bool
`isInfixOf` Text
t)
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()`"

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 :: Text -> Text -> Either String Value
regexMatch Text
text Text
regexT = do
  Regex
regex  <- CompOption -> ExecOption -> Text -> 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 Text
regexT
  Maybe MatchArray
result <- Regex -> Text -> Either String (Maybe MatchArray)
Regex.execute Regex
regex Text
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

-- | 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' -> Unary -> Value -> Either String Value
evalUnary 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
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'')