{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveLift                 #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}
{-|
  Module      : Auth.Biscuit.Datalog.AST
  Copyright   : © Clément Delafargue, 2021
  License     : MIT
  Maintainer  : clement@delafargue.name
  The Datalog elements
-}
module Auth.Biscuit.Datalog.AST
  (
    Binary (..)
  , Block
  , Block' (..)
  , BlockElement' (..)
  , Check
  , Check'
  , Expression
  , Expression' (..)
  , Fact
  , ToTerm (..)
  , FromValue (..)
  , Term
  , Term' (..)
  , IsWithinSet (..)
  , Op (..)
  , ParsedAs (..)
  , Policy
  , Policy'
  , PolicyType (..)
  , Predicate
  , Predicate' (..)
  , PredicateOrFact (..)
  , QQTerm
  , Query
  , Query'
  , QueryItem' (..)
  , Rule
  , Rule' (..)
  , RuleScope (..)
  , SetType
  , Slice (..)
  , SliceType
  , Unary (..)
  , Value
  , VariableType
  , Authorizer
  , Authorizer' (..)
  , AuthorizerElement' (..)
  , elementToBlock
  , elementToAuthorizer
  , fromStack
  , listSymbolsInBlock
  , renderBlock
  , renderFact
  , renderRule
  , toSetTerm
  , toStack
  ) where

import           Control.Applicative        ((<|>))
import           Control.Monad              ((<=<))
import           Data.ByteString            (ByteString)
import           Data.ByteString.Base16     as Hex
import           Data.Foldable              (fold)
import           Data.Set                   (Set)
import qualified Data.Set                   as Set
import           Data.String                (IsString)
import           Data.Text                  (Text, intercalate, pack, unpack)
import           Data.Text.Encoding         (decodeUtf8)
import           Data.Time                  (UTCTime)
import           Data.Void                  (Void, absurd)
import           Instances.TH.Lift          ()
import           Language.Haskell.TH
import           Language.Haskell.TH.Syntax
import           Numeric.Natural            (Natural)

data IsWithinSet = NotWithinSet | WithinSet
data ParsedAs = RegularString | QuasiQuote
data PredicateOrFact = InPredicate | InFact

type family VariableType (inSet :: IsWithinSet) (pof :: PredicateOrFact) where
  VariableType 'NotWithinSet 'InPredicate = Text
  VariableType inSet          pof         = Void

newtype Slice = Slice String
  deriving newtype (Slice -> Slice -> Bool
(Slice -> Slice -> Bool) -> (Slice -> Slice -> Bool) -> Eq Slice
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Slice -> Slice -> Bool
$c/= :: Slice -> Slice -> Bool
== :: Slice -> Slice -> Bool
$c== :: Slice -> Slice -> Bool
Eq, Int -> Slice -> ShowS
[Slice] -> ShowS
Slice -> String
(Int -> Slice -> ShowS)
-> (Slice -> String) -> ([Slice] -> ShowS) -> Show Slice
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Slice] -> ShowS
$cshowList :: [Slice] -> ShowS
show :: Slice -> String
$cshow :: Slice -> String
showsPrec :: Int -> Slice -> ShowS
$cshowsPrec :: Int -> Slice -> ShowS
Show, Eq Slice
Eq Slice
-> (Slice -> Slice -> Ordering)
-> (Slice -> Slice -> Bool)
-> (Slice -> Slice -> Bool)
-> (Slice -> Slice -> Bool)
-> (Slice -> Slice -> Bool)
-> (Slice -> Slice -> Slice)
-> (Slice -> Slice -> Slice)
-> Ord Slice
Slice -> Slice -> Bool
Slice -> Slice -> Ordering
Slice -> Slice -> Slice
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Slice -> Slice -> Slice
$cmin :: Slice -> Slice -> Slice
max :: Slice -> Slice -> Slice
$cmax :: Slice -> Slice -> Slice
>= :: Slice -> Slice -> Bool
$c>= :: Slice -> Slice -> Bool
> :: Slice -> Slice -> Bool
$c> :: Slice -> Slice -> Bool
<= :: Slice -> Slice -> Bool
$c<= :: Slice -> Slice -> Bool
< :: Slice -> Slice -> Bool
$c< :: Slice -> Slice -> Bool
compare :: Slice -> Slice -> Ordering
$ccompare :: Slice -> Slice -> Ordering
$cp1Ord :: Eq Slice
Ord, String -> Slice
(String -> Slice) -> IsString Slice
forall a. (String -> a) -> IsString a
fromString :: String -> Slice
$cfromString :: String -> Slice
IsString)

instance Lift Slice where
  lift :: Slice -> Q Exp
lift (Slice String
name) = [| toTerm $(varE $ mkName name) |]
#if MIN_VERSION_template_haskell(2,17,0)
  liftTyped = liftCode . unsafeTExpCoerce . lift
#else
  liftTyped :: Slice -> Q (TExp Slice)
liftTyped = Q Exp -> Q (TExp Slice)
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp Slice))
-> (Slice -> Q Exp) -> Slice -> Q (TExp Slice)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Slice -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif

type family SliceType (ctx :: ParsedAs) where
  SliceType 'RegularString = Void
  SliceType 'QuasiQuote    = Slice

type family SetType (inSet :: IsWithinSet) (ctx :: ParsedAs) where
  SetType 'NotWithinSet ctx = Set (Term' 'WithinSet 'InFact ctx)
  SetType 'WithinSet    ctx = Void

-- | A single datalog item.
-- | This can be a value, a set of items, or a slice (a value that will be injected later),
-- | depending on the context
data Term' (inSet :: IsWithinSet) (pof :: PredicateOrFact) (ctx :: ParsedAs) =
    Variable (VariableType inSet pof)
  -- ^ A variable (eg. @$0@)
  | LInteger Int
  -- ^ An integer literal (eg. @42@)
  | LString Text
  -- ^ A string literal (eg. @"file1"@)
  | LDate UTCTime
  -- ^ A date literal (eg. @2021-05-26T18:00:00Z@)
  | LBytes ByteString
  -- ^ A hex literal (eg. @hex:ff9900@)
  | LBool Bool
  -- ^ A bool literal (eg. @true@)
  | Antiquote (SliceType ctx)
  -- ^ A slice (eg. @${name}@)
  | TermSet (SetType inSet ctx)
  -- ^ A set (eg. @[true, false]@)

deriving instance ( Eq (VariableType inSet pof)
                  , Eq (SliceType ctx)
                  , Eq (SetType inSet ctx)
                  ) => Eq (Term' inSet pof ctx)

deriving instance ( Ord (VariableType inSet pof)
                  , Ord (SliceType ctx)
                  , Ord (SetType inSet ctx)
                  ) => Ord (Term' inSet pof ctx)

deriving instance ( Show (VariableType inSet pof)
                  , Show (SliceType ctx)
                  , Show (SetType inSet ctx)
                  ) => Show (Term' inSet pof ctx)

-- | In a regular AST, slices have already been eliminated
type Term = Term' 'NotWithinSet 'InPredicate 'RegularString
-- | In an AST parsed from a QuasiQuoter, there might be references to haskell variables
type QQTerm = Term' 'NotWithinSet 'InPredicate 'QuasiQuote
-- | A term that is not a variable
type Value = Term' 'NotWithinSet 'InFact 'RegularString
-- | An element of a set
type SetValue = Term' 'WithinSet 'InFact 'RegularString

instance  ( Lift (VariableType inSet pof)
          , Lift (SetType inSet ctx)
          , Lift (SliceType ctx)
          )
         => Lift (Term' inSet pof ctx) where
  lift :: Term' inSet pof ctx -> Q Exp
lift (Variable VariableType inSet pof
n)    = [| Variable n |]
  lift (LInteger Int
i)    = [| LInteger i |]
  lift (LString Text
s)     = [| LString s |]
  lift (LBytes ByteString
bs)     = [| LBytes bs |]
  lift (LBool Bool
b)       = [| LBool  b |]
  lift (TermSet SetType inSet ctx
terms) = [| TermSet terms |]
  lift (LDate UTCTime
t)       = [| LDate (read $(lift $ show t)) |]
  lift (Antiquote SliceType ctx
s)   = [| s |]

#if MIN_VERSION_template_haskell(2,17,0)
  liftTyped = liftCode . unsafeTExpCoerce . lift
#else
  liftTyped :: Term' inSet pof ctx -> Q (TExp (Term' inSet pof ctx))
liftTyped = Q Exp -> Q (TExp (Term' inSet pof ctx))
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> Q (TExp (Term' inSet pof ctx)))
-> (Term' inSet pof ctx -> Q Exp)
-> Term' inSet pof ctx
-> Q (TExp (Term' inSet pof ctx))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term' inSet pof ctx -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif

-- | This class describes how to turn a haskell value into a datalog value.
-- | This is used when slicing a haskell variable in a datalog expression
class ToTerm t where
  -- | How to turn a value into a datalog item
  toTerm :: t -> Term' inSet pof 'RegularString

-- | This class describes how to turn a datalog value into a regular haskell value.
class FromValue t where
  fromValue :: Value -> Maybe t

instance ToTerm Int where
  toTerm :: Int -> Term' inSet pof 'RegularString
toTerm = Int -> Term' inSet pof 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger

instance FromValue Int where
  fromValue :: Value -> Maybe Int
fromValue (LInteger Int
v) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
v
  fromValue Value
_            = Maybe Int
forall a. Maybe a
Nothing

instance ToTerm Integer where
  toTerm :: Integer -> Term' inSet pof 'RegularString
toTerm = Int -> Term' inSet pof 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger (Int -> Term' inSet pof 'RegularString)
-> (Integer -> Int) -> Integer -> Term' inSet pof 'RegularString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance FromValue Integer where
  fromValue :: Value -> Maybe Integer
fromValue (LInteger Int
v) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)
  fromValue Value
_            = Maybe Integer
forall a. Maybe a
Nothing

instance ToTerm Text where
  toTerm :: Text -> Term' inSet pof 'RegularString
toTerm = Text -> Term' inSet pof 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Text -> Term' inSet pof ctx
LString

instance FromValue Text where
  fromValue :: Value -> Maybe Text
fromValue (LString Text
t) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
  fromValue Value
_           = Maybe Text
forall a. Maybe a
Nothing

instance ToTerm Bool where
  toTerm :: Bool -> Term' inSet pof 'RegularString
toTerm = Bool -> Term' inSet pof 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool

instance FromValue Bool where
  fromValue :: Value -> Maybe Bool
fromValue (LBool Bool
b) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b
  fromValue Value
_         = Maybe Bool
forall a. Maybe a
Nothing

instance ToTerm ByteString where
  toTerm :: ByteString -> Term' inSet pof 'RegularString
toTerm = ByteString -> Term' inSet pof 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
ByteString -> Term' inSet pof ctx
LBytes

instance FromValue ByteString where
  fromValue :: Value -> Maybe ByteString
fromValue (LBytes ByteString
bs) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs
  fromValue Value
_           = Maybe ByteString
forall a. Maybe a
Nothing

instance ToTerm UTCTime where
  toTerm :: UTCTime -> Term' inSet pof 'RegularString
toTerm = UTCTime -> Term' inSet pof 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
UTCTime -> Term' inSet pof ctx
LDate

instance FromValue UTCTime where
  fromValue :: Value -> Maybe UTCTime
fromValue (LDate UTCTime
t) = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
t
  fromValue Value
_         = Maybe UTCTime
forall a. Maybe a
Nothing

instance FromValue Value where
  fromValue :: Value -> Maybe Value
fromValue = Value -> Maybe Value
forall a. a -> Maybe a
Just

toSetTerm :: Value
          -> Maybe (Term' 'WithinSet 'InFact 'RegularString)
toSetTerm :: Value -> Maybe (Term' 'WithinSet 'InFact 'RegularString)
toSetTerm = \case
  LInteger Int
i  -> Term' 'WithinSet 'InFact 'RegularString
-> Maybe (Term' 'WithinSet 'InFact 'RegularString)
forall a. a -> Maybe a
Just (Term' 'WithinSet 'InFact 'RegularString
 -> Maybe (Term' 'WithinSet 'InFact 'RegularString))
-> Term' 'WithinSet 'InFact 'RegularString
-> Maybe (Term' 'WithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Int -> Term' 'WithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Int -> Term' inSet pof ctx
LInteger Int
i
  LString Text
i   -> Term' 'WithinSet 'InFact 'RegularString
-> Maybe (Term' 'WithinSet 'InFact 'RegularString)
forall a. a -> Maybe a
Just (Term' 'WithinSet 'InFact 'RegularString
 -> Maybe (Term' 'WithinSet 'InFact 'RegularString))
-> Term' 'WithinSet 'InFact 'RegularString
-> Maybe (Term' 'WithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Text -> Term' 'WithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Text -> Term' inSet pof ctx
LString Text
i
  LDate UTCTime
i     -> Term' 'WithinSet 'InFact 'RegularString
-> Maybe (Term' 'WithinSet 'InFact 'RegularString)
forall a. a -> Maybe a
Just (Term' 'WithinSet 'InFact 'RegularString
 -> Maybe (Term' 'WithinSet 'InFact 'RegularString))
-> Term' 'WithinSet 'InFact 'RegularString
-> Maybe (Term' 'WithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ UTCTime -> Term' 'WithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
UTCTime -> Term' inSet pof ctx
LDate UTCTime
i
  LBytes ByteString
i    -> Term' 'WithinSet 'InFact 'RegularString
-> Maybe (Term' 'WithinSet 'InFact 'RegularString)
forall a. a -> Maybe a
Just (Term' 'WithinSet 'InFact 'RegularString
 -> Maybe (Term' 'WithinSet 'InFact 'RegularString))
-> Term' 'WithinSet 'InFact 'RegularString
-> Maybe (Term' 'WithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Term' 'WithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
ByteString -> Term' inSet pof ctx
LBytes ByteString
i
  LBool Bool
i     -> Term' 'WithinSet 'InFact 'RegularString
-> Maybe (Term' 'WithinSet 'InFact 'RegularString)
forall a. a -> Maybe a
Just (Term' 'WithinSet 'InFact 'RegularString
 -> Maybe (Term' 'WithinSet 'InFact 'RegularString))
-> Term' 'WithinSet 'InFact 'RegularString
-> Maybe (Term' 'WithinSet 'InFact 'RegularString)
forall a b. (a -> b) -> a -> b
$ Bool -> Term' 'WithinSet 'InFact 'RegularString
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
Bool -> Term' inSet pof ctx
LBool Bool
i
  TermSet SetType 'NotWithinSet 'RegularString
_   -> Maybe (Term' 'WithinSet 'InFact 'RegularString)
forall a. Maybe a
Nothing
  Variable VariableType 'NotWithinSet 'InFact
v  -> Void -> Maybe (Term' 'WithinSet 'InFact 'RegularString)
forall a. Void -> a
absurd Void
VariableType 'NotWithinSet 'InFact
v
  Antiquote SliceType 'RegularString
v -> Void -> Maybe (Term' 'WithinSet 'InFact 'RegularString)
forall a. Void -> a
absurd Void
SliceType 'RegularString
v

renderId' :: (VariableType inSet pof -> Text)
          -> (SetType inSet ctx -> Text)
          -> (SliceType ctx -> Text)
          -> Term' inSet pof ctx -> Text
renderId' :: (VariableType inSet pof -> Text)
-> (SetType inSet ctx -> Text)
-> (SliceType ctx -> Text)
-> Term' inSet pof ctx
-> Text
renderId' VariableType inSet pof -> Text
var SetType inSet ctx -> Text
set SliceType ctx -> Text
slice = \case
  Variable VariableType inSet pof
name -> VariableType inSet pof -> Text
var VariableType inSet pof
name
  LInteger Int
int  -> String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
int
  LString Text
str   -> String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
str
  LDate UTCTime
time    -> String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
time
  LBytes ByteString
bs     -> Text
"hex:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8 (ByteString -> ByteString
Hex.encode ByteString
bs)
  LBool Bool
True    -> Text
"true"
  LBool Bool
False   -> Text
"false"
  TermSet SetType inSet ctx
terms -> SetType inSet ctx -> Text
set SetType inSet ctx
terms -- "[" <> intercalate "," (renderInnerId <$> Set.toList terms) <> "]"
  Antiquote SliceType ctx
v   -> SliceType ctx -> Text
slice SliceType ctx
v

renderSet :: (SliceType ctx -> Text)
          -> Set (Term' 'WithinSet 'InFact ctx)
          -> Text
renderSet :: (SliceType ctx -> Text)
-> Set (Term' 'WithinSet 'InFact ctx) -> Text
renderSet SliceType ctx -> Text
slice Set (Term' 'WithinSet 'InFact ctx)
terms =
  Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
"," ((VariableType 'WithinSet 'InFact -> Text)
-> (SetType 'WithinSet ctx -> Text)
-> (SliceType ctx -> Text)
-> Term' 'WithinSet 'InFact ctx
-> Text
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
(VariableType inSet pof -> Text)
-> (SetType inSet ctx -> Text)
-> (SliceType ctx -> Text)
-> Term' inSet pof ctx
-> Text
renderId' VariableType 'WithinSet 'InFact -> Text
forall a. Void -> a
absurd SetType 'WithinSet ctx -> Text
forall a. Void -> a
absurd SliceType ctx -> Text
slice (Term' 'WithinSet 'InFact ctx -> Text)
-> [Term' 'WithinSet 'InFact ctx] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set (Term' 'WithinSet 'InFact ctx)
-> [Term' 'WithinSet 'InFact ctx]
forall a. Set a -> [a]
Set.toList Set (Term' 'WithinSet 'InFact ctx)
terms) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"

renderId :: Term -> Text
renderId :: Term -> Text
renderId = (VariableType 'NotWithinSet 'InPredicate -> Text)
-> (SetType 'NotWithinSet 'RegularString -> Text)
-> (SliceType 'RegularString -> Text)
-> Term
-> Text
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
(VariableType inSet pof -> Text)
-> (SetType inSet ctx -> Text)
-> (SliceType ctx -> Text)
-> Term' inSet pof ctx
-> Text
renderId' (Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ((SliceType 'RegularString -> Text)
-> Set (Term' 'WithinSet 'InFact 'RegularString) -> Text
forall (ctx :: ParsedAs).
(SliceType ctx -> Text)
-> Set (Term' 'WithinSet 'InFact ctx) -> Text
renderSet SliceType 'RegularString -> Text
forall a. Void -> a
absurd) SliceType 'RegularString -> Text
forall a. Void -> a
absurd

renderFactId :: Term' 'NotWithinSet 'InFact 'RegularString -> Text
renderFactId :: Value -> Text
renderFactId = (VariableType 'NotWithinSet 'InFact -> Text)
-> (SetType 'NotWithinSet 'RegularString -> Text)
-> (SliceType 'RegularString -> Text)
-> Value
-> Text
forall (inSet :: IsWithinSet) (pof :: PredicateOrFact)
       (ctx :: ParsedAs).
(VariableType inSet pof -> Text)
-> (SetType inSet ctx -> Text)
-> (SliceType ctx -> Text)
-> Term' inSet pof ctx
-> Text
renderId' VariableType 'NotWithinSet 'InFact -> Text
forall a. Void -> a
absurd ((SliceType 'RegularString -> Text)
-> Set (Term' 'WithinSet 'InFact 'RegularString) -> Text
forall (ctx :: ParsedAs).
(SliceType ctx -> Text)
-> Set (Term' 'WithinSet 'InFact ctx) -> Text
renderSet SliceType 'RegularString -> Text
forall a. Void -> a
absurd) SliceType 'RegularString -> Text
forall a. Void -> a
absurd

listSymbolsInTerm :: Term -> Set.Set Text
listSymbolsInTerm :: Term -> Set Text
listSymbolsInTerm = \case
  LString  Text
v    -> Text -> Set Text
forall a. a -> Set a
Set.singleton Text
v
  Variable VariableType 'NotWithinSet 'InPredicate
name -> Text -> Set Text
forall a. a -> Set a
Set.singleton Text
VariableType 'NotWithinSet 'InPredicate
name
  TermSet SetType 'NotWithinSet 'RegularString
terms -> (Term' 'WithinSet 'InFact 'RegularString -> Set Text)
-> Set (Term' 'WithinSet 'InFact 'RegularString) -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Term' 'WithinSet 'InFact 'RegularString -> Set Text
listSymbolsInSetValue Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
terms
  Antiquote SliceType 'RegularString
v   -> Void -> Set Text
forall a. Void -> a
absurd Void
SliceType 'RegularString
v
  Term
_             -> Set Text
forall a. Monoid a => a
mempty

listSymbolsInValue :: Value -> Set.Set Text
listSymbolsInValue :: Value -> Set Text
listSymbolsInValue = \case
  LString  Text
v    -> Text -> Set Text
forall a. a -> Set a
Set.singleton Text
v
  TermSet SetType 'NotWithinSet 'RegularString
terms -> (Term' 'WithinSet 'InFact 'RegularString -> Set Text)
-> Set (Term' 'WithinSet 'InFact 'RegularString) -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Term' 'WithinSet 'InFact 'RegularString -> Set Text
listSymbolsInSetValue Set (Term' 'WithinSet 'InFact 'RegularString)
SetType 'NotWithinSet 'RegularString
terms
  Variable  VariableType 'NotWithinSet 'InFact
v   -> Void -> Set Text
forall a. Void -> a
absurd Void
VariableType 'NotWithinSet 'InFact
v
  Antiquote SliceType 'RegularString
v   -> Void -> Set Text
forall a. Void -> a
absurd Void
SliceType 'RegularString
v
  Value
_             -> Set Text
forall a. Monoid a => a
mempty

listSymbolsInSetValue :: SetValue -> Set.Set Text
listSymbolsInSetValue :: Term' 'WithinSet 'InFact 'RegularString -> Set Text
listSymbolsInSetValue = \case
  LString  Text
v  -> Text -> Set Text
forall a. a -> Set a
Set.singleton Text
v
  TermSet   SetType 'WithinSet 'RegularString
v -> Void -> Set Text
forall a. Void -> a
absurd Void
SetType 'WithinSet 'RegularString
v
  Variable  VariableType 'WithinSet 'InFact
v -> Void -> Set Text
forall a. Void -> a
absurd Void
VariableType 'WithinSet 'InFact
v
  Antiquote SliceType 'RegularString
v -> Void -> Set Text
forall a. Void -> a
absurd Void
SliceType 'RegularString
v
  Term' 'WithinSet 'InFact 'RegularString
_           -> Set Text
forall a. Monoid a => a
mempty

data Predicate' (pof :: PredicateOrFact) (ctx :: ParsedAs) = Predicate
  { Predicate' pof ctx -> Text
name  :: Text
  , Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms :: [Term' 'NotWithinSet pof ctx]
  }

deriving instance ( Eq (Term' 'NotWithinSet pof ctx)
                  ) => Eq (Predicate' pof ctx)
deriving instance ( Ord (Term' 'NotWithinSet pof ctx)
                  ) => Ord (Predicate' pof ctx)
deriving instance ( Show (Term' 'NotWithinSet pof ctx)
                  ) => Show (Predicate' pof ctx)

deriving instance Lift (Term' 'NotWithinSet pof ctx) => Lift (Predicate' pof ctx)

type Predicate = Predicate' 'InPredicate 'RegularString
type Fact = Predicate' 'InFact 'RegularString

renderPredicate :: Predicate -> Text
renderPredicate :: Predicate -> Text
renderPredicate Predicate{Text
name :: Text
name :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> Text
name,[Term]
terms :: [Term]
terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms} =
  Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
", " ((Term -> Text) -> [Term] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Text
renderId [Term]
terms) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

renderFact :: Fact -> Text
renderFact :: Fact -> Text
renderFact Predicate{Text
name :: Text
name :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> Text
name,[Value]
terms :: [Value]
terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
terms} =
  Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
", " ((Value -> Text) -> [Value] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Text
renderFactId [Value]
terms) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

listSymbolsInFact :: Fact -> Set.Set Text
listSymbolsInFact :: Fact -> Set Text
listSymbolsInFact Predicate{[Value]
Text
terms :: [Value]
name :: Text
terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
name :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> Text
..} =
     Text -> Set Text
forall a. a -> Set a
Set.singleton Text
name
  Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> (Value -> Set Text) -> [Value] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Value -> Set Text
listSymbolsInValue [Value]
terms

listSymbolsInPredicate :: Predicate -> Set.Set Text
listSymbolsInPredicate :: Predicate -> Set Text
listSymbolsInPredicate Predicate{[Term]
Text
terms :: [Term]
name :: Text
terms :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> [Term' 'NotWithinSet pof ctx]
name :: forall (pof :: PredicateOrFact) (ctx :: ParsedAs).
Predicate' pof ctx -> Text
..} =
     Text -> Set Text
forall a. a -> Set a
Set.singleton Text
name
  Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> (Term -> Set Text) -> [Term] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Term -> Set Text
listSymbolsInTerm [Term]
terms

data QueryItem' ctx = QueryItem
  { QueryItem' ctx -> [Predicate' 'InPredicate ctx]
qBody        :: [Predicate' 'InPredicate ctx]
  , QueryItem' ctx -> [Expression' ctx]
qExpressions :: [Expression' ctx]
  , QueryItem' ctx -> Maybe RuleScope
qScope       :: Maybe RuleScope
  }

type Query' ctx = [QueryItem' ctx]
type Query = Query' 'RegularString

type Check' ctx = Query' ctx
type Check = Query
data PolicyType = Allow | Deny
  deriving (PolicyType -> PolicyType -> Bool
(PolicyType -> PolicyType -> Bool)
-> (PolicyType -> PolicyType -> Bool) -> Eq PolicyType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PolicyType -> PolicyType -> Bool
$c/= :: PolicyType -> PolicyType -> Bool
== :: PolicyType -> PolicyType -> Bool
$c== :: PolicyType -> PolicyType -> Bool
Eq, Int -> PolicyType -> ShowS
[PolicyType] -> ShowS
PolicyType -> String
(Int -> PolicyType -> ShowS)
-> (PolicyType -> String)
-> ([PolicyType] -> ShowS)
-> Show PolicyType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PolicyType] -> ShowS
$cshowList :: [PolicyType] -> ShowS
show :: PolicyType -> String
$cshow :: PolicyType -> String
showsPrec :: Int -> PolicyType -> ShowS
$cshowsPrec :: Int -> PolicyType -> ShowS
Show, Eq PolicyType
Eq PolicyType
-> (PolicyType -> PolicyType -> Ordering)
-> (PolicyType -> PolicyType -> Bool)
-> (PolicyType -> PolicyType -> Bool)
-> (PolicyType -> PolicyType -> Bool)
-> (PolicyType -> PolicyType -> Bool)
-> (PolicyType -> PolicyType -> PolicyType)
-> (PolicyType -> PolicyType -> PolicyType)
-> Ord PolicyType
PolicyType -> PolicyType -> Bool
PolicyType -> PolicyType -> Ordering
PolicyType -> PolicyType -> PolicyType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PolicyType -> PolicyType -> PolicyType
$cmin :: PolicyType -> PolicyType -> PolicyType
max :: PolicyType -> PolicyType -> PolicyType
$cmax :: PolicyType -> PolicyType -> PolicyType
>= :: PolicyType -> PolicyType -> Bool
$c>= :: PolicyType -> PolicyType -> Bool
> :: PolicyType -> PolicyType -> Bool
$c> :: PolicyType -> PolicyType -> Bool
<= :: PolicyType -> PolicyType -> Bool
$c<= :: PolicyType -> PolicyType -> Bool
< :: PolicyType -> PolicyType -> Bool
$c< :: PolicyType -> PolicyType -> Bool
compare :: PolicyType -> PolicyType -> Ordering
$ccompare :: PolicyType -> PolicyType -> Ordering
$cp1Ord :: Eq PolicyType
Ord, PolicyType -> Q Exp
PolicyType -> Q (TExp PolicyType)
(PolicyType -> Q Exp)
-> (PolicyType -> Q (TExp PolicyType)) -> Lift PolicyType
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: PolicyType -> Q (TExp PolicyType)
$cliftTyped :: PolicyType -> Q (TExp PolicyType)
lift :: PolicyType -> Q Exp
$clift :: PolicyType -> Q Exp
Lift)
type Policy' ctx = (PolicyType, Query' ctx)
type Policy = (PolicyType, Query)

deriving instance ( Eq (Predicate' 'InPredicate ctx)
                  , Eq (Expression' ctx)
                  ) => Eq (QueryItem' ctx)
deriving instance ( Ord (Predicate' 'InPredicate ctx)
                  , Ord (Expression' ctx)
                  ) => Ord (QueryItem' ctx)
deriving instance ( Show (Predicate' 'InPredicate ctx)
                  , Show (Expression' ctx)
                  ) => Show (QueryItem' ctx)

deriving instance (Lift (Predicate' 'InPredicate ctx), Lift (Expression' ctx)) => Lift (QueryItem' ctx)

renderQueryItem :: QueryItem' 'RegularString -> Text
renderQueryItem :: QueryItem' 'RegularString -> Text
renderQueryItem QueryItem{[Expression' 'RegularString]
[Predicate]
Maybe RuleScope
qScope :: Maybe RuleScope
qExpressions :: [Expression' 'RegularString]
qBody :: [Predicate]
qScope :: forall (ctx :: ParsedAs). QueryItem' ctx -> Maybe RuleScope
qExpressions :: forall (ctx :: ParsedAs). QueryItem' ctx -> [Expression' ctx]
qBody :: forall (ctx :: ParsedAs).
QueryItem' ctx -> [Predicate' 'InPredicate ctx]
..} =
  Text -> [Text] -> Text
intercalate Text
",\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ Predicate -> Text
renderPredicate (Predicate -> Text) -> [Predicate] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Predicate]
qBody
    , Expression' 'RegularString -> Text
renderExpression (Expression' 'RegularString -> Text)
-> [Expression' 'RegularString] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expression' 'RegularString]
qExpressions
    ]

renderCheck :: Check -> Text
renderCheck :: Check -> Text
renderCheck Check
is = Text
"check if " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
  Text -> [Text] -> Text
intercalate Text
"\n or " (QueryItem' 'RegularString -> Text
renderQueryItem (QueryItem' 'RegularString -> Text) -> Check -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Check
is)

listSymbolsInQueryItem :: QueryItem' 'RegularString -> Set.Set Text
listSymbolsInQueryItem :: QueryItem' 'RegularString -> Set Text
listSymbolsInQueryItem QueryItem{[Expression' 'RegularString]
[Predicate]
Maybe RuleScope
qScope :: Maybe RuleScope
qExpressions :: [Expression' 'RegularString]
qBody :: [Predicate]
qScope :: forall (ctx :: ParsedAs). QueryItem' ctx -> Maybe RuleScope
qExpressions :: forall (ctx :: ParsedAs). QueryItem' ctx -> [Expression' ctx]
qBody :: forall (ctx :: ParsedAs).
QueryItem' ctx -> [Predicate' 'InPredicate ctx]
..} =
     Text -> Set Text
forall a. a -> Set a
Set.singleton Text
"query" -- query items are serialized as `Rule`s
                           -- so an empty rule head is added: `query()`
                           -- It means that query items implicitly depend on
                           -- the `query` symbol being defined.
  Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> (Predicate -> Set Text) -> [Predicate] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Predicate -> Set Text
listSymbolsInPredicate [Predicate]
qBody
  Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> (Expression' 'RegularString -> Set Text)
-> [Expression' 'RegularString] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Expression' 'RegularString -> Set Text
listSymbolsInExpression [Expression' 'RegularString]
qExpressions

listSymbolsInCheck :: Check -> Set.Set Text
listSymbolsInCheck :: Check -> Set Text
listSymbolsInCheck =
  (QueryItem' 'RegularString -> Set Text) -> Check -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap QueryItem' 'RegularString -> Set Text
listSymbolsInQueryItem

data RuleScope  =
    OnlyAuthority
  | Previous
  | UnsafeAny
  | OnlyBlocks (Set Natural)
  deriving (RuleScope -> RuleScope -> Bool
(RuleScope -> RuleScope -> Bool)
-> (RuleScope -> RuleScope -> Bool) -> Eq RuleScope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RuleScope -> RuleScope -> Bool
$c/= :: RuleScope -> RuleScope -> Bool
== :: RuleScope -> RuleScope -> Bool
$c== :: RuleScope -> RuleScope -> Bool
Eq, Eq RuleScope
Eq RuleScope
-> (RuleScope -> RuleScope -> Ordering)
-> (RuleScope -> RuleScope -> Bool)
-> (RuleScope -> RuleScope -> Bool)
-> (RuleScope -> RuleScope -> Bool)
-> (RuleScope -> RuleScope -> Bool)
-> (RuleScope -> RuleScope -> RuleScope)
-> (RuleScope -> RuleScope -> RuleScope)
-> Ord RuleScope
RuleScope -> RuleScope -> Bool
RuleScope -> RuleScope -> Ordering
RuleScope -> RuleScope -> RuleScope
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RuleScope -> RuleScope -> RuleScope
$cmin :: RuleScope -> RuleScope -> RuleScope
max :: RuleScope -> RuleScope -> RuleScope
$cmax :: RuleScope -> RuleScope -> RuleScope
>= :: RuleScope -> RuleScope -> Bool
$c>= :: RuleScope -> RuleScope -> Bool
> :: RuleScope -> RuleScope -> Bool
$c> :: RuleScope -> RuleScope -> Bool
<= :: RuleScope -> RuleScope -> Bool
$c<= :: RuleScope -> RuleScope -> Bool
< :: RuleScope -> RuleScope -> Bool
$c< :: RuleScope -> RuleScope -> Bool
compare :: RuleScope -> RuleScope -> Ordering
$ccompare :: RuleScope -> RuleScope -> Ordering
$cp1Ord :: Eq RuleScope
Ord, Int -> RuleScope -> ShowS
[RuleScope] -> ShowS
RuleScope -> String
(Int -> RuleScope -> ShowS)
-> (RuleScope -> String)
-> ([RuleScope] -> ShowS)
-> Show RuleScope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RuleScope] -> ShowS
$cshowList :: [RuleScope] -> ShowS
show :: RuleScope -> String
$cshow :: RuleScope -> String
showsPrec :: Int -> RuleScope -> ShowS
$cshowsPrec :: Int -> RuleScope -> ShowS
Show, RuleScope -> Q Exp
RuleScope -> Q (TExp RuleScope)
(RuleScope -> Q Exp)
-> (RuleScope -> Q (TExp RuleScope)) -> Lift RuleScope
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: RuleScope -> Q (TExp RuleScope)
$cliftTyped :: RuleScope -> Q (TExp RuleScope)
lift :: RuleScope -> Q Exp
$clift :: RuleScope -> Q Exp
Lift)

data Rule' ctx = Rule
  { Rule' ctx -> Predicate' 'InPredicate ctx
rhead       :: Predicate' 'InPredicate ctx
  , Rule' ctx -> [Predicate' 'InPredicate ctx]
body        :: [Predicate' 'InPredicate ctx]
  , Rule' ctx -> [Expression' ctx]
expressions :: [Expression' ctx]
  , Rule' ctx -> Maybe RuleScope
scope       :: Maybe RuleScope
  }

deriving instance ( Eq (Predicate' 'InPredicate ctx)
                  , Eq (Expression' ctx)
                  ) => Eq (Rule' ctx)
deriving instance ( Ord (Predicate' 'InPredicate ctx)
                  , Ord (Expression' ctx)
                  ) => Ord (Rule' ctx)
deriving instance ( Show (Predicate' 'InPredicate ctx)
                  , Show (Expression' ctx)
                  ) => Show (Rule' ctx)

type Rule = Rule' 'RegularString

deriving instance (Lift (Predicate' 'InPredicate ctx), Lift (Expression' ctx)) => Lift (Rule' ctx)

renderRule :: Rule' 'RegularString -> Text
renderRule :: Rule' 'RegularString -> Text
renderRule Rule{Predicate
rhead :: Predicate
rhead :: forall (ctx :: ParsedAs). Rule' ctx -> Predicate' 'InPredicate ctx
rhead,[Predicate]
body :: [Predicate]
body :: forall (ctx :: ParsedAs).
Rule' ctx -> [Predicate' 'InPredicate ctx]
body,[Expression' 'RegularString]
expressions :: [Expression' 'RegularString]
expressions :: forall (ctx :: ParsedAs). Rule' ctx -> [Expression' ctx]
expressions} =
  Predicate -> Text
renderPredicate Predicate
rhead Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
", " ((Predicate -> Text) -> [Predicate] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Predicate -> Text
renderPredicate [Predicate]
body [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Expression' 'RegularString -> Text)
-> [Expression' 'RegularString] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expression' 'RegularString -> Text
renderExpression [Expression' 'RegularString]
expressions)

listSymbolsInRule :: Rule -> Set.Set Text
listSymbolsInRule :: Rule' 'RegularString -> Set Text
listSymbolsInRule Rule{[Expression' 'RegularString]
[Predicate]
Maybe RuleScope
Predicate
scope :: Maybe RuleScope
expressions :: [Expression' 'RegularString]
body :: [Predicate]
rhead :: Predicate
scope :: forall (ctx :: ParsedAs). Rule' ctx -> Maybe RuleScope
expressions :: forall (ctx :: ParsedAs). Rule' ctx -> [Expression' ctx]
body :: forall (ctx :: ParsedAs).
Rule' ctx -> [Predicate' 'InPredicate ctx]
rhead :: forall (ctx :: ParsedAs). Rule' ctx -> Predicate' 'InPredicate ctx
..} =
     Predicate -> Set Text
listSymbolsInPredicate Predicate
rhead
  Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> (Predicate -> Set Text) -> [Predicate] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Predicate -> Set Text
listSymbolsInPredicate [Predicate]
body
  Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> (Expression' 'RegularString -> Set Text)
-> [Expression' 'RegularString] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Expression' 'RegularString -> Set Text
listSymbolsInExpression [Expression' 'RegularString]
expressions

data Unary =
    Negate
  | Parens
  | Length
  deriving (Unary -> Unary -> Bool
(Unary -> Unary -> Bool) -> (Unary -> Unary -> Bool) -> Eq Unary
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Unary -> Unary -> Bool
$c/= :: Unary -> Unary -> Bool
== :: Unary -> Unary -> Bool
$c== :: Unary -> Unary -> Bool
Eq, Eq Unary
Eq Unary
-> (Unary -> Unary -> Ordering)
-> (Unary -> Unary -> Bool)
-> (Unary -> Unary -> Bool)
-> (Unary -> Unary -> Bool)
-> (Unary -> Unary -> Bool)
-> (Unary -> Unary -> Unary)
-> (Unary -> Unary -> Unary)
-> Ord Unary
Unary -> Unary -> Bool
Unary -> Unary -> Ordering
Unary -> Unary -> Unary
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Unary -> Unary -> Unary
$cmin :: Unary -> Unary -> Unary
max :: Unary -> Unary -> Unary
$cmax :: Unary -> Unary -> Unary
>= :: Unary -> Unary -> Bool
$c>= :: Unary -> Unary -> Bool
> :: Unary -> Unary -> Bool
$c> :: Unary -> Unary -> Bool
<= :: Unary -> Unary -> Bool
$c<= :: Unary -> Unary -> Bool
< :: Unary -> Unary -> Bool
$c< :: Unary -> Unary -> Bool
compare :: Unary -> Unary -> Ordering
$ccompare :: Unary -> Unary -> Ordering
$cp1Ord :: Eq Unary
Ord, Int -> Unary -> ShowS
[Unary] -> ShowS
Unary -> String
(Int -> Unary -> ShowS)
-> (Unary -> String) -> ([Unary] -> ShowS) -> Show Unary
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Unary] -> ShowS
$cshowList :: [Unary] -> ShowS
show :: Unary -> String
$cshow :: Unary -> String
showsPrec :: Int -> Unary -> ShowS
$cshowsPrec :: Int -> Unary -> ShowS
Show, Unary -> Q Exp
Unary -> Q (TExp Unary)
(Unary -> Q Exp) -> (Unary -> Q (TExp Unary)) -> Lift Unary
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Unary -> Q (TExp Unary)
$cliftTyped :: Unary -> Q (TExp Unary)
lift :: Unary -> Q Exp
$clift :: Unary -> Q Exp
Lift)

data Binary =
    LessThan
  | GreaterThan
  | LessOrEqual
  | GreaterOrEqual
  | Equal
  | Contains
  | Prefix
  | Suffix
  | Regex
  | Add
  | Sub
  | Mul
  | Div
  | And
  | Or
  | Intersection
  | Union
  deriving (Binary -> Binary -> Bool
(Binary -> Binary -> Bool)
-> (Binary -> Binary -> Bool) -> Eq Binary
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Binary -> Binary -> Bool
$c/= :: Binary -> Binary -> Bool
== :: Binary -> Binary -> Bool
$c== :: Binary -> Binary -> Bool
Eq, Eq Binary
Eq Binary
-> (Binary -> Binary -> Ordering)
-> (Binary -> Binary -> Bool)
-> (Binary -> Binary -> Bool)
-> (Binary -> Binary -> Bool)
-> (Binary -> Binary -> Bool)
-> (Binary -> Binary -> Binary)
-> (Binary -> Binary -> Binary)
-> Ord Binary
Binary -> Binary -> Bool
Binary -> Binary -> Ordering
Binary -> Binary -> Binary
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Binary -> Binary -> Binary
$cmin :: Binary -> Binary -> Binary
max :: Binary -> Binary -> Binary
$cmax :: Binary -> Binary -> Binary
>= :: Binary -> Binary -> Bool
$c>= :: Binary -> Binary -> Bool
> :: Binary -> Binary -> Bool
$c> :: Binary -> Binary -> Bool
<= :: Binary -> Binary -> Bool
$c<= :: Binary -> Binary -> Bool
< :: Binary -> Binary -> Bool
$c< :: Binary -> Binary -> Bool
compare :: Binary -> Binary -> Ordering
$ccompare :: Binary -> Binary -> Ordering
$cp1Ord :: Eq Binary
Ord, Int -> Binary -> ShowS
[Binary] -> ShowS
Binary -> String
(Int -> Binary -> ShowS)
-> (Binary -> String) -> ([Binary] -> ShowS) -> Show Binary
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Binary] -> ShowS
$cshowList :: [Binary] -> ShowS
show :: Binary -> String
$cshow :: Binary -> String
showsPrec :: Int -> Binary -> ShowS
$cshowsPrec :: Int -> Binary -> ShowS
Show, Binary -> Q Exp
Binary -> Q (TExp Binary)
(Binary -> Q Exp) -> (Binary -> Q (TExp Binary)) -> Lift Binary
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Binary -> Q (TExp Binary)
$cliftTyped :: Binary -> Q (TExp Binary)
lift :: Binary -> Q Exp
$clift :: Binary -> Q Exp
Lift)

data Expression' (ctx :: ParsedAs) =
    EValue (Term' 'NotWithinSet 'InPredicate ctx)
  | EUnary Unary (Expression' ctx)
  | EBinary Binary (Expression' ctx) (Expression' ctx)

deriving instance Eq   (Term' 'NotWithinSet 'InPredicate ctx) => Eq (Expression' ctx)
deriving instance Ord  (Term' 'NotWithinSet 'InPredicate ctx) => Ord (Expression' ctx)
deriving instance Lift (Term' 'NotWithinSet 'InPredicate ctx) => Lift (Expression' ctx)
deriving instance Show (Term' 'NotWithinSet 'InPredicate ctx) => Show (Expression' ctx)

type Expression = Expression' 'RegularString

listSymbolsInExpression :: Expression -> Set.Set Text
listSymbolsInExpression :: Expression' 'RegularString -> Set Text
listSymbolsInExpression = \case
  EValue Term
t       -> Term -> Set Text
listSymbolsInTerm Term
t
  EUnary Unary
_ Expression' 'RegularString
e     -> Expression' 'RegularString -> Set Text
listSymbolsInExpression Expression' 'RegularString
e
  EBinary Binary
_ Expression' 'RegularString
e Expression' 'RegularString
e' -> (Expression' 'RegularString -> Set Text)
-> [Expression' 'RegularString] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Expression' 'RegularString -> Set Text
listSymbolsInExpression [Expression' 'RegularString
e, Expression' 'RegularString
e']

data Op =
    VOp Term
  | UOp Unary
  | BOp Binary

fromStack :: [Op] -> Either String Expression
fromStack :: [Op] -> Either String (Expression' 'RegularString)
fromStack =
  let go :: [Expression' 'RegularString]
-> [Op] -> Either a [Expression' 'RegularString]
go [Expression' 'RegularString]
stack []                    = [Expression' 'RegularString]
-> Either a [Expression' 'RegularString]
forall a b. b -> Either a b
Right [Expression' 'RegularString]
stack
      go [Expression' 'RegularString]
stack        (VOp Term
t : [Op]
rest) = [Expression' 'RegularString]
-> [Op] -> Either a [Expression' 'RegularString]
go (Term -> Expression' 'RegularString
forall (ctx :: ParsedAs).
Term' 'NotWithinSet 'InPredicate ctx -> Expression' ctx
EValue Term
t Expression' 'RegularString
-> [Expression' 'RegularString] -> [Expression' 'RegularString]
forall a. a -> [a] -> [a]
: [Expression' 'RegularString]
stack) [Op]
rest
      go (Expression' 'RegularString
e:[Expression' 'RegularString]
stack)    (UOp Unary
o : [Op]
rest) = [Expression' 'RegularString]
-> [Op] -> Either a [Expression' 'RegularString]
go (Unary -> Expression' 'RegularString -> Expression' 'RegularString
forall (ctx :: ParsedAs).
Unary -> Expression' ctx -> Expression' ctx
EUnary Unary
o Expression' 'RegularString
e Expression' 'RegularString
-> [Expression' 'RegularString] -> [Expression' 'RegularString]
forall a. a -> [a] -> [a]
: [Expression' 'RegularString]
stack) [Op]
rest
      go []           (UOp Unary
_ : [Op]
_)    = a -> Either a [Expression' 'RegularString]
forall a b. a -> Either a b
Left a
"Empty stack on unary op"
      go (Expression' 'RegularString
e:Expression' 'RegularString
e':[Expression' 'RegularString]
stack) (BOp Binary
o : [Op]
rest) = [Expression' 'RegularString]
-> [Op] -> Either a [Expression' 'RegularString]
go (Binary
-> Expression' 'RegularString
-> Expression' 'RegularString
-> Expression' 'RegularString
forall (ctx :: ParsedAs).
Binary -> Expression' ctx -> Expression' ctx -> Expression' ctx
EBinary Binary
o Expression' 'RegularString
e' Expression' 'RegularString
e Expression' 'RegularString
-> [Expression' 'RegularString] -> [Expression' 'RegularString]
forall a. a -> [a] -> [a]
: [Expression' 'RegularString]
stack) [Op]
rest
      go [Expression' 'RegularString
_]          (BOp Binary
_ : [Op]
_)    = a -> Either a [Expression' 'RegularString]
forall a b. a -> Either a b
Left a
"Unary stack on binary op"
      go []           (BOp Binary
_ : [Op]
_)    = a -> Either a [Expression' 'RegularString]
forall a b. a -> Either a b
Left a
"Empty stack on binary op"
      final :: [b] -> Either a b
final []  = a -> Either a b
forall a b. a -> Either a b
Left a
"Empty stack"
      final [b
x] = b -> Either a b
forall a b. b -> Either a b
Right b
x
      final [b]
_   = a -> Either a b
forall a b. a -> Either a b
Left a
"Stack containing more than one element"
   in [Expression' 'RegularString]
-> Either String (Expression' 'RegularString)
forall a b. IsString a => [b] -> Either a b
final ([Expression' 'RegularString]
 -> Either String (Expression' 'RegularString))
-> ([Op] -> Either String [Expression' 'RegularString])
-> [Op]
-> Either String (Expression' 'RegularString)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Expression' 'RegularString]
-> [Op] -> Either String [Expression' 'RegularString]
forall a.
IsString a =>
[Expression' 'RegularString]
-> [Op] -> Either a [Expression' 'RegularString]
go []

toStack :: Expression -> [Op]
toStack :: Expression' 'RegularString -> [Op]
toStack Expression' 'RegularString
expr =
  let go :: Expression' 'RegularString -> [Op] -> [Op]
go Expression' 'RegularString
e [Op]
s = case Expression' 'RegularString
e of
        EValue Term
t      -> Term -> Op
VOp Term
t Op -> [Op] -> [Op]
forall a. a -> [a] -> [a]
: [Op]
s
        EUnary Unary
o Expression' 'RegularString
i    -> Expression' 'RegularString -> [Op] -> [Op]
go Expression' 'RegularString
i ([Op] -> [Op]) -> [Op] -> [Op]
forall a b. (a -> b) -> a -> b
$ Unary -> Op
UOp Unary
o Op -> [Op] -> [Op]
forall a. a -> [a] -> [a]
: [Op]
s
        EBinary Binary
o Expression' 'RegularString
l Expression' 'RegularString
r -> Expression' 'RegularString -> [Op] -> [Op]
go Expression' 'RegularString
l ([Op] -> [Op]) -> [Op] -> [Op]
forall a b. (a -> b) -> a -> b
$ Expression' 'RegularString -> [Op] -> [Op]
go Expression' 'RegularString
r ([Op] -> [Op]) -> [Op] -> [Op]
forall a b. (a -> b) -> a -> b
$ Binary -> Op
BOp Binary
o Op -> [Op] -> [Op]
forall a. a -> [a] -> [a]
: [Op]
s
   in Expression' 'RegularString -> [Op] -> [Op]
go Expression' 'RegularString
expr []

renderExpression :: Expression -> Text
renderExpression :: Expression' 'RegularString -> Text
renderExpression =
  let rOp :: Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rOp Text
t Expression' 'RegularString
e Expression' 'RegularString
e' = Expression' 'RegularString -> Text
renderExpression Expression' 'RegularString
e
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expression' 'RegularString -> Text
renderExpression Expression' 'RegularString
e'
      rm :: Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rm Text
m Expression' 'RegularString
e Expression' 'RegularString
e' = Expression' 'RegularString -> Text
renderExpression Expression' 'RegularString
e
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
m Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"("
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expression' 'RegularString -> Text
renderExpression Expression' 'RegularString
e'
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
   in \case
        EValue Term
t                    -> Term -> Text
renderId Term
t
        EUnary Unary
Negate Expression' 'RegularString
e             -> Text
"!" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expression' 'RegularString -> Text
renderExpression Expression' 'RegularString
e
        EUnary Unary
Parens Expression' 'RegularString
e             -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expression' 'RegularString -> Text
renderExpression Expression' 'RegularString
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        EUnary Unary
Length Expression' 'RegularString
e             -> Expression' 'RegularString -> Text
renderExpression Expression' 'RegularString
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".length()"
        EBinary Binary
LessThan Expression' 'RegularString
e Expression' 'RegularString
e'       -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rOp Text
"<" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
GreaterThan Expression' 'RegularString
e Expression' 'RegularString
e'    -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rOp Text
">" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
LessOrEqual Expression' 'RegularString
e Expression' 'RegularString
e'    -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rOp Text
"<=" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
GreaterOrEqual Expression' 'RegularString
e Expression' 'RegularString
e' -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rOp Text
">=" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
Equal Expression' 'RegularString
e Expression' 'RegularString
e'          -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rOp Text
"==" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
Contains Expression' 'RegularString
e Expression' 'RegularString
e'       -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rm Text
"contains" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
Prefix Expression' 'RegularString
e Expression' 'RegularString
e'         -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rm Text
"starts_with" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
Suffix Expression' 'RegularString
e Expression' 'RegularString
e'         -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rm Text
"ends_with" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
Regex Expression' 'RegularString
e Expression' 'RegularString
e'          -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rm Text
"matches" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
Intersection Expression' 'RegularString
e Expression' 'RegularString
e'   -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rm Text
"intersection" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
Union Expression' 'RegularString
e Expression' 'RegularString
e'          -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rm Text
"union" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
Add Expression' 'RegularString
e Expression' 'RegularString
e'            -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rOp Text
"+" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
Sub Expression' 'RegularString
e Expression' 'RegularString
e'            -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rOp Text
"-" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
Mul Expression' 'RegularString
e Expression' 'RegularString
e'            -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rOp Text
"*" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
Div Expression' 'RegularString
e Expression' 'RegularString
e'            -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rOp Text
"/" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
And Expression' 'RegularString
e Expression' 'RegularString
e'            -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rOp Text
"&&" Expression' 'RegularString
e Expression' 'RegularString
e'
        EBinary Binary
Or Expression' 'RegularString
e Expression' 'RegularString
e'             -> Text
-> Expression' 'RegularString -> Expression' 'RegularString -> Text
rOp Text
"||" Expression' 'RegularString
e Expression' 'RegularString
e'

-- | A biscuit block, containing facts, rules and checks.
--
-- 'Block' has a 'Monoid' instance, which is the expected way
-- to build composite blocks (eg if you need to generate a list of facts):
--
-- > -- build a block from multiple variables v1, v2, v3
-- > [block| value(${v1}); |] <>
-- > [block| value(${v2}); |] <>
-- > [block| value(${v3}); |]
type Block = Block' 'RegularString

-- | A biscuit block, that may or may not contain slices referencing
-- haskell variables
data Block' (ctx :: ParsedAs) = Block
  { Block' ctx -> [Rule' ctx]
bRules   :: [Rule' ctx]
  , Block' ctx -> [Predicate' 'InFact ctx]
bFacts   :: [Predicate' 'InFact ctx]
  , Block' ctx -> [Check' ctx]
bChecks  :: [Check' ctx]
  , Block' ctx -> Maybe Text
bContext :: Maybe Text
  , Block' ctx -> Maybe RuleScope
bScope   :: Maybe RuleScope
  }

renderBlock :: Block -> Text
renderBlock :: Block -> Text
renderBlock Block{[Check]
[Rule' 'RegularString]
[Fact]
Maybe Text
Maybe RuleScope
bScope :: Maybe RuleScope
bContext :: Maybe Text
bChecks :: [Check]
bFacts :: [Fact]
bRules :: [Rule' 'RegularString]
bScope :: forall (ctx :: ParsedAs). Block' ctx -> Maybe RuleScope
bContext :: forall (ctx :: ParsedAs). Block' ctx -> Maybe Text
bChecks :: forall (ctx :: ParsedAs). Block' ctx -> [Check' ctx]
bFacts :: forall (ctx :: ParsedAs). Block' ctx -> [Predicate' 'InFact ctx]
bRules :: forall (ctx :: ParsedAs). Block' ctx -> [Rule' ctx]
..} =
  Text -> [Text] -> Text
intercalate Text
";\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ Rule' 'RegularString -> Text
renderRule (Rule' 'RegularString -> Text) -> [Rule' 'RegularString] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Rule' 'RegularString]
bRules
    , Fact -> Text
renderFact (Fact -> Text) -> [Fact] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Fact]
bFacts
    , Check -> Text
renderCheck (Check -> Text) -> [Check] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Check]
bChecks
    ]

deriving instance ( Eq (Predicate' 'InFact ctx)
                  , Eq (Rule' ctx)
                  , Eq (QueryItem' ctx)
                  ) => Eq (Block' ctx)

-- deriving instance ( Show (Predicate' 'InFact ctx)
--                   , Show (Rule' ctx)
--                   , Show (QueryItem' ctx)
--                   ) => Show (Block' ctx)
instance Show Block where
  show :: Block -> String
show = Text -> String
unpack (Text -> String) -> (Block -> Text) -> Block -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Text
renderBlock

deriving instance ( Lift (Predicate' 'InFact ctx)
                  , Lift (Rule' ctx)
                  , Lift (QueryItem' ctx)
                  ) => Lift (Block' ctx)

instance Semigroup (Block' ctx) where
  Block' ctx
b1 <> :: Block' ctx -> Block' ctx -> Block' ctx
<> Block' ctx
b2 = Block :: forall (ctx :: ParsedAs).
[Rule' ctx]
-> [Predicate' 'InFact ctx]
-> [Check' ctx]
-> Maybe Text
-> Maybe RuleScope
-> Block' ctx
Block { bRules :: [Rule' ctx]
bRules = Block' ctx -> [Rule' ctx]
forall (ctx :: ParsedAs). Block' ctx -> [Rule' ctx]
bRules Block' ctx
b1 [Rule' ctx] -> [Rule' ctx] -> [Rule' ctx]
forall a. Semigroup a => a -> a -> a
<> Block' ctx -> [Rule' ctx]
forall (ctx :: ParsedAs). Block' ctx -> [Rule' ctx]
bRules Block' ctx
b2
                   , bFacts :: [Predicate' 'InFact ctx]
bFacts = Block' ctx -> [Predicate' 'InFact ctx]
forall (ctx :: ParsedAs). Block' ctx -> [Predicate' 'InFact ctx]
bFacts Block' ctx
b1 [Predicate' 'InFact ctx]
-> [Predicate' 'InFact ctx] -> [Predicate' 'InFact ctx]
forall a. Semigroup a => a -> a -> a
<> Block' ctx -> [Predicate' 'InFact ctx]
forall (ctx :: ParsedAs). Block' ctx -> [Predicate' 'InFact ctx]
bFacts Block' ctx
b2
                   , bChecks :: [Check' ctx]
bChecks = Block' ctx -> [Check' ctx]
forall (ctx :: ParsedAs). Block' ctx -> [Check' ctx]
bChecks Block' ctx
b1 [Check' ctx] -> [Check' ctx] -> [Check' ctx]
forall a. Semigroup a => a -> a -> a
<> Block' ctx -> [Check' ctx]
forall (ctx :: ParsedAs). Block' ctx -> [Check' ctx]
bChecks Block' ctx
b2
                   , bContext :: Maybe Text
bContext = Block' ctx -> Maybe Text
forall (ctx :: ParsedAs). Block' ctx -> Maybe Text
bContext Block' ctx
b2 Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Block' ctx -> Maybe Text
forall (ctx :: ParsedAs). Block' ctx -> Maybe Text
bContext Block' ctx
b1
                   , bScope :: Maybe RuleScope
bScope = Block' ctx -> Maybe RuleScope
forall (ctx :: ParsedAs). Block' ctx -> Maybe RuleScope
bScope Block' ctx
b1 Maybe RuleScope -> Maybe RuleScope -> Maybe RuleScope
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Block' ctx -> Maybe RuleScope
forall (ctx :: ParsedAs). Block' ctx -> Maybe RuleScope
bScope Block' ctx
b2
                   }

instance Monoid (Block' ctx) where
  mempty :: Block' ctx
mempty = Block :: forall (ctx :: ParsedAs).
[Rule' ctx]
-> [Predicate' 'InFact ctx]
-> [Check' ctx]
-> Maybe Text
-> Maybe RuleScope
-> Block' ctx
Block { bRules :: [Rule' ctx]
bRules = []
                 , bFacts :: [Predicate' 'InFact ctx]
bFacts = []
                 , bChecks :: [Check' ctx]
bChecks = []
                 , bContext :: Maybe Text
bContext = Maybe Text
forall a. Maybe a
Nothing
                 , bScope :: Maybe RuleScope
bScope = Maybe RuleScope
forall a. Maybe a
Nothing
                 }

listSymbolsInBlock :: Block' 'RegularString -> Set.Set Text
listSymbolsInBlock :: Block -> Set Text
listSymbolsInBlock Block {[Check]
[Rule' 'RegularString]
[Fact]
Maybe Text
Maybe RuleScope
bScope :: Maybe RuleScope
bContext :: Maybe Text
bChecks :: [Check]
bFacts :: [Fact]
bRules :: [Rule' 'RegularString]
bScope :: forall (ctx :: ParsedAs). Block' ctx -> Maybe RuleScope
bContext :: forall (ctx :: ParsedAs). Block' ctx -> Maybe Text
bChecks :: forall (ctx :: ParsedAs). Block' ctx -> [Check' ctx]
bFacts :: forall (ctx :: ParsedAs). Block' ctx -> [Predicate' 'InFact ctx]
bRules :: forall (ctx :: ParsedAs). Block' ctx -> [Rule' ctx]
..} = [Set Text] -> Set Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
  [ (Rule' 'RegularString -> Set Text)
-> [Rule' 'RegularString] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Rule' 'RegularString -> Set Text
listSymbolsInRule [Rule' 'RegularString]
bRules
  , (Fact -> Set Text) -> [Fact] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Fact -> Set Text
listSymbolsInFact [Fact]
bFacts
  , (Check -> Set Text) -> [Check] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Check -> Set Text
listSymbolsInCheck [Check]
bChecks
  ]

-- | A biscuit authorizer, containing, facts, rules, checks and policies
type Authorizer = Authorizer' 'RegularString

-- | The context in which a biscuit policies and checks are verified.
-- A authorizer may add policies (`deny if` / `allow if` conditions), as well as rules, facts, and checks.
-- A authorizer may or may not contain slices referencing haskell variables.
data Authorizer' (ctx :: ParsedAs) = Authorizer
  { Authorizer' ctx -> [Policy' ctx]
vPolicies :: [Policy' ctx]
  -- ^ the allow / deny policies.
  , Authorizer' ctx -> Block' ctx
vBlock    :: Block' ctx
  -- ^ the facts, rules and checks
  }

instance Semigroup (Authorizer' ctx) where
  Authorizer' ctx
v1 <> :: Authorizer' ctx -> Authorizer' ctx -> Authorizer' ctx
<> Authorizer' ctx
v2 = Authorizer :: forall (ctx :: ParsedAs).
[Policy' ctx] -> Block' ctx -> Authorizer' ctx
Authorizer { vPolicies :: [Policy' ctx]
vPolicies = Authorizer' ctx -> [Policy' ctx]
forall (ctx :: ParsedAs). Authorizer' ctx -> [Policy' ctx]
vPolicies Authorizer' ctx
v1 [Policy' ctx] -> [Policy' ctx] -> [Policy' ctx]
forall a. Semigroup a => a -> a -> a
<> Authorizer' ctx -> [Policy' ctx]
forall (ctx :: ParsedAs). Authorizer' ctx -> [Policy' ctx]
vPolicies Authorizer' ctx
v2
                      , vBlock :: Block' ctx
vBlock = Authorizer' ctx -> Block' ctx
forall (ctx :: ParsedAs). Authorizer' ctx -> Block' ctx
vBlock Authorizer' ctx
v1 Block' ctx -> Block' ctx -> Block' ctx
forall a. Semigroup a => a -> a -> a
<> Authorizer' ctx -> Block' ctx
forall (ctx :: ParsedAs). Authorizer' ctx -> Block' ctx
vBlock Authorizer' ctx
v2
                      }

instance Monoid (Authorizer' ctx) where
  mempty :: Authorizer' ctx
mempty = Authorizer :: forall (ctx :: ParsedAs).
[Policy' ctx] -> Block' ctx -> Authorizer' ctx
Authorizer { vPolicies :: [Policy' ctx]
vPolicies = []
                    , vBlock :: Block' ctx
vBlock = Block' ctx
forall a. Monoid a => a
mempty
                    }

deriving instance ( Eq (Block' ctx)
                  , Eq (QueryItem' ctx)
                  ) => Eq (Authorizer' ctx)

deriving instance ( Show (Block' ctx)
                  , Show (QueryItem' ctx)
                  ) => Show (Authorizer' ctx)

deriving instance ( Lift (Block' ctx)
                  , Lift (QueryItem' ctx)
                  ) => Lift (Authorizer' ctx)

data BlockElement' ctx
  = BlockFact (Predicate' 'InFact ctx)
  | BlockRule (Rule' ctx)
  | BlockCheck (Check' ctx)
  | BlockComment

deriving instance ( Show (Predicate' 'InFact ctx)
                  , Show (Rule' ctx)
                  , Show (QueryItem' ctx)
                  ) => Show (BlockElement' ctx)

elementToBlock :: BlockElement' ctx -> Block' ctx
elementToBlock :: BlockElement' ctx -> Block' ctx
elementToBlock = \case
   BlockRule Rule' ctx
r  -> [Rule' ctx]
-> [Predicate' 'InFact ctx]
-> [Check' ctx]
-> Maybe Text
-> Maybe RuleScope
-> Block' ctx
forall (ctx :: ParsedAs).
[Rule' ctx]
-> [Predicate' 'InFact ctx]
-> [Check' ctx]
-> Maybe Text
-> Maybe RuleScope
-> Block' ctx
Block [Rule' ctx
r] [] [] Maybe Text
forall a. Maybe a
Nothing Maybe RuleScope
forall a. Maybe a
Nothing
   BlockFact Predicate' 'InFact ctx
f  -> [Rule' ctx]
-> [Predicate' 'InFact ctx]
-> [Check' ctx]
-> Maybe Text
-> Maybe RuleScope
-> Block' ctx
forall (ctx :: ParsedAs).
[Rule' ctx]
-> [Predicate' 'InFact ctx]
-> [Check' ctx]
-> Maybe Text
-> Maybe RuleScope
-> Block' ctx
Block [] [Predicate' 'InFact ctx
f] [] Maybe Text
forall a. Maybe a
Nothing Maybe RuleScope
forall a. Maybe a
Nothing
   BlockCheck Check' ctx
c -> [Rule' ctx]
-> [Predicate' 'InFact ctx]
-> [Check' ctx]
-> Maybe Text
-> Maybe RuleScope
-> Block' ctx
forall (ctx :: ParsedAs).
[Rule' ctx]
-> [Predicate' 'InFact ctx]
-> [Check' ctx]
-> Maybe Text
-> Maybe RuleScope
-> Block' ctx
Block [] [] [Check' ctx
c] Maybe Text
forall a. Maybe a
Nothing Maybe RuleScope
forall a. Maybe a
Nothing
   BlockElement' ctx
BlockComment -> Block' ctx
forall a. Monoid a => a
mempty

data AuthorizerElement' ctx
  = AuthorizerPolicy (Policy' ctx)
  | BlockElement (BlockElement' ctx)

deriving instance ( Show (Predicate' 'InFact ctx)
                  , Show (Rule' ctx)
                  , Show (QueryItem' ctx)
                  ) => Show (AuthorizerElement' ctx)

elementToAuthorizer :: AuthorizerElement' ctx -> Authorizer' ctx
elementToAuthorizer :: AuthorizerElement' ctx -> Authorizer' ctx
elementToAuthorizer = \case
  AuthorizerPolicy Policy' ctx
p -> [Policy' ctx] -> Block' ctx -> Authorizer' ctx
forall (ctx :: ParsedAs).
[Policy' ctx] -> Block' ctx -> Authorizer' ctx
Authorizer [Policy' ctx
p] Block' ctx
forall a. Monoid a => a
mempty
  BlockElement BlockElement' ctx
be    -> [Policy' ctx] -> Block' ctx -> Authorizer' ctx
forall (ctx :: ParsedAs).
[Policy' ctx] -> Block' ctx -> Authorizer' ctx
Authorizer [] (BlockElement' ctx -> Block' ctx
forall (ctx :: ParsedAs). BlockElement' ctx -> Block' ctx
elementToBlock BlockElement' ctx
be)