{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TupleSections              #-}
{-|
  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
  , extractVariables

  --
  , getFactsForRule
  , checkCheck
  , checkPolicy
  , getBindingsForRuleBody
  , getCombinations
  ) where

import           Control.Monad            (join, mfilter, zipWithM)
import           Data.Bitraversable       (bitraverse)
import qualified Data.ByteString          as ByteString
import           Data.Foldable            (fold)
import           Data.Functor.Compose     (Compose (..))
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           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
/= :: MatchedQuery -> MatchedQuery -> Bool
$c/= :: MatchedQuery -> MatchedQuery -> Bool
== :: MatchedQuery -> MatchedQuery -> Bool
$c== :: 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
showList :: [MatchedQuery] -> ShowS
$cshowList :: [MatchedQuery] -> ShowS
show :: MatchedQuery -> String
$cshow :: MatchedQuery -> String
showsPrec :: Int -> MatchedQuery -> ShowS
$cshowsPrec :: Int -> 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
/= :: ResultError -> ResultError -> Bool
$c/= :: ResultError -> ResultError -> Bool
== :: ResultError -> ResultError -> Bool
$c== :: 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
showList :: [ResultError] -> ShowS
$cshowList :: [ResultError] -> ShowS
show :: ResultError -> String
$cshow :: ResultError -> String
showsPrec :: Int -> ResultError -> ShowS
$cshowsPrec :: Int -> 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
/= :: ExecutionError -> ExecutionError -> Bool
$c/= :: ExecutionError -> ExecutionError -> Bool
== :: ExecutionError -> ExecutionError -> Bool
$c== :: 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
showList :: [ExecutionError] -> ShowS
$cshowList :: [ExecutionError] -> ShowS
show :: ExecutionError -> String
$cshow :: ExecutionError -> String
showsPrec :: Int -> ExecutionError -> ShowS
$cshowsPrec :: Int -> 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
/= :: Limits -> Limits -> Bool
$c/= :: Limits -> Limits -> Bool
== :: Limits -> Limits -> Bool
$c== :: 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
showList :: [Limits] -> ShowS
$cshowList :: [Limits] -> ShowS
show :: Limits -> String
$cshow :: Limits -> String
showsPrec :: Int -> Limits -> ShowS
$cshowsPrec :: Int -> 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 :: Int -> Int -> Int -> Bool -> Limits
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
/= :: FactGroup -> FactGroup -> Bool
$c/= :: FactGroup -> FactGroup -> Bool
== :: FactGroup -> FactGroup -> Bool
$c== :: 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' :: FactGroup -> Maybe RuleScope -> Natural -> FactGroup
keepAuthorized' :: FactGroup -> Maybe RuleScope -> Natural -> FactGroup
keepAuthorized' FactGroup
factGroup Maybe RuleScope
mScope Natural
currentBlockId =
  let scope :: RuleScope
scope = RuleScope -> Maybe RuleScope -> RuleScope
forall a. a -> Maybe a -> a
fromMaybe RuleScope
OnlyAuthority Maybe RuleScope
mScope
   in case RuleScope
scope of
        RuleScope
OnlyAuthority  -> FactGroup -> Set Natural -> FactGroup
keepAuthorized FactGroup
factGroup ([Natural] -> Set Natural
forall a. Ord a => [a] -> Set a
Set.fromList [Natural
0, Natural
currentBlockId])
        RuleScope
Previous       -> FactGroup -> Set Natural -> FactGroup
keepAuthorized FactGroup
factGroup ([Natural] -> Set Natural
forall a. Ord a => [a] -> Set a
Set.fromList [Natural
0..Natural
currentBlockId])
        RuleScope
UnsafeAny      -> FactGroup
factGroup
        OnlyBlocks Set Natural
ids -> FactGroup -> Set Natural -> FactGroup
keepAuthorized FactGroup
factGroup (Natural -> Set Natural -> Set Natural
forall a. Ord a => a -> Set a -> Set a
Set.insert Natural
currentBlockId Set Natural
ids)

toScopedFacts :: FactGroup -> Set (Scoped Fact)
toScopedFacts :: FactGroup -> Set (Scoped Fact)
toScopedFacts (FactGroup Map (Set Natural) (Set Fact)
factGroups) =
  let distributeScope :: t -> Set t -> Set (t, t)
distributeScope t
scope Set t
facts = (t -> (t, t)) -> Set t -> Set (t, t)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (t
scope,) Set t
facts
   in ((Set Natural, Set Fact) -> Set (Scoped Fact))
-> [(Set Natural, Set Fact)] -> Set (Scoped Fact)
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 t. (Ord t, Ord t) => t -> Set t -> Set (t, t)
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 (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 (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 -> FactGroup -> Check -> Validation (NonEmpty Check) ()
checkCheck :: Limits
-> Natural -> FactGroup -> Query -> Validation (NonEmpty Query) ()
checkCheck Limits
l Natural
checkBlockId FactGroup
facts Query
items =
  if (QueryItem' 'RegularString -> Bool) -> Query -> 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' 'RegularString -> Maybe (Set Bindings))
-> QueryItem' 'RegularString
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Limits
-> Natural
-> FactGroup
-> QueryItem' 'RegularString
-> Maybe (Set Bindings)
isQueryItemSatisfied Limits
l Natural
checkBlockId FactGroup
facts) Query
items
  then () -> Validation (NonEmpty Query) ()
forall e a. a -> Validation e a
Success ()
  else Query -> Validation (NonEmpty Query) ()
forall e a. e -> Validation (NonEmpty e) a
failure Query
items

checkPolicy :: Limits -> FactGroup -> Policy -> Maybe (Either MatchedQuery MatchedQuery)
checkPolicy :: Limits
-> FactGroup -> Policy -> Maybe (Either MatchedQuery MatchedQuery)
checkPolicy Limits
l FactGroup
facts (PolicyType
pType, Query
query) =
  let bindings :: Set Bindings
bindings = [Set Bindings] -> Set Bindings
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' 'RegularString -> Maybe (Set Bindings))
-> Query -> [Set Bindings]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Limits
-> Natural
-> FactGroup
-> QueryItem' 'RegularString
-> Maybe (Set Bindings)
isQueryItemSatisfied Limits
l Natural
0 FactGroup
facts) Query
query
   in if Bool -> Bool
not (Set Bindings -> 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 :: Query -> Set Bindings -> MatchedQuery
MatchedQuery{matchedQuery :: Query
matchedQuery = Query
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 :: Query -> Set Bindings -> MatchedQuery
MatchedQuery{matchedQuery :: Query
matchedQuery = Query
query, Set Bindings
bindings :: Set Bindings
bindings :: Set Bindings
bindings}
      else Maybe (Either MatchedQuery MatchedQuery)
forall a. Maybe a
Nothing

isQueryItemSatisfied :: Limits -> Natural -> FactGroup -> QueryItem' 'RegularString -> Maybe (Set Bindings)
isQueryItemSatisfied :: Limits
-> Natural
-> FactGroup
-> QueryItem' 'RegularString
-> Maybe (Set Bindings)
isQueryItemSatisfied Limits
l Natural
blockId FactGroup
allFacts QueryItem{[Predicate' 'InPredicate 'RegularString]
qBody :: forall (ctx :: ParsedAs).
QueryItem' ctx -> [Predicate' 'InPredicate ctx]
qBody :: [Predicate' 'InPredicate 'RegularString]
qBody, [Expression' 'RegularString]
qExpressions :: forall (ctx :: ParsedAs). QueryItem' ctx -> [Expression' ctx]
qExpressions :: [Expression' 'RegularString]
qExpressions, Maybe RuleScope
qScope :: forall (ctx :: ParsedAs). QueryItem' ctx -> Maybe RuleScope
qScope :: Maybe RuleScope
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
$ FactGroup -> Maybe RuleScope -> Natural -> FactGroup
keepAuthorized' FactGroup
allFacts Maybe RuleScope
qScope Natural
blockId
      bindings :: Set Bindings
bindings = Set (Set Natural, Bindings) -> Set Bindings
forall a. Set (a, Bindings) -> Set Bindings
removeScope (Set (Set Natural, Bindings) -> Set Bindings)
-> Set (Set Natural, Bindings) -> Set Bindings
forall a b. (a -> b) -> a -> b
$ Limits
-> Set (Scoped Fact)
-> [Predicate' 'InPredicate 'RegularString]
-> [Expression' 'RegularString]
-> Set (Set Natural, Bindings)
getBindingsForRuleBody Limits
l Set (Scoped Fact)
facts [Predicate' 'InPredicate 'RegularString]
qBody [Expression' 'RegularString]
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 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) -> Rule -> Set (Scoped Fact)
getFactsForRule :: Limits -> Set (Scoped Fact) -> Rule -> Set (Scoped Fact)
getFactsForRule Limits
l Set (Scoped Fact)
facts Rule{Predicate' 'InPredicate 'RegularString
rhead :: forall (ctx :: ParsedAs). Rule' ctx -> Predicate' 'InPredicate ctx
rhead :: Predicate' 'InPredicate 'RegularString
rhead, [Predicate' 'InPredicate 'RegularString]
body :: forall (ctx :: ParsedAs).
Rule' ctx -> [Predicate' 'InPredicate ctx]
body :: [Predicate' 'InPredicate 'RegularString]
body, [Expression' 'RegularString]
expressions :: forall (ctx :: ParsedAs). Rule' ctx -> [Expression' ctx]
expressions :: [Expression' 'RegularString]
expressions} =
  let legalBindings :: Set (Scoped Bindings)
      legalBindings :: Set (Set Natural, Bindings)
legalBindings = Limits
-> Set (Scoped Fact)
-> [Predicate' 'InPredicate 'RegularString]
-> [Expression' 'RegularString]
-> Set (Set Natural, Bindings)
getBindingsForRuleBody Limits
l Set (Scoped Fact)
facts [Predicate' 'InPredicate 'RegularString]
body [Expression' 'RegularString]
expressions
      newFacts :: [Scoped Fact]
newFacts = ((Set Natural, Bindings) -> Maybe (Scoped Fact))
-> [(Set Natural, Bindings)] -> [Scoped Fact]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Predicate' 'InPredicate 'RegularString
-> (Set Natural, Bindings) -> Maybe (Scoped Fact)
applyBindings Predicate' 'InPredicate 'RegularString
rhead) ([(Set Natural, Bindings)] -> [Scoped Fact])
-> [(Set Natural, Bindings)] -> [Scoped Fact]
forall a b. (a -> b) -> a -> b
$ Set (Set Natural, Bindings) -> [(Set Natural, Bindings)]
forall a. Set a -> [a]
Set.toList Set (Set Natural, 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 'RegularString]
-> [Expression' 'RegularString]
-> Set (Set Natural, Bindings)
getBindingsForRuleBody Limits
l Set (Scoped Fact)
facts [Predicate' 'InPredicate 'RegularString]
body [Expression' 'RegularString]
expressions =
  let -- gather bindings from all the facts that match the query's predicates
      candidateBindings :: [Set (Set Natural, Bindings)]
candidateBindings = Set (Scoped Fact)
-> [Predicate' 'InPredicate 'RegularString]
-> [Set (Set Natural, Bindings)]
getCandidateBindings Set (Scoped Fact)
facts [Predicate' 'InPredicate 'RegularString]
body
      allVariables :: Set Text
allVariables = [Predicate' 'InPredicate 'RegularString] -> Set Text
extractVariables [Predicate' 'InPredicate 'RegularString]
body
      -- only keep bindings combinations where each variable has a single possible match
      legalBindingsForFacts :: Set (Set Natural, Bindings)
legalBindingsForFacts = Set Text
-> [Set (Set Natural, Bindings)] -> Set (Set Natural, Bindings)
reduceCandidateBindings Set Text
allVariables [Set (Set Natural, Bindings)]
candidateBindings
      -- only keep bindings that satisfy the query expressions
   in ((Set Natural, Bindings) -> Bool)
-> Set (Set Natural, Bindings) -> Set (Set Natural, Bindings)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\(Set Natural, Bindings)
b -> (Expression' 'RegularString -> Bool)
-> [Expression' 'RegularString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Limits
-> (Set Natural, Bindings) -> Expression' 'RegularString -> Bool
satisfies Limits
l (Set Natural, Bindings)
b) [Expression' 'RegularString]
expressions) Set (Set Natural, Bindings)
legalBindingsForFacts

satisfies :: Limits
          -> Scoped Bindings
          -> Expression
          -> Bool
satisfies :: Limits
-> (Set Natural, Bindings) -> Expression' 'RegularString -> Bool
satisfies Limits
l (Set Natural, Bindings)
b Expression' 'RegularString
e = Limits
-> Bindings -> Expression' 'RegularString -> Either String Value
evaluateExpression Limits
l ((Set Natural, Bindings) -> Bindings
forall a b. (a, b) -> b
snd (Set Natural, Bindings)
b) Expression' 'RegularString
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 :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool Bool
True)

extractVariables :: [Predicate] -> Set Name
extractVariables :: [Predicate' 'InPredicate 'RegularString] -> Set Text
extractVariables [Predicate' 'InPredicate 'RegularString]
predicates =
  let keepVariable :: Term' inSet pof ctx -> Maybe (VariableType inSet pof)
keepVariable = \case
        Variable VariableType inSet pof
name -> VariableType inSet pof -> Maybe (VariableType inSet pof)
forall a. a -> Maybe a
Just VariableType inSet pof
name
        Term' inSet pof ctx
_             -> Maybe (VariableType inSet pof)
forall a. Maybe a
Nothing
      extractVariables' :: Predicate' pof ctx -> [VariableType 'NotWithinSet pof]
extractVariables' Predicate{[Term' 'NotWithinSet pof ctx]
terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms :: [Term' 'NotWithinSet pof ctx]
terms} = (Term' 'NotWithinSet pof ctx
 -> Maybe (VariableType 'NotWithinSet pof))
-> [Term' 'NotWithinSet pof ctx]
-> [VariableType 'NotWithinSet pof]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Term' 'NotWithinSet pof ctx
-> Maybe (VariableType 'NotWithinSet pof)
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Term' inSet pof ctx -> Maybe (VariableType inSet pof)
keepVariable [Term' 'NotWithinSet pof ctx]
terms
   in [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ Predicate' 'InPredicate 'RegularString -> [Text]
forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [VariableType 'NotWithinSet pof]
extractVariables' (Predicate' 'InPredicate 'RegularString -> [Text])
-> [Predicate' 'InPredicate 'RegularString] -> [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Predicate' 'InPredicate 'RegularString]
predicates


applyBindings :: Predicate -> Scoped Bindings -> Maybe (Scoped Fact)
applyBindings :: Predicate' 'InPredicate 'RegularString
-> (Set Natural, Bindings) -> Maybe (Scoped Fact)
applyBindings p :: Predicate' 'InPredicate 'RegularString
p@Predicate{[Term' 'NotWithinSet 'InPredicate 'RegularString]
terms :: [Term' 'NotWithinSet 'InPredicate 'RegularString]
terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms} (Set Natural
origins, Bindings
bindings) =
  let newTerms :: Maybe [Value]
newTerms = (Term' 'NotWithinSet 'InPredicate 'RegularString -> Maybe Value)
-> [Term' 'NotWithinSet 'InPredicate 'RegularString]
-> Maybe [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Term' 'NotWithinSet 'InPredicate 'RegularString -> Maybe Value
replaceTerm [Term' 'NotWithinSet 'InPredicate 'RegularString]
terms
      replaceTerm :: Term -> Maybe Value
      replaceTerm :: Term' 'NotWithinSet 'InPredicate 'RegularString -> 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 Int
t)  = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger Int
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 :: ParsedAs).
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 :: ParsedAs).
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 :: ParsedAs).
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 :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool Bool
t
      replaceTerm (TermSet SetType 'NotWithinSet 'RegularString
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 'RegularString -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SetType inSet ctx -> Term' inSet pof ctx
TermSet SetType 'NotWithinSet 'RegularString
t
      replaceTerm (Antiquote SliceType 'RegularString
t) = Void -> Maybe Value
forall a. Void -> a
absurd Void
SliceType 'RegularString
t
   in (\[Value]
nt -> (Set Natural
origins, Predicate' 'InPredicate 'RegularString
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 :: [[(Set Natural, Bindings)]] -> [Scoped [Bindings]]
getCombinations = Compose [] ((,) (Set Natural)) [Bindings] -> [Scoped [Bindings]]
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose [] ((,) (Set Natural)) [Bindings] -> [Scoped [Bindings]])
-> ([[(Set Natural, Bindings)]]
    -> Compose [] ((,) (Set Natural)) [Bindings])
-> [[(Set Natural, Bindings)]]
-> [Scoped [Bindings]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Set Natural, Bindings)]
 -> Compose [] ((,) (Set Natural)) Bindings)
-> [[(Set Natural, Bindings)]]
-> Compose [] ((,) (Set Natural)) [Bindings]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse [(Set Natural, 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Value -> NonEmpty Value) -> Bindings -> Map Text (NonEmpty Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> NonEmpty Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
      sameValues :: NonEmpty Value -> Maybe Value
sameValues = (NonEmpty Value -> Value) -> Maybe (NonEmpty Value) -> Maybe Value
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 (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 (Set Natural, Bindings)] -> Set (Set Natural, Bindings)
reduceCandidateBindings Set Text
allVariables [Set (Set Natural, Bindings)]
matches =
  let allCombinations :: [(Set Natural, [Bindings])]
      allCombinations :: [Scoped [Bindings]]
allCombinations = [[(Set Natural, Bindings)]] -> [Scoped [Bindings]]
getCombinations ([[(Set Natural, Bindings)]] -> [Scoped [Bindings]])
-> [[(Set Natural, Bindings)]] -> [Scoped [Bindings]]
forall a b. (a -> b) -> a -> b
$ Set (Set Natural, Bindings) -> [(Set Natural, Bindings)]
forall a. Set a -> [a]
Set.toList (Set (Set Natural, Bindings) -> [(Set Natural, Bindings)])
-> [Set (Set Natural, Bindings)] -> [[(Set Natural, Bindings)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Set (Set Natural, Bindings)]
matches
      isComplete :: Scoped Bindings -> Bool
      isComplete :: (Set Natural, Bindings) -> Bool
isComplete = (Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== Set Text
allVariables) (Set Text -> Bool)
-> ((Set Natural, Bindings) -> Set Text)
-> (Set Natural, 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)
-> ((Set Natural, Bindings) -> [Text])
-> (Set Natural, 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])
-> ((Set Natural, Bindings) -> Bindings)
-> (Set Natural, Bindings)
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Natural, Bindings) -> Bindings
forall a b. (a, b) -> b
snd
   in [(Set Natural, Bindings)] -> Set (Set Natural, Bindings)
forall a. Ord a => [a] -> Set a
Set.fromList ([(Set Natural, Bindings)] -> Set (Set Natural, Bindings))
-> [(Set Natural, Bindings)] -> Set (Set Natural, Bindings)
forall a b. (a -> b) -> a -> b
$ ((Set Natural, Bindings) -> Bool)
-> [(Set Natural, Bindings)] -> [(Set Natural, Bindings)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Set Natural, Bindings) -> Bool
isComplete ([(Set Natural, Bindings)] -> [(Set Natural, Bindings)])
-> [(Set Natural, Bindings)] -> [(Set Natural, Bindings)]
forall a b. (a -> b) -> a -> b
$ ([Bindings] -> Bindings)
-> Scoped [Bindings] -> (Set Natural, Bindings)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bindings] -> Bindings
mergeBindings (Scoped [Bindings] -> (Set Natural, Bindings))
-> [Scoped [Bindings]] -> [(Set Natural, 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 'RegularString]
-> [Set (Set Natural, Bindings)]
getCandidateBindings Set (Scoped Fact)
facts [Predicate' 'InPredicate 'RegularString]
predicates =
   let mapMaybeS :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
       mapMaybeS :: (a -> Maybe b) -> Set a -> Set b
mapMaybeS a -> Maybe b
f = (a -> Set b) -> Set a -> Set b
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((b -> Set b) -> Maybe b -> Set b
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 'RegularString
-> Set (Set Natural, Bindings)
keepFacts Predicate' 'InPredicate 'RegularString
p = (Scoped Fact -> Maybe (Set Natural, Bindings))
-> Set (Scoped Fact) -> Set (Set Natural, Bindings)
forall a b. (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
mapMaybeS (Predicate' 'InPredicate 'RegularString
-> Scoped Fact -> Maybe (Set Natural, Bindings)
factMatchesPredicate Predicate' 'InPredicate 'RegularString
p) Set (Scoped Fact)
facts
    in Predicate' 'InPredicate 'RegularString
-> Set (Set Natural, Bindings)
keepFacts (Predicate' 'InPredicate 'RegularString
 -> Set (Set Natural, Bindings))
-> [Predicate' 'InPredicate 'RegularString]
-> [Set (Set Natural, Bindings)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Predicate' 'InPredicate 'RegularString]
predicates

isSame :: Term -> Value -> Bool
isSame :: Term' 'NotWithinSet 'InPredicate 'RegularString -> Value -> Bool
isSame (LInteger Int
t) (LInteger Int
t') = Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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 'RegularString
t)  (TermSet SetType 'NotWithinSet 'RegularString
t')  = Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString) -> Bool
forall a. Eq a => a -> a -> Bool
== Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t'
isSame Term' 'NotWithinSet 'InPredicate 'RegularString
_ 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 'RegularString
-> Scoped Fact -> Maybe (Set Natural, Bindings)
factMatchesPredicate Predicate{name :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> Text
name = Text
predicateName, terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms = [Term' 'NotWithinSet 'InPredicate 'RegularString]
predicateTerms }
                     ( Set Natural
factOrigins
                     , Predicate{name :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> Text
name = Text
factName, terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
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 'RegularString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term' 'NotWithinSet 'InPredicate 'RegularString]
predicateTerms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Value] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
factTerms
      allMatches :: Maybe [Bindings]
allMatches = (Term' 'NotWithinSet 'InPredicate 'RegularString
 -> Value -> Maybe Bindings)
-> [Term' 'NotWithinSet 'InPredicate 'RegularString]
-> [Value]
-> Maybe [Bindings]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Term' 'NotWithinSet 'InPredicate 'RegularString
-> Value -> Maybe Bindings
compatibleMatch [Term' 'NotWithinSet 'InPredicate 'RegularString]
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 'RegularString
-> 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 'RegularString
t Value
t' | Term' 'NotWithinSet 'InPredicate 'RegularString -> Value -> Bool
isSame Term' 'NotWithinSet 'InPredicate 'RegularString
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 -> (Set Natural, Bindings))
-> ([Bindings] -> Bindings)
-> [Bindings]
-> (Set Natural, Bindings)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bindings] -> Bindings
mergeBindings ([Bindings] -> (Set Natural, Bindings))
-> Maybe [Bindings] -> Maybe (Set Natural, Bindings)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Bindings]
allMatches
      else Maybe (Set Natural, Bindings)
forall a. Maybe a
Nothing

applyVariable :: Bindings
              -> Term
              -> Either String Value
applyVariable :: Bindings
-> Term' 'NotWithinSet 'InPredicate 'RegularString
-> 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 Int
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
$ Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger Int
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 :: ParsedAs).
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 :: ParsedAs).
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 :: ParsedAs).
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 :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool Bool
t
  TermSet SetType 'NotWithinSet 'RegularString
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 'RegularString -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SetType inSet ctx -> Term' inSet pof ctx
TermSet SetType 'NotWithinSet 'RegularString
t
  Antiquote SliceType 'RegularString
v -> Void -> Either String Value
forall a. Void -> a
absurd Void
SliceType 'RegularString
v

evalUnary :: Unary -> Value -> Either String Value
evalUnary :: Unary -> Value -> Either String Value
evalUnary Unary
Parens Value
t = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
t
evalUnary Unary
Negate (LBool Bool
b) = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
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 (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
. Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (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 (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
. Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (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 'RegularString
s) = Value -> Either String Value
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
. Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int -> Either String Value) -> Int -> Either String Value
forall a b. (a -> b) -> a -> b
$ Set (Term' 'WithinSet 'InFact 'RegularString) -> Int
forall a. Set a -> Int
Set.size Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
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 Int
i) (LInteger Int
i') = Value -> Either String Value
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 :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i')
evalBinary Limits
_ Binary
Equal (LString Text
t) (LString Text
t')   = Value -> Either String Value
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 :: ParsedAs).
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 (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 :: ParsedAs).
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 (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 :: ParsedAs).
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 (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 :: ParsedAs).
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 'RegularString
t) (TermSet SetType 'NotWithinSet 'RegularString
t')   = Value -> Either String Value
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 :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString) -> Bool
forall a. Eq a => a -> a -> Bool
== Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
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
LessThan (LInteger Int
i) (LInteger Int
i') = Value -> Either String Value
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 :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i')
evalBinary Limits
_ Binary
LessThan (LDate UTCTime
t) (LDate UTCTime
t')       = Value -> Either String Value
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 :: ParsedAs).
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 Int
i) (LInteger Int
i') = Value -> Either String Value
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 :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i')
evalBinary Limits
_ Binary
GreaterThan (LDate UTCTime
t) (LDate UTCTime
t')       = Value -> Either String Value
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 :: ParsedAs).
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 Int
i) (LInteger Int
i') = Value -> Either String Value
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 :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i')
evalBinary Limits
_ Binary
LessOrEqual (LDate UTCTime
t) (LDate UTCTime
t')       = Value -> Either String Value
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 :: ParsedAs).
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 Int
i) (LInteger Int
i') = Value -> Either String Value
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 :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i')
evalBinary Limits
_ Binary
GreaterOrEqual (LDate UTCTime
t) (LDate UTCTime
t')       = Value -> Either String Value
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 :: ParsedAs).
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 (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 :: ParsedAs).
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 (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 :: ParsedAs).
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 :: Bool
allowRegexes :: Limits -> 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 Int
i) (LInteger Int
i') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i')
evalBinary Limits
_ Binary
Add (LString Text
t) (LString Text
t') = Value -> Either String Value
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 :: ParsedAs).
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 Int
i) (LInteger Int
i') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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 Int
i) (LInteger Int
i') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
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 Int
_) (LInteger Int
0) = String -> Either String Value
forall a b. a -> Either a b
Left String
"Divide by 0"
evalBinary Limits
_ Binary
Div (LInteger Int
i) (LInteger Int
i') = Value -> Either String Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either String Value) -> Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
i')
evalBinary Limits
_ Binary
Div Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only integers support division"
-- boolean operations
evalBinary Limits
_ Binary
And (LBool Bool
b) (LBool Bool
b') = Value -> Either String Value
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 :: ParsedAs).
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 (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 :: ParsedAs).
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 'RegularString
t) (TermSet SetType 'NotWithinSet 'RegularString
t') = Value -> Either String Value
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 :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t' Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t)
evalBinary Limits
_ Binary
Contains (TermSet SetType 'NotWithinSet 'RegularString
t) Value
t' = case Value -> Maybe (Term' 'WithinSet 'InFact 'RegularString)
toSetTerm Value
t' of
    Just Term' 'WithinSet 'InFact 'RegularString
t'' -> Value -> Either String Value
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 :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool (Term' 'WithinSet 'InFact 'RegularString
-> Set (Term' 'WithinSet 'InFact 'RegularString) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Term' 'WithinSet 'InFact 'RegularString
t'' Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t)
    Maybe (Term' 'WithinSet 'InFact 'RegularString)
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 (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 :: ParsedAs).
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 'RegularString
t) (TermSet SetType 'NotWithinSet 'RegularString
t') = Value -> Either String Value
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 'RegularString -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SetType inSet ctx -> Term' inSet pof ctx
TermSet (Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString)
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
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 'RegularString
t) (TermSet SetType 'NotWithinSet 'RegularString
t') = Value -> Either String Value
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 'RegularString -> Value
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SetType inSet ctx -> Term' inSet pof ctx
TermSet (Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString)
-> Set (Term' 'WithinSet 'InFact 'RegularString)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t')
evalBinary Limits
_ Binary
Union Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"Only sets support `.union()`"

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 (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 :: ParsedAs).
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' 'RegularString -> Either String Value
evaluateExpression Limits
l Bindings
b = \case
    EValue Term' 'NotWithinSet 'InPredicate 'RegularString
term -> Bindings
-> Term' 'NotWithinSet 'InPredicate 'RegularString
-> Either String Value
applyVariable Bindings
b Term' 'NotWithinSet 'InPredicate 'RegularString
term
    EUnary Unary
op Expression' 'RegularString
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' 'RegularString -> Either String Value
evaluateExpression Limits
l Bindings
b Expression' 'RegularString
e'
    EBinary Binary
op Expression' 'RegularString
e' Expression' 'RegularString
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' 'RegularString -> Either String Value)
 -> (Expression' 'RegularString -> Either String Value)
 -> (Expression' 'RegularString, Expression' 'RegularString)
 -> Either String (Value, Value))
-> (Expression' 'RegularString -> Either String Value)
-> (Expression' 'RegularString, Expression' 'RegularString)
-> Either String (Value, Value)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Expression' 'RegularString -> Either String Value)
-> (Expression' 'RegularString -> Either String Value)
-> (Expression' 'RegularString, Expression' 'RegularString)
-> Either String (Value, Value)
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' 'RegularString -> Either String Value
evaluateExpression Limits
l Bindings
b) (Expression' 'RegularString
e', Expression' 'RegularString
e'')