{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RecordWildCards   #-}
{-|
  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
  ( BlockWithRevocationIds (..)
  , ExecutionError (..)
  , Limits (..)
  , ResultError (..)
  , World (..)
  , Bindings
  , Name
  , computeAllFacts
  , defaultLimits
  , evaluateExpression
  , runVerifier
  , runVerifierWithLimits
  ) where

import           Control.Monad               (join, mfilter, when)
import           Data.Bifunctor              (first)
import           Data.Bitraversable          (bitraverse)
import           Data.ByteString             (ByteString)
import qualified Data.ByteString             as ByteString
import           Data.Foldable               (traverse_)
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, intercalate, unpack)
import qualified Data.Text                   as Text
import           Data.Void                   (absurd)
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.Datalog.Parser (fact)
import           Auth.Biscuit.Timer          (timer)
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

-- | 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] Query
  -- ^ 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)

-- | The result of running verification
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
  | FactsInBlocks
  -- ^ Some blocks contained either rules or facts while it was forbidden
  | ResultError ResultError
  -- ^ The checks and policies were not fulfilled after evaluation
  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 restrictions
-- See `defaultLimits` for default values.
data Limits
  = Limits
  { Limits -> Int
maxFacts          :: Int
  -- ^ maximum number of facts that can be produced (else `TooManyFacts` is thrown)
  , 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
  , Limits -> Bool
allowBlockFacts   :: Bool
  -- ^ wheter or not accept facts and rules in blocks. Even when they are enabled, they
  -- can’t give rise to facts containing `#authority` or `#ambient` symbols
  , Limits -> ByteString -> IO (Either () ())
checkRevocationId :: ByteString -> IO (Either () ())
  -- ^ how to check for token revocation `Left ()` means that the given id is revoked,
  -- `Right ()` means it’s not revoked.
  }

-- | 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
-> Bool
-> (ByteString -> IO (Either () ()))
-> Limits
Limits
  { maxFacts :: Int
maxFacts = Int
1000
  , maxIterations :: Int
maxIterations = Int
100
  , maxTime :: Int
maxTime = Int
1000
  , allowRegexes :: Bool
allowRegexes = Bool
True
  , allowBlockFacts :: Bool
allowBlockFacts = Bool
True
  , checkRevocationId :: ByteString -> IO (Either () ())
checkRevocationId = IO (Either () ()) -> ByteString -> IO (Either () ())
forall a b. a -> b -> a
const (IO (Either () ()) -> ByteString -> IO (Either () ()))
-> (Either () () -> IO (Either () ()))
-> Either () ()
-> ByteString
-> IO (Either () ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either () () -> IO (Either () ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either () () -> ByteString -> IO (Either () ()))
-> Either () () -> ByteString -> IO (Either () ())
forall a b. (a -> b) -> a -> b
$ () -> Either () ()
forall a b. b -> Either a b
Right ()
  }

-- | A parsed block, along with the associated revocation ids.
data BlockWithRevocationIds
  = BlockWithRevocationIds
  { BlockWithRevocationIds -> Block
bBlock              :: Block
  -- ^ The parsed block
  , BlockWithRevocationIds -> ByteString
genericRevocationId :: ByteString
  -- ^ Generic revocation id (depends on the block contents and its primary key)
  , BlockWithRevocationIds -> ByteString
uniqueRevocationId  :: ByteString
  -- ^ Unique revocation id (specific to the token)
  }

-- | A collection of facts  and rules used to derive new facts.
-- Rules coming from blocks are stored separately since they are subject to specific
-- restrictions regarding the facts they can generate.
data World
 = World
 { World -> Set Rule
rules      :: Set Rule
 , World -> Set Rule
blockRules :: Set Rule
 , World -> Set Fact
facts      :: Set Fact
 }

instance Semigroup World where
  World
w1 <> :: World -> World -> World
<> World
w2 = World :: Set Rule -> Set Rule -> Set Fact -> World
World
               { rules :: Set Rule
rules = World -> Set Rule
rules World
w1 Set Rule -> Set Rule -> Set Rule
forall a. Semigroup a => a -> a -> a
<> World -> Set Rule
rules World
w2
               , blockRules :: Set Rule
blockRules = World -> Set Rule
blockRules World
w1 Set Rule -> Set Rule -> Set Rule
forall a. Semigroup a => a -> a -> a
<> World -> Set Rule
blockRules World
w2
               , facts :: Set Fact
facts = World -> Set Fact
facts World
w1 Set Fact -> Set Fact -> Set Fact
forall a. Semigroup a => a -> a -> a
<> World -> Set Fact
facts World
w2
               }

instance Monoid World where
  mempty :: World
mempty = Set Rule -> Set Rule -> Set Fact -> World
World Set Rule
forall a. Monoid a => a
mempty Set Rule
forall a. Monoid a => a
mempty Set Fact
forall a. Monoid a => a
mempty

instance Show World where
  show :: World -> String
show World{Set Rule
Set Fact
facts :: Set Fact
blockRules :: Set Rule
rules :: Set Rule
facts :: World -> Set Fact
blockRules :: World -> Set Rule
rules :: World -> Set Rule
..} = Text -> String
unpack (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
intercalate Text
"\n" ([Text] -> String) -> [Text] -> String
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
    [ [ Text
"Authority & Verifier Rules" ]
    , Rule -> Text
renderRule (Rule -> Text) -> [Rule] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Rule -> [Rule]
forall a. Set a -> [a]
Set.toList Set Rule
rules
    , [ Text
"Block Rules" ]
    , Rule -> Text
renderRule (Rule -> Text) -> [Rule] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Rule -> [Rule]
forall a. Set a -> [a]
Set.toList Set Rule
blockRules
    , [ Text
"Facts" ]
    , Fact -> Text
renderFact (Fact -> Text) -> [Fact] -> [Text]
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
    ]

-- | Is the fact "restricted" (meaning it is not allowed to come from a block, or generated by a block rule).
-- In practice, only authority blocks can contain the symbols `#ambient` and `#authority`
isRestricted :: Fact -> Bool
isRestricted :: Fact -> Bool
isRestricted Predicate{[ID' 'NotWithinSet 'InFact 'RegularString]
terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [ID' 'NotWithinSet pof ctx]
terms :: [ID' 'NotWithinSet 'InFact 'RegularString]
terms} =
  let restrictedSymbol :: ID' inSet pof ctx -> Bool
restrictedSymbol (Symbol Text
s ) = Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"ambient" Bool -> Bool -> Bool
|| Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"authority"
      restrictedSymbol ID' inSet pof ctx
_           = Bool
False
   in (ID' 'NotWithinSet 'InFact 'RegularString -> Bool)
-> [ID' 'NotWithinSet 'InFact 'RegularString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ID' 'NotWithinSet 'InFact 'RegularString -> Bool
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
ID' inSet pof ctx -> Bool
restrictedSymbol [ID' 'NotWithinSet 'InFact 'RegularString]
terms

-- | Expose the block revocation ids through facts
revocationIdFacts :: Integer
                  -- ^ The block index (0 for authority, 1-n for blocks)
                  -> BlockWithRevocationIds
                  -> [Fact]
revocationIdFacts :: Integer -> BlockWithRevocationIds -> [Fact]
revocationIdFacts Integer
index BlockWithRevocationIds{ByteString
genericRevocationId :: ByteString
genericRevocationId :: BlockWithRevocationIds -> ByteString
genericRevocationId, ByteString
uniqueRevocationId :: ByteString
uniqueRevocationId :: BlockWithRevocationIds -> ByteString
uniqueRevocationId} =
  [ [fact|revocation_id(${index}, ${genericRevocationId})|]
  , [fact|unique_revocation_id(${index}, ${uniqueRevocationId})|]
  ]

collectWorld :: Limits -> Verifier -> BlockWithRevocationIds -> [BlockWithRevocationIds] -> World
collectWorld :: Limits
-> Verifier
-> BlockWithRevocationIds
-> [BlockWithRevocationIds]
-> World
collectWorld Limits{Bool
allowBlockFacts :: Bool
allowBlockFacts :: Limits -> Bool
allowBlockFacts} Verifier{Block
vBlock :: forall (ctx :: ParsedAs). Verifier' ctx -> Block' ctx
vBlock :: Block
vBlock} BlockWithRevocationIds
authority [BlockWithRevocationIds]
blocks =
  let getRules :: BlockWithRevocationIds -> [Rule]
getRules = Block -> [Rule]
forall (ctx :: ParsedAs). Block' ctx -> [Rule' ctx]
bRules (Block -> [Rule])
-> (BlockWithRevocationIds -> Block)
-> BlockWithRevocationIds
-> [Rule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockWithRevocationIds -> Block
bBlock
      getFacts :: BlockWithRevocationIds -> [Fact]
getFacts = Block -> [Fact]
forall (ctx :: ParsedAs). Block' ctx -> [Predicate' 'InFact ctx]
bFacts (Block -> [Fact])
-> (BlockWithRevocationIds -> Block)
-> BlockWithRevocationIds
-> [Fact]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockWithRevocationIds -> Block
bBlock
      revocationIds :: [Fact]
revocationIds = [[Fact]] -> [Fact]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Fact]] -> [Fact]) -> [[Fact]] -> [Fact]
forall a b. (a -> b) -> a -> b
$ (Integer -> BlockWithRevocationIds -> [Fact])
-> [Integer] -> [BlockWithRevocationIds] -> [[Fact]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> BlockWithRevocationIds -> [Fact]
revocationIdFacts [Integer
0..] (BlockWithRevocationIds
authority BlockWithRevocationIds
-> [BlockWithRevocationIds] -> [BlockWithRevocationIds]
forall a. a -> [a] -> [a]
: [BlockWithRevocationIds]
blocks)
   in World :: Set Rule -> Set Rule -> Set Fact -> World
World
        { rules :: Set Rule
rules = [Rule] -> Set Rule
forall a. Ord a => [a] -> Set a
Set.fromList ([Rule] -> Set Rule) -> [Rule] -> Set Rule
forall a b. (a -> b) -> a -> b
$ Block -> [Rule]
forall (ctx :: ParsedAs). Block' ctx -> [Rule' ctx]
bRules Block
vBlock [Rule] -> [Rule] -> [Rule]
forall a. Semigroup a => a -> a -> a
<> BlockWithRevocationIds -> [Rule]
getRules BlockWithRevocationIds
authority
        , blockRules :: Set Rule
blockRules = if Bool
allowBlockFacts
                       then [Rule] -> Set Rule
forall a. Ord a => [a] -> Set a
Set.fromList ([Rule] -> Set Rule) -> [Rule] -> Set Rule
forall a b. (a -> b) -> a -> b
$ (BlockWithRevocationIds -> [Rule])
-> [BlockWithRevocationIds] -> [Rule]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap BlockWithRevocationIds -> [Rule]
getRules [BlockWithRevocationIds]
blocks
                       else Set Rule
forall a. Monoid a => a
mempty
        , facts :: Set Fact
facts = [Fact] -> Set Fact
forall a. Ord a => [a] -> Set a
Set.fromList ([Fact] -> Set Fact) -> [Fact] -> Set Fact
forall a b. (a -> b) -> a -> b
$
                  Block -> [Fact]
forall (ctx :: ParsedAs). Block' ctx -> [Predicate' 'InFact ctx]
bFacts Block
vBlock
               [Fact] -> [Fact] -> [Fact]
forall a. Semigroup a => a -> a -> a
<> BlockWithRevocationIds -> [Fact]
getFacts BlockWithRevocationIds
authority
               [Fact] -> [Fact] -> [Fact]
forall a. Semigroup a => a -> a -> a
<> (Fact -> Bool) -> [Fact] -> [Fact]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Bool
allowBlockFacts Bool -> Bool -> Bool
&&) (Bool -> Bool) -> (Fact -> Bool) -> Fact -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (Fact -> Bool) -> Fact -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fact -> Bool
isRestricted) (BlockWithRevocationIds -> [Fact]
getFacts (BlockWithRevocationIds -> [Fact])
-> [BlockWithRevocationIds] -> [Fact]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [BlockWithRevocationIds]
blocks)
               [Fact] -> [Fact] -> [Fact]
forall a. Semigroup a => a -> a -> a
<> [Fact]
revocationIds
        }

-- | Given a series of blocks and a verifier, ensure that all
-- the checks and policies match
runVerifier :: BlockWithRevocationIds
            -- ^ The authority block
            -> [BlockWithRevocationIds]
            -- ^ The extra blocks
            -> Verifier
            -- ^ A verifier
            -> IO (Either ExecutionError Query)
runVerifier :: BlockWithRevocationIds
-> [BlockWithRevocationIds]
-> Verifier
-> IO (Either ExecutionError Query)
runVerifier = Limits
-> BlockWithRevocationIds
-> [BlockWithRevocationIds]
-> Verifier
-> IO (Either ExecutionError Query)
runVerifierWithLimits Limits
defaultLimits

-- | Given a series of blocks and a verifier, ensure that all
-- the checks and policies match, with provided execution
-- constraints
runVerifierWithLimits :: Limits
                      -- ^ custom limits
                      -> BlockWithRevocationIds
                      -- ^ The authority block
                      -> [BlockWithRevocationIds]
                      -- ^ The extra blocks
                      -> Verifier
                      -- ^ A verifier
                      -> IO (Either ExecutionError Query)
runVerifierWithLimits :: Limits
-> BlockWithRevocationIds
-> [BlockWithRevocationIds]
-> Verifier
-> IO (Either ExecutionError Query)
runVerifierWithLimits l :: Limits
l@Limits{Bool
Int
ByteString -> IO (Either () ())
checkRevocationId :: ByteString -> IO (Either () ())
allowBlockFacts :: Bool
allowRegexes :: Bool
maxTime :: Int
maxIterations :: Int
maxFacts :: Int
checkRevocationId :: Limits -> ByteString -> IO (Either () ())
allowBlockFacts :: Limits -> Bool
allowRegexes :: Limits -> Bool
maxTime :: Limits -> Int
maxIterations :: Limits -> Int
maxFacts :: Limits -> Int
..} BlockWithRevocationIds
authority [BlockWithRevocationIds]
blocks Verifier
v = do
  Maybe (Either ExecutionError Query)
resultOrTimeout <- Int
-> IO (Either ExecutionError Query)
-> IO (Maybe (Either ExecutionError Query))
forall a. Int -> IO a -> IO (Maybe a)
timer Int
maxTime (IO (Either ExecutionError Query)
 -> IO (Maybe (Either ExecutionError Query)))
-> IO (Either ExecutionError Query)
-> IO (Maybe (Either ExecutionError Query))
forall a b. (a -> b) -> a -> b
$ Limits
-> BlockWithRevocationIds
-> [BlockWithRevocationIds]
-> Verifier
-> IO (Either ExecutionError Query)
runVerifier' Limits
l BlockWithRevocationIds
authority [BlockWithRevocationIds]
blocks Verifier
v
  Either ExecutionError Query -> IO (Either ExecutionError Query)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ExecutionError Query -> IO (Either ExecutionError Query))
-> Either ExecutionError Query -> IO (Either ExecutionError Query)
forall a b. (a -> b) -> a -> b
$ case Maybe (Either ExecutionError Query)
resultOrTimeout of
    Maybe (Either ExecutionError Query)
Nothing -> ExecutionError -> Either ExecutionError Query
forall a b. a -> Either a b
Left ExecutionError
Timeout
    Just Either ExecutionError Query
r  -> Either ExecutionError Query
r

runVerifier' :: Limits
             -> BlockWithRevocationIds
             -> [BlockWithRevocationIds]
             -> Verifier
             -> IO (Either ExecutionError Query)
runVerifier' :: Limits
-> BlockWithRevocationIds
-> [BlockWithRevocationIds]
-> Verifier
-> IO (Either ExecutionError Query)
runVerifier' Limits
l BlockWithRevocationIds
authority [BlockWithRevocationIds]
blocks v :: Verifier
v@Verifier{[Policy' 'RegularString]
Block
vPolicies :: forall (ctx :: ParsedAs). Verifier' ctx -> [Policy' ctx]
vBlock :: Block
vPolicies :: [Policy' 'RegularString]
vBlock :: forall (ctx :: ParsedAs). Verifier' ctx -> Block' ctx
..} = do
  let initialWorld :: World
initialWorld = Limits
-> Verifier
-> BlockWithRevocationIds
-> [BlockWithRevocationIds]
-> World
collectWorld Limits
l Verifier
v BlockWithRevocationIds
authority [BlockWithRevocationIds]
blocks
      allFacts' :: Either ExecutionError (Set Fact)
allFacts' = Limits -> World -> Either ExecutionError (Set Fact)
computeAllFacts Limits
l World
initialWorld
  case Either ExecutionError (Set Fact)
allFacts' of
      Left ExecutionError
e -> Either ExecutionError Query -> IO (Either ExecutionError Query)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ExecutionError Query -> IO (Either ExecutionError Query))
-> Either ExecutionError Query -> IO (Either ExecutionError Query)
forall a b. (a -> b) -> a -> b
$ ExecutionError -> Either ExecutionError Query
forall a b. a -> Either a b
Left ExecutionError
e
      Right Set Fact
allFacts -> do
        let allChecks :: [Query]
allChecks = (Block -> [Query]) -> [Block] -> [Query]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Block -> [Query]
forall (ctx :: ParsedAs). Block' ctx -> [Check' ctx]
bChecks ([Block] -> [Query]) -> [Block] -> [Query]
forall a b. (a -> b) -> a -> b
$ Block
vBlock Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: (BlockWithRevocationIds -> Block
bBlock (BlockWithRevocationIds -> Block)
-> [BlockWithRevocationIds] -> [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockWithRevocationIds
authority BlockWithRevocationIds
-> [BlockWithRevocationIds] -> [BlockWithRevocationIds]
forall a. a -> [a] -> [a]
: [BlockWithRevocationIds]
blocks)
            checkResults :: Validation (NonEmpty Query) ()
checkResults = (Query -> Validation (NonEmpty Query) ())
-> [Query] -> Validation (NonEmpty Query) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Limits -> Set Fact -> Query -> Validation (NonEmpty Query) ()
checkCheck Limits
l Set Fact
allFacts) [Query]
allChecks
            policiesResults :: [Either Query Query]
policiesResults = (Policy' 'RegularString -> Maybe (Either Query Query))
-> [Policy' 'RegularString] -> [Either Query Query]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Limits
-> Set Fact -> Policy' 'RegularString -> Maybe (Either Query Query)
checkPolicy Limits
l Set Fact
allFacts) [Policy' 'RegularString]
vPolicies
            policyResult :: Either (Maybe Query) Query
policyResult = case [Either Query Query]
policiesResults of
              Either Query Query
p : [Either Query Query]
_ -> (Query -> Maybe Query)
-> Either Query Query -> Either (Maybe Query) Query
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Query -> Maybe Query
forall a. a -> Maybe a
Just Either Query Query
p
              []    -> Maybe Query -> Either (Maybe Query) Query
forall a b. a -> Either a b
Left Maybe Query
forall a. Maybe a
Nothing
        Either ExecutionError Query -> IO (Either ExecutionError Query)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ExecutionError Query -> IO (Either ExecutionError Query))
-> Either ExecutionError Query -> IO (Either ExecutionError Query)
forall a b. (a -> b) -> a -> b
$ case (Validation (NonEmpty Query) ()
checkResults, Either (Maybe Query) Query
policyResult) of
          (Success (), Right Query
p)       -> Query -> Either ExecutionError Query
forall a b. b -> Either a b
Right Query
p
          (Success (), Left Maybe Query
Nothing)  -> ExecutionError -> Either ExecutionError Query
forall a b. a -> Either a b
Left (ExecutionError -> Either ExecutionError Query)
-> ExecutionError -> Either ExecutionError Query
forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError (ResultError -> ExecutionError) -> ResultError -> ExecutionError
forall a b. (a -> b) -> a -> b
$ [Query] -> ResultError
NoPoliciesMatched []
          (Success (), Left (Just Query
p)) -> ExecutionError -> Either ExecutionError Query
forall a b. a -> Either a b
Left (ExecutionError -> Either ExecutionError Query)
-> ExecutionError -> Either ExecutionError Query
forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError (ResultError -> ExecutionError) -> ResultError -> ExecutionError
forall a b. (a -> b) -> a -> b
$ [Query] -> Query -> ResultError
DenyRuleMatched [] Query
p
          (Failure NonEmpty Query
cs, Left Maybe Query
Nothing)  -> ExecutionError -> Either ExecutionError Query
forall a b. a -> Either a b
Left (ExecutionError -> Either ExecutionError Query)
-> ExecutionError -> Either ExecutionError Query
forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError (ResultError -> ExecutionError) -> ResultError -> ExecutionError
forall a b. (a -> b) -> a -> b
$ [Query] -> ResultError
NoPoliciesMatched (NonEmpty Query -> [Query]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Query
cs)
          (Failure NonEmpty Query
cs, Left (Just Query
p)) -> ExecutionError -> Either ExecutionError Query
forall a b. a -> Either a b
Left (ExecutionError -> Either ExecutionError Query)
-> ExecutionError -> Either ExecutionError Query
forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError (ResultError -> ExecutionError) -> ResultError -> ExecutionError
forall a b. (a -> b) -> a -> b
$ [Query] -> Query -> ResultError
DenyRuleMatched (NonEmpty Query -> [Query]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Query
cs) Query
p
          (Failure NonEmpty Query
cs, Right Query
_)       -> ExecutionError -> Either ExecutionError Query
forall a b. a -> Either a b
Left (ExecutionError -> Either ExecutionError Query)
-> ExecutionError -> Either ExecutionError Query
forall a b. (a -> b) -> a -> b
$ ResultError -> ExecutionError
ResultError (ResultError -> ExecutionError) -> ResultError -> ExecutionError
forall a b. (a -> b) -> a -> b
$ NonEmpty Query -> ResultError
FailedChecks NonEmpty Query
cs

checkCheck :: Limits -> Set Fact -> Check -> Validation (NonEmpty Check) ()
checkCheck :: Limits -> Set Fact -> Query -> Validation (NonEmpty Query) ()
checkCheck Limits
l Set Fact
facts Query
items =
  if (QueryItem' 'RegularString -> Bool) -> Query -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Limits -> Set Fact -> QueryItem' 'RegularString -> Bool
isQueryItemSatisfied Limits
l Set Fact
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 -> Set Fact -> Policy -> Maybe (Either Query Query)
checkPolicy :: Limits
-> Set Fact -> Policy' 'RegularString -> Maybe (Either Query Query)
checkPolicy Limits
l Set Fact
facts (PolicyType
pType, Query
items) =
  if (QueryItem' 'RegularString -> Bool) -> Query -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Limits -> Set Fact -> QueryItem' 'RegularString -> Bool
isQueryItemSatisfied Limits
l Set Fact
facts) Query
items
  then Either Query Query -> Maybe (Either Query Query)
forall a. a -> Maybe a
Just (Either Query Query -> Maybe (Either Query Query))
-> Either Query Query -> Maybe (Either Query Query)
forall a b. (a -> b) -> a -> b
$ case PolicyType
pType of
    PolicyType
Allow -> Query -> Either Query Query
forall a b. b -> Either a b
Right Query
items
    PolicyType
Deny  -> Query -> Either Query Query
forall a b. a -> Either a b
Left Query
items
  else Maybe (Either Query Query)
forall a. Maybe a
Nothing

isQueryItemSatisfied :: Limits -> Set Fact -> QueryItem' 'RegularString -> Bool
isQueryItemSatisfied :: Limits -> Set Fact -> QueryItem' 'RegularString -> Bool
isQueryItemSatisfied Limits
l Set Fact
facts 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} =
  let bindings :: Set Bindings
bindings = Limits
-> Set Fact
-> [Predicate' 'InPredicate 'RegularString]
-> [Expression' 'RegularString]
-> Set Bindings
getBindingsForRuleBody Limits
l Set Fact
facts [Predicate' 'InPredicate 'RegularString]
qBody [Expression' 'RegularString]
qExpressions
   in 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

-- | Compute all possible facts, recursively calling itself
-- until it can't generate new facts or a limit is reached
computeAllFacts :: Limits
                -- ^ The maximum amount of iterations that can be reached
                -> World
                -- ^ The initial rules and facts
                -> Either ExecutionError (Set Fact)
computeAllFacts :: Limits -> World -> Either ExecutionError (Set Fact)
computeAllFacts l :: Limits
l@Limits{Bool
Int
ByteString -> IO (Either () ())
checkRevocationId :: ByteString -> IO (Either () ())
allowBlockFacts :: Bool
allowRegexes :: Bool
maxTime :: Int
maxIterations :: Int
maxFacts :: Int
checkRevocationId :: Limits -> ByteString -> IO (Either () ())
allowBlockFacts :: Limits -> Bool
allowRegexes :: Limits -> Bool
maxTime :: Limits -> Int
maxIterations :: Limits -> Int
maxFacts :: Limits -> Int
..} = Limits -> Int -> World -> Either ExecutionError (Set Fact)
computeAllFacts' Limits
l Int
maxIterations


-- | Compute all possible facts, recursively calling itself
-- until it can't generate new facts or a limit is reached
computeAllFacts' :: Limits
                 -> Int
                 -> World
                 -> Either ExecutionError (Set Fact)
computeAllFacts' :: Limits -> Int -> World -> Either ExecutionError (Set Fact)
computeAllFacts' l :: Limits
l@Limits{Bool
Int
ByteString -> IO (Either () ())
checkRevocationId :: ByteString -> IO (Either () ())
allowBlockFacts :: Bool
allowRegexes :: Bool
maxTime :: Int
maxIterations :: Int
maxFacts :: Int
checkRevocationId :: Limits -> ByteString -> IO (Either () ())
allowBlockFacts :: Limits -> Bool
allowRegexes :: Limits -> Bool
maxTime :: Limits -> Int
maxIterations :: Limits -> Int
maxFacts :: Limits -> Int
..} Int
remainingIterations w :: World
w@World{Set Fact
facts :: Set Fact
facts :: World -> Set Fact
facts} = do
  let newFacts :: Set Fact
newFacts = Limits -> World -> Set Fact
extend Limits
l World
w
      allFacts :: Set Fact
allFacts = Set Fact
facts Set Fact -> Set Fact -> Set Fact
forall a. Semigroup a => a -> a -> a
<> Set Fact
newFacts
  Bool -> Either ExecutionError () -> Either ExecutionError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set Fact -> Int
forall a. Set a -> Int
Set.size Set Fact
allFacts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxFacts) (Either ExecutionError () -> Either ExecutionError ())
-> Either ExecutionError () -> Either ExecutionError ()
forall a b. (a -> b) -> a -> b
$ ExecutionError -> Either ExecutionError ()
forall a b. a -> Either a b
Left ExecutionError
TooManyFacts
  Bool -> Either ExecutionError () -> Either ExecutionError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
remainingIterations Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0) (Either ExecutionError () -> Either ExecutionError ())
-> Either ExecutionError () -> Either ExecutionError ()
forall a b. (a -> b) -> a -> b
$ ExecutionError -> Either ExecutionError ()
forall a b. a -> Either a b
Left ExecutionError
TooManyIterations
  if Set Fact -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Fact
newFacts
  then Set Fact -> Either ExecutionError (Set Fact)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set Fact
allFacts
  else Limits -> Int -> World -> Either ExecutionError (Set Fact)
computeAllFacts' Limits
l (Int
remainingIterations Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (World
w { facts :: Set Fact
facts = Set Fact
allFacts })

extend :: Limits -> World -> Set Fact
extend :: Limits -> World -> Set Fact
extend Limits
l World{Set Rule
Set Fact
facts :: Set Fact
blockRules :: Set Rule
rules :: Set Rule
facts :: World -> Set Fact
blockRules :: World -> Set Rule
rules :: World -> Set Rule
..} =
  let buildFacts :: Set Rule -> Set Fact
buildFacts = (Rule -> Set Fact) -> Set Rule -> Set Fact
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Limits -> Set Fact -> Rule -> Set Fact
getFactsForRule Limits
l Set Fact
facts)
      allNewFacts :: Set Fact
allNewFacts = Set Rule -> Set Fact
buildFacts Set Rule
rules
      allNewBlockFacts :: Set Fact
allNewBlockFacts = (Fact -> Bool) -> Set Fact -> Set Fact
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not (Bool -> Bool) -> (Fact -> Bool) -> Fact -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fact -> Bool
isRestricted) (Set Fact -> Set Fact) -> Set Fact -> Set Fact
forall a b. (a -> b) -> a -> b
$ Set Rule -> Set Fact
buildFacts Set Rule
blockRules
   in Set Fact -> Set Fact -> Set Fact
forall a. Ord a => Set a -> Set a -> Set a
Set.difference (Set Fact
allNewFacts Set Fact -> Set Fact -> Set Fact
forall a. Semigroup a => a -> a -> a
<> Set Fact
allNewBlockFacts) Set Fact
facts

getFactsForRule :: Limits -> Set Fact -> Rule -> Set Fact
getFactsForRule :: Limits -> Set Fact -> Rule -> Set Fact
getFactsForRule Limits
l Set 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 Bindings
legalBindings = Limits
-> Set Fact
-> [Predicate' 'InPredicate 'RegularString]
-> [Expression' 'RegularString]
-> Set Bindings
getBindingsForRuleBody Limits
l Set Fact
facts [Predicate' 'InPredicate 'RegularString]
body [Expression' 'RegularString]
expressions
      newFacts :: [Fact]
newFacts = (Bindings -> Maybe Fact) -> [Bindings] -> [Fact]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Predicate' 'InPredicate 'RegularString -> Bindings -> Maybe Fact
applyBindings Predicate' 'InPredicate 'RegularString
rhead) ([Bindings] -> [Fact]) -> [Bindings] -> [Fact]
forall a b. (a -> b) -> a -> b
$ Set Bindings -> [Bindings]
forall a. Set a -> [a]
Set.toList Set Bindings
legalBindings
   in [Fact] -> Set Fact
forall a. Ord a => [a] -> Set a
Set.fromList [Fact]
newFacts

getBindingsForRuleBody :: Limits -> Set Fact -> [Predicate] -> [Expression] -> Set Bindings
getBindingsForRuleBody :: Limits
-> Set Fact
-> [Predicate' 'InPredicate 'RegularString]
-> [Expression' 'RegularString]
-> Set Bindings
getBindingsForRuleBody Limits
l Set Fact
facts [Predicate' 'InPredicate 'RegularString]
body [Expression' 'RegularString]
expressions =
  let candidateBindings :: [Set Bindings]
candidateBindings = Set Fact
-> [Predicate' 'InPredicate 'RegularString] -> [Set Bindings]
getCandidateBindings Set Fact
facts [Predicate' 'InPredicate 'RegularString]
body
      allVariables :: Set Text
allVariables = [Predicate' 'InPredicate 'RegularString] -> Set Text
extractVariables [Predicate' 'InPredicate 'RegularString]
body
      legalBindingsForFacts :: Set Bindings
legalBindingsForFacts = Set Text -> [Set Bindings] -> Set Bindings
reduceCandidateBindings Set Text
allVariables [Set Bindings]
candidateBindings
   in (Bindings -> Bool) -> Set Bindings -> Set Bindings
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\Bindings
b -> (Expression' 'RegularString -> Bool)
-> [Expression' 'RegularString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Limits -> Bindings -> Expression' 'RegularString -> Bool
satisfies Limits
l Bindings
b) [Expression' 'RegularString]
expressions) Set Bindings
legalBindingsForFacts

satisfies :: Limits
          -> Bindings
          -> Expression
          -> Bool
satisfies :: Limits -> Bindings -> Expression' 'RegularString -> Bool
satisfies Limits
l Bindings
b Expression' 'RegularString
e = Limits
-> Bindings
-> Expression' 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
evaluateExpression Limits
l Bindings
b Expression' 'RegularString
e Either String (ID' 'NotWithinSet 'InFact 'RegularString)
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString) -> Bool
forall a. Eq a => a -> a -> Bool
== ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. b -> Either a b
Right (Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool Bool
True)

extractVariables :: [Predicate] -> Set Name
extractVariables :: [Predicate' 'InPredicate 'RegularString] -> Set Text
extractVariables [Predicate' 'InPredicate 'RegularString]
predicates =
  let keepVariable :: ID' 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
        ID' inSet pof ctx
_ -> Maybe (VariableType inSet pof)
forall a. Maybe a
Nothing
      extractVariables' :: Predicate' pof ctx -> [VariableType 'NotWithinSet pof]
extractVariables' Predicate{[ID' 'NotWithinSet pof ctx]
terms :: [ID' 'NotWithinSet pof ctx]
terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [ID' 'NotWithinSet pof ctx]
terms} = (ID' 'NotWithinSet pof ctx
 -> Maybe (VariableType 'NotWithinSet pof))
-> [ID' 'NotWithinSet pof ctx] -> [VariableType 'NotWithinSet pof]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ID' 'NotWithinSet pof ctx -> Maybe (VariableType 'NotWithinSet pof)
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
ID' inSet pof ctx -> Maybe (VariableType inSet pof)
keepVariable [ID' '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 -> Bindings -> Maybe Fact
applyBindings :: Predicate' 'InPredicate 'RegularString -> Bindings -> Maybe Fact
applyBindings p :: Predicate' 'InPredicate 'RegularString
p@Predicate{[ID' 'NotWithinSet 'InPredicate 'RegularString]
terms :: [ID' 'NotWithinSet 'InPredicate 'RegularString]
terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [ID' 'NotWithinSet pof ctx]
terms} Bindings
bindings =
  let newTerms :: Maybe [ID' 'NotWithinSet 'InFact 'RegularString]
newTerms = (ID' 'NotWithinSet 'InPredicate 'RegularString
 -> Maybe (ID' 'NotWithinSet 'InFact 'RegularString))
-> [ID' 'NotWithinSet 'InPredicate 'RegularString]
-> Maybe [ID' 'NotWithinSet 'InFact 'RegularString]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ID' 'NotWithinSet 'InPredicate 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
replaceTerm [ID' 'NotWithinSet 'InPredicate 'RegularString]
terms
      replaceTerm :: ID -> Maybe Value
      replaceTerm :: ID' 'NotWithinSet 'InPredicate 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
replaceTerm (Variable VariableType 'NotWithinSet 'InPredicate
n)  = Text
-> Bindings -> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
VariableType 'NotWithinSet 'InPredicate
n Bindings
bindings
      replaceTerm (Symbol Text
t)    = ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a. a -> Maybe a
Just (ID' 'NotWithinSet 'InFact 'RegularString
 -> Maybe (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Text -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Text -> ID' inSet pof ctx
Symbol Text
t
      replaceTerm (LInteger Int
t)  = ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a. a -> Maybe a
Just (ID' 'NotWithinSet 'InFact 'RegularString
 -> Maybe (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Int -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> ID' inSet pof ctx
LInteger Int
t
      replaceTerm (LString Text
t)   = ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a. a -> Maybe a
Just (ID' 'NotWithinSet 'InFact 'RegularString
 -> Maybe (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Text -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Text -> ID' inSet pof ctx
LString Text
t
      replaceTerm (LDate UTCTime
t)     = ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a. a -> Maybe a
Just (ID' 'NotWithinSet 'InFact 'RegularString
 -> Maybe (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ UTCTime -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
UTCTime -> ID' inSet pof ctx
LDate UTCTime
t
      replaceTerm (LBytes ByteString
t)    = ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a. a -> Maybe a
Just (ID' 'NotWithinSet 'InFact 'RegularString
 -> Maybe (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
ByteString -> ID' inSet pof ctx
LBytes ByteString
t
      replaceTerm (LBool Bool
t)     = ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a. a -> Maybe a
Just (ID' 'NotWithinSet 'InFact 'RegularString
 -> Maybe (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool Bool
t
      replaceTerm (TermSet SetType 'NotWithinSet 'RegularString
t)   = ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a. a -> Maybe a
Just (ID' 'NotWithinSet 'InFact 'RegularString
 -> Maybe (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ SetType 'NotWithinSet 'RegularString
-> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SetType inSet ctx -> ID' inSet pof ctx
TermSet SetType 'NotWithinSet 'RegularString
t
      replaceTerm (Antiquote SliceType 'RegularString
t) = Void -> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall a. Void -> a
absurd Void
SliceType 'RegularString
t
   in (\[ID' 'NotWithinSet 'InFact 'RegularString]
nt -> Predicate' 'InPredicate 'RegularString
p { terms :: [ID' 'NotWithinSet 'InFact 'RegularString]
terms = [ID' 'NotWithinSet 'InFact 'RegularString]
nt}) ([ID' 'NotWithinSet 'InFact 'RegularString] -> Fact)
-> Maybe [ID' 'NotWithinSet 'InFact 'RegularString] -> Maybe Fact
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [ID' 'NotWithinSet 'InFact 'RegularString]
newTerms

getCombinations :: [[a]] -> [[a]]
getCombinations :: [[a]] -> [[a]]
getCombinations ([a]
x:[[a]]
xs) = do
  a
y <- [a]
x
  (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> [[a]] -> [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[a]] -> [[a]]
forall a. [[a]] -> [[a]]
getCombinations [[a]]
xs
getCombinations []     = [[]]

mergeBindings :: [Bindings] -> Bindings
mergeBindings :: [Bindings] -> Bindings
mergeBindings =
  -- group all the values unified with each variable
  let combinations :: [Bindings]
-> Map Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
combinations = (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
 -> NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
 -> NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
-> [Map Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))]
-> Map Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
-> NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
-> NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
forall a. Semigroup a => a -> a -> a
(<>) ([Map Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))]
 -> Map Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)))
-> ([Bindings]
    -> [Map
          Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))])
-> [Bindings]
-> Map Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bindings
 -> Map Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)))
-> [Bindings]
-> [Map Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ID' 'NotWithinSet 'InFact 'RegularString
 -> NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
-> Bindings
-> Map Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ID' 'NotWithinSet 'InFact 'RegularString
-> NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
      sameValues :: NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
sameValues = (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
 -> ID' 'NotWithinSet 'InFact 'RegularString)
-> Maybe (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
-> ID' 'NotWithinSet 'InFact 'RegularString
forall a. NonEmpty a -> a
NE.head (Maybe (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
 -> Maybe (ID' 'NotWithinSet 'InFact 'RegularString))
-> (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
    -> Maybe (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)))
-> NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString) -> Bool)
-> Maybe (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
-> Maybe (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
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 (ID' 'NotWithinSet 'InFact 'RegularString) -> Int)
-> NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) (Maybe (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
 -> Maybe (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)))
-> (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
    -> Maybe (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)))
-> NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
-> Maybe (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
-> Maybe (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
forall a. a -> Maybe a
Just (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
 -> Maybe (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)))
-> (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
    -> NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
-> NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
-> Maybe (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
-> NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub
  -- only keep
      keepConsistent :: Map k (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
-> Map k (ID' 'NotWithinSet 'InFact 'RegularString)
keepConsistent = (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
 -> Maybe (ID' 'NotWithinSet 'InFact 'RegularString))
-> Map k (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
-> Map k (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
sameValues
   in Map Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
-> Bindings
forall k.
Map k (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
-> Map k (ID' 'NotWithinSet 'InFact 'RegularString)
keepConsistent (Map Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
 -> Bindings)
-> ([Bindings]
    -> Map Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString)))
-> [Bindings]
-> Bindings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bindings]
-> Map Text (NonEmpty (ID' 'NotWithinSet 'InFact 'RegularString))
combinations

reduceCandidateBindings :: Set Name
                        -> [Set Bindings]
                        -> Set Bindings
reduceCandidateBindings :: Set Text -> [Set Bindings] -> Set Bindings
reduceCandidateBindings Set Text
allVariables [Set Bindings]
matches =
  let allCombinations :: [[Bindings]]
      allCombinations :: [[Bindings]]
allCombinations = [[Bindings]] -> [[Bindings]]
forall a. [[a]] -> [[a]]
getCombinations ([[Bindings]] -> [[Bindings]]) -> [[Bindings]] -> [[Bindings]]
forall a b. (a -> b) -> a -> b
$ Set Bindings -> [Bindings]
forall a. Set a -> [a]
Set.toList (Set Bindings -> [Bindings]) -> [Set Bindings] -> [[Bindings]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Set Bindings]
matches
      isComplete :: Bindings -> Bool
      isComplete :: Bindings -> Bool
isComplete = (Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== Set Text
allVariables) (Set Text -> Bool) -> (Bindings -> Set Text) -> 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)
-> (Bindings -> [Text]) -> Bindings -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bindings -> [Text]
forall k a. Map k a -> [k]
Map.keys
   in [Bindings] -> Set Bindings
forall a. Ord a => [a] -> Set a
Set.fromList ([Bindings] -> Set Bindings) -> [Bindings] -> Set Bindings
forall a b. (a -> b) -> a -> b
$ (Bindings -> Bool) -> [Bindings] -> [Bindings]
forall a. (a -> Bool) -> [a] -> [a]
filter Bindings -> Bool
isComplete ([Bindings] -> [Bindings]) -> [Bindings] -> [Bindings]
forall a b. (a -> b) -> a -> b
$ [Bindings] -> Bindings
mergeBindings ([Bindings] -> Bindings) -> [[Bindings]] -> [Bindings]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Bindings]]
allCombinations

getCandidateBindings :: Set Fact
                     -> [Predicate]
                     -> [Set Bindings]
getCandidateBindings :: Set Fact
-> [Predicate' 'InPredicate 'RegularString] -> [Set Bindings]
getCandidateBindings Set Fact
facts [Predicate' 'InPredicate 'RegularString]
predicates =
   let mapMaybeS :: (a -> t a) -> t a -> Set a
mapMaybeS a -> t a
f = (a -> Set a) -> t a -> Set a
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> Set a) -> t a -> Set a
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Set a
forall a. a -> Set a
Set.singleton (t a -> Set a) -> (a -> t a) -> a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> t a
f)
       keepFacts :: Predicate' 'InPredicate 'RegularString -> Set Bindings
keepFacts Predicate' 'InPredicate 'RegularString
p = (Fact -> Maybe Bindings) -> Set Fact -> Set Bindings
forall a (t :: * -> *) (t :: * -> *) a.
(Ord a, Foldable t, Foldable t) =>
(a -> t a) -> t a -> Set a
mapMaybeS (Predicate' 'InPredicate 'RegularString -> Fact -> Maybe Bindings
factMatchesPredicate Predicate' 'InPredicate 'RegularString
p) Set Fact
facts
    in Predicate' 'InPredicate 'RegularString -> Set Bindings
keepFacts (Predicate' 'InPredicate 'RegularString -> Set Bindings)
-> [Predicate' 'InPredicate 'RegularString] -> [Set Bindings]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Predicate' 'InPredicate 'RegularString]
predicates

isSame :: ID -> Value -> Bool
isSame :: ID' 'NotWithinSet 'InPredicate 'RegularString
-> ID' 'NotWithinSet 'InFact 'RegularString -> Bool
isSame (Symbol Text
t)   (Symbol Text
t')   = Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t'
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 (ID' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t Set (ID' 'WithinSet 'InFact 'RegularString)
-> Set (ID' 'WithinSet 'InFact 'RegularString) -> Bool
forall a. Eq a => a -> a -> Bool
== Set (ID' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t'
isSame ID' 'NotWithinSet 'InPredicate 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_                        = Bool
False

factMatchesPredicate :: Predicate -> Fact -> Maybe Bindings
factMatchesPredicate :: Predicate' 'InPredicate 'RegularString -> Fact -> Maybe 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 -> [ID' 'NotWithinSet pof ctx]
terms = [ID' 'NotWithinSet 'InPredicate 'RegularString]
predicateTerms }
                     Predicate{name :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> Text
name = Text
factName, terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [ID' 'NotWithinSet pof ctx]
terms = [ID' 'NotWithinSet 'InFact 'RegularString]
factTerms } =
  let namesMatch :: Bool
namesMatch = Text
predicateName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
factName
      lengthsMatch :: Bool
lengthsMatch = [ID' 'NotWithinSet 'InPredicate 'RegularString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ID' 'NotWithinSet 'InPredicate 'RegularString]
predicateTerms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [ID' 'NotWithinSet 'InFact 'RegularString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ID' 'NotWithinSet 'InFact 'RegularString]
factTerms
      allMatches :: Maybe [Bindings]
allMatches = [Maybe Bindings] -> Maybe [Bindings]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ([Maybe Bindings] -> Maybe [Bindings])
-> [Maybe Bindings] -> Maybe [Bindings]
forall a b. (a -> b) -> a -> b
$ (ID' 'NotWithinSet 'InPredicate 'RegularString
 -> ID' 'NotWithinSet 'InFact 'RegularString -> Maybe Bindings)
-> [ID' 'NotWithinSet 'InPredicate 'RegularString]
-> [ID' 'NotWithinSet 'InFact 'RegularString]
-> [Maybe Bindings]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ID' 'NotWithinSet 'InPredicate 'RegularString
-> ID' 'NotWithinSet 'InFact 'RegularString -> Maybe Bindings
yolo [ID' 'NotWithinSet 'InPredicate 'RegularString]
predicateTerms [ID' 'NotWithinSet 'InFact 'RegularString]
factTerms
      yolo :: ID -> Value -> Maybe Bindings
      yolo :: ID' 'NotWithinSet 'InPredicate 'RegularString
-> ID' 'NotWithinSet 'InFact 'RegularString -> Maybe Bindings
yolo (Variable VariableType 'NotWithinSet 'InPredicate
vname) ID' 'NotWithinSet 'InFact 'RegularString
value = Bindings -> Maybe Bindings
forall a. a -> Maybe a
Just (Text -> ID' 'NotWithinSet 'InFact 'RegularString -> Bindings
forall k a. k -> a -> Map k a
Map.singleton Text
VariableType 'NotWithinSet 'InPredicate
vname ID' 'NotWithinSet 'InFact 'RegularString
value)
      yolo ID' 'NotWithinSet 'InPredicate 'RegularString
t ID' 'NotWithinSet 'InFact 'RegularString
t' | ID' 'NotWithinSet 'InPredicate 'RegularString
-> ID' 'NotWithinSet 'InFact 'RegularString -> Bool
isSame ID' 'NotWithinSet 'InPredicate 'RegularString
t ID' 'NotWithinSet 'InFact 'RegularString
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 [Bindings] -> Bindings
mergeBindings ([Bindings] -> Bindings) -> Maybe [Bindings] -> Maybe Bindings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Bindings]
allMatches
      else Maybe Bindings
forall a. Maybe a
Nothing

applyVariable :: Bindings
              -> ID
              -> Either String Value
applyVariable :: Bindings
-> ID' 'NotWithinSet 'InPredicate 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
applyVariable Bindings
bindings = \case
  Variable VariableType 'NotWithinSet 'InPredicate
n -> String
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall b a. b -> Maybe a -> Either b a
maybeToRight String
"Unbound variable" (Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bindings
bindings Bindings
-> Text -> Maybe (ID' 'NotWithinSet 'InFact 'RegularString)
forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
VariableType 'NotWithinSet 'InPredicate
n
  Symbol Text
t   -> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. b -> Either a b
Right (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Text -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Text -> ID' inSet pof ctx
Symbol Text
t
  LInteger Int
t -> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. b -> Either a b
Right (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Int -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> ID' inSet pof ctx
LInteger Int
t
  LString Text
t  -> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. b -> Either a b
Right (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Text -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Text -> ID' inSet pof ctx
LString Text
t
  LDate UTCTime
t    -> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. b -> Either a b
Right (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ UTCTime -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
UTCTime -> ID' inSet pof ctx
LDate UTCTime
t
  LBytes ByteString
t   -> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. b -> Either a b
Right (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
ByteString -> ID' inSet pof ctx
LBytes ByteString
t
  LBool Bool
t    -> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. b -> Either a b
Right (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool Bool
t
  TermSet SetType 'NotWithinSet 'RegularString
t  -> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. b -> Either a b
Right (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ SetType 'NotWithinSet 'RegularString
-> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SetType inSet ctx -> ID' inSet pof ctx
TermSet SetType 'NotWithinSet 'RegularString
t
  Antiquote SliceType 'RegularString
v -> Void -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a. Void -> a
absurd Void
SliceType 'RegularString
v

evalUnary :: Unary -> Value -> Either String Value
evalUnary :: Unary
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
evalUnary Unary
Parens ID' 'NotWithinSet 'InFact 'RegularString
t = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ID' 'NotWithinSet 'InFact 'RegularString
t
evalUnary Unary
Negate (LBool Bool
b) = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (Bool -> ID' 'NotWithinSet 'InFact 'RegularString)
-> Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
b)
evalUnary Unary
Negate ID' 'NotWithinSet 'InFact 'RegularString
_ = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"Only booleans support negation"
evalUnary Unary
Length (LString Text
t) = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> (Int -> ID' 'NotWithinSet 'InFact 'RegularString)
-> Int
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> ID' inSet pof ctx
LInteger (Int -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> Int -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Text -> Int
Text.length Text
t
evalUnary Unary
Length (LBytes ByteString
bs) = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> (Int -> ID' 'NotWithinSet 'InFact 'RegularString)
-> Int
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> ID' inSet pof ctx
LInteger (Int -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> Int -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
ByteString.length ByteString
bs
evalUnary Unary
Length (TermSet SetType 'NotWithinSet 'RegularString
s) = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> (Int -> ID' 'NotWithinSet 'InFact 'RegularString)
-> Int
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> ID' inSet pof ctx
LInteger (Int -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> Int -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Set (ID' 'WithinSet 'InFact 'RegularString) -> Int
forall a. Set a -> Int
Set.size Set (ID' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
s
evalUnary Unary
Length ID' 'NotWithinSet 'InFact 'RegularString
_ = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
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
-> ID' 'NotWithinSet 'InFact 'RegularString
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
evalBinary Limits
_ Binary
Equal (Symbol Text
s) (Symbol Text
s')     = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
s')
evalBinary Limits
_ Binary
Equal (LInteger Int
i) (LInteger Int
i') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' 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')   = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' 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')       = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' 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')     = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' 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')       = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' 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')   = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (Set (ID' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t Set (ID' 'WithinSet 'InFact 'RegularString)
-> Set (ID' 'WithinSet 'InFact 'RegularString) -> Bool
forall a. Eq a => a -> a -> Bool
== Set (ID' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t')
evalBinary Limits
_ Binary
Equal ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_                        = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"Equality mismatch"
evalBinary Limits
_ Binary
LessThan (LInteger Int
i) (LInteger Int
i') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' 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')       = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
t')
evalBinary Limits
_ Binary
LessThan ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_                        = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"< mismatch"
evalBinary Limits
_ Binary
GreaterThan (LInteger Int
i) (LInteger Int
i') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' 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')       = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
t')
evalBinary Limits
_ Binary
GreaterThan ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_                        = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"> mismatch"
evalBinary Limits
_ Binary
LessOrEqual (LInteger Int
i) (LInteger Int
i') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' 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')       = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
t')
evalBinary Limits
_ Binary
LessOrEqual ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_                        = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"<= mismatch"
evalBinary Limits
_ Binary
GreaterOrEqual (LInteger Int
i) (LInteger Int
i') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' 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')       = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
t')
evalBinary Limits
_ Binary
GreaterOrEqual ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_                        = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
">= mismatch"
-- string-related operations
evalBinary Limits
_ Binary
Prefix (LString Text
t) (LString Text
t') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (Text
t' Text -> Text -> Bool
`Text.isPrefixOf` Text
t)
evalBinary Limits
_ Binary
Prefix ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_                      = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"Only strings support `.starts_with()`"
evalBinary Limits
_ Binary
Suffix (LString Text
t) (LString Text
t') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (Text
t' Text -> Text -> Bool
`Text.isSuffixOf` Text
t)
evalBinary Limits
_ Binary
Suffix ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_                      = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
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 (ID' 'NotWithinSet 'InFact 'RegularString)
regexMatch Text
t Text
r
                                                               | Bool
otherwise    = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"Regex evaluation is disabled"
evalBinary Limits
_ Binary
Regex ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_                       = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
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') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Int -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> ID' inSet pof ctx
LInteger (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i')
evalBinary Limits
_ Binary
Add ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_ = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"Only integers support addition"
evalBinary Limits
_ Binary
Sub (LInteger Int
i) (LInteger Int
i') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Int -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> ID' inSet pof ctx
LInteger (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i')
evalBinary Limits
_ Binary
Sub ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_ = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"Only integers support subtraction"
evalBinary Limits
_ Binary
Mul (LInteger Int
i) (LInteger Int
i') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Int -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> ID' inSet pof ctx
LInteger (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i')
evalBinary Limits
_ Binary
Mul ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_ = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
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 (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"Divide by 0"
evalBinary Limits
_ Binary
Div (LInteger Int
i) (LInteger Int
i') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Int -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> ID' inSet pof ctx
LInteger (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
i')
evalBinary Limits
_ Binary
Div ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_ = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
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') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (Bool
b Bool -> Bool -> Bool
&& Bool
b')
evalBinary Limits
_ Binary
And ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_ = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"Only booleans support &&"
evalBinary Limits
_ Binary
Or (LBool Bool
b) (LBool Bool
b') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (Bool
b Bool -> Bool -> Bool
|| Bool
b')
evalBinary Limits
_ Binary
Or ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_ = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
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') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (Set (ID' 'WithinSet 'InFact 'RegularString)
-> Set (ID' 'WithinSet 'InFact 'RegularString) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set (ID' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t' Set (ID' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t)
evalBinary Limits
_ Binary
Contains (TermSet SetType 'NotWithinSet 'RegularString
t) ID' 'NotWithinSet 'InFact 'RegularString
t' = case ID' 'NotWithinSet 'InFact 'RegularString
-> Maybe (ID' 'WithinSet 'InFact 'RegularString)
toSetTerm ID' 'NotWithinSet 'InFact 'RegularString
t' of
    Just ID' 'WithinSet 'InFact 'RegularString
t'' -> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (ID' 'WithinSet 'InFact 'RegularString
-> Set (ID' 'WithinSet 'InFact 'RegularString) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ID' 'WithinSet 'InFact 'RegularString
t'' Set (ID' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t)
    Maybe (ID' 'WithinSet 'InFact 'RegularString)
Nothing  -> String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"Sets cannot contain nested sets nor variables"
evalBinary Limits
_ Binary
Contains ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_ = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"Only sets support `.contains()`"
evalBinary Limits
_ Binary
Intersection (TermSet SetType 'NotWithinSet 'RegularString
t) (TermSet SetType 'NotWithinSet 'RegularString
t') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ SetType 'NotWithinSet 'RegularString
-> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SetType inSet ctx -> ID' inSet pof ctx
TermSet (Set (ID' 'WithinSet 'InFact 'RegularString)
-> Set (ID' 'WithinSet 'InFact 'RegularString)
-> Set (ID' 'WithinSet 'InFact 'RegularString)
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set (ID' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t Set (ID' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t')
evalBinary Limits
_ Binary
Intersection ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_ = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
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') = ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ SetType 'NotWithinSet 'RegularString
-> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
SetType inSet ctx -> ID' inSet pof ctx
TermSet (Set (ID' 'WithinSet 'InFact 'RegularString)
-> Set (ID' 'WithinSet 'InFact 'RegularString)
-> Set (ID' 'WithinSet 'InFact 'RegularString)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (ID' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t Set (ID' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
t')
evalBinary Limits
_ Binary
Union ID' 'NotWithinSet 'InFact 'RegularString
_ ID' 'NotWithinSet 'InFact 'RegularString
_ = String -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b. a -> Either a b
Left String
"Only sets support `.union()`"

regexMatch :: Text -> Text -> Either String Value
regexMatch :: Text
-> Text -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
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
  ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> (Bool -> ID' 'NotWithinSet 'InFact 'RegularString)
-> Bool
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ID' 'NotWithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> ID' inSet pof ctx
LBool (Bool -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> Bool -> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
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 (ID' 'NotWithinSet 'InFact 'RegularString)
evaluateExpression Limits
l Bindings
b = \case
    EValue ID' 'NotWithinSet 'InPredicate 'RegularString
term -> Bindings
-> ID' 'NotWithinSet 'InPredicate 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
applyVariable Bindings
b ID' 'NotWithinSet 'InPredicate 'RegularString
term
    EUnary Unary
op Expression' 'RegularString
e' -> Unary
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
evalUnary Unary
op (ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Limits
-> Bindings
-> Expression' 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
evaluateExpression Limits
l Bindings
b Expression' 'RegularString
e'
    EBinary Binary
op Expression' 'RegularString
e' Expression' 'RegularString
e'' -> (ID' 'NotWithinSet 'InFact 'RegularString
 -> ID' 'NotWithinSet 'InFact 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> (ID' 'NotWithinSet 'InFact 'RegularString,
    ID' 'NotWithinSet 'InFact 'RegularString)
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Limits
-> Binary
-> ID' 'NotWithinSet 'InFact 'RegularString
-> ID' 'NotWithinSet 'InFact 'RegularString
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
evalBinary Limits
l Binary
op) ((ID' 'NotWithinSet 'InFact 'RegularString,
  ID' 'NotWithinSet 'InFact 'RegularString)
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> Either
     String
     (ID' 'NotWithinSet 'InFact 'RegularString,
      ID' 'NotWithinSet 'InFact 'RegularString)
-> Either String (ID' 'NotWithinSet 'InFact 'RegularString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Expression' 'RegularString
  -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
 -> (Expression' 'RegularString
     -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
 -> (Expression' 'RegularString, Expression' 'RegularString)
 -> Either
      String
      (ID' 'NotWithinSet 'InFact 'RegularString,
       ID' 'NotWithinSet 'InFact 'RegularString))
-> (Expression' 'RegularString
    -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> (Expression' 'RegularString, Expression' 'RegularString)
-> Either
     String
     (ID' 'NotWithinSet 'InFact 'RegularString,
      ID' 'NotWithinSet 'InFact 'RegularString)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Expression' 'RegularString
 -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> (Expression' 'RegularString
    -> Either String (ID' 'NotWithinSet 'InFact 'RegularString))
-> (Expression' 'RegularString, Expression' 'RegularString)
-> Either
     String
     (ID' 'NotWithinSet 'InFact 'RegularString,
      ID' 'NotWithinSet 'InFact 'RegularString)
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 (ID' 'NotWithinSet 'InFact 'RegularString)
evaluateExpression Limits
l Bindings
b) (Expression' 'RegularString
e', Expression' 'RegularString
e'')