-- | A selector reads job fields and applies policies. Evaluation returns the
-- selected result. Static inspection returns all reachable policies for
-- migration initialization.
module Arbiter.Core.Selector
  ( Selector
  , field
  , usePolicy
  , runSelector
  , collectPolicies
  , usesAnyPolicy
  , chooseWhen
  , selectByCase
  ) where

import Control.Selective (bindS, ifS)
import Control.Selective.Free (Select, getEffects, liftSelect, runSelect)
import Data.Maybe (mapMaybe)
import Data.Set (Set)
import Data.Set qualified as Set

-- | A primitive in a selector. Reads a field of the job, or uses a policy. A used
-- policy is recorded for collection and yielded for building a key.
data Prim policy payload a
  = ReadField (payload -> a)
  | UsePolicy policy a
  deriving stock ((forall a b.
 (a -> b) -> Prim policy payload a -> Prim policy payload b)
-> (forall a b.
    a -> Prim policy payload b -> Prim policy payload a)
-> Functor (Prim policy payload)
forall a b. a -> Prim policy payload b -> Prim policy payload a
forall a b.
(a -> b) -> Prim policy payload a -> Prim policy payload b
forall policy payload a b.
a -> Prim policy payload b -> Prim policy payload a
forall policy payload a b.
(a -> b) -> Prim policy payload a -> Prim policy payload b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall policy payload a b.
(a -> b) -> Prim policy payload a -> Prim policy payload b
fmap :: forall a b.
(a -> b) -> Prim policy payload a -> Prim policy payload b
$c<$ :: forall policy payload a b.
a -> Prim policy payload b -> Prim policy payload a
<$ :: forall a b. a -> Prim policy payload b -> Prim policy payload a
Functor)

-- | A selective description over a payload. Evaluation for a job returns an
-- @a@. Static inspection returns the reachable policies.
type Selector policy payload = Select (Prim policy payload)

-- | Read a field of the job (for predicates or key suffixes).
field :: (payload -> a) -> Selector policy payload a
field :: forall payload a policy.
(payload -> a) -> Selector policy payload a
field = Prim policy payload a -> Select (Prim policy payload) a
forall (f :: * -> *) a. f a -> Select f a
liftSelect (Prim policy payload a -> Select (Prim policy payload) a)
-> ((payload -> a) -> Prim policy payload a)
-> (payload -> a)
-> Select (Prim policy payload) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (payload -> a) -> Prim policy payload a
forall policy payload a. (payload -> a) -> Prim policy payload a
ReadField

-- | Record a policy for initialization and return it for key construction.
usePolicy :: policy -> Selector policy payload policy
usePolicy :: forall policy payload. policy -> Selector policy payload policy
usePolicy policy
chosen = Prim policy payload policy -> Select (Prim policy payload) policy
forall (f :: * -> *) a. f a -> Select f a
liftSelect (policy -> policy -> Prim policy payload policy
forall policy payload a. policy -> a -> Prim policy payload a
UsePolicy policy
chosen policy
chosen)

-- | Run a selector against a concrete job to get its result.
runSelector :: forall policy payload a. payload -> Selector policy payload a -> a
runSelector :: forall policy payload a. payload -> Selector policy payload a -> a
runSelector payload
job Selector policy payload a
program = (forall x. Prim policy payload x -> payload -> x)
-> Selector policy payload a -> payload -> a
forall (g :: * -> *) (f :: * -> *) a.
Selective g =>
(forall x. f x -> g x) -> Select f a -> g a
runSelect Prim policy payload x -> payload -> x
forall x. Prim policy payload x -> payload -> x
interpret Selector policy payload a
program payload
job
  where
    interpret :: forall x. Prim policy payload x -> (payload -> x)
    interpret :: forall x. Prim policy payload x -> payload -> x
interpret (ReadField payload -> x
reader) = payload -> x
reader
    interpret (UsePolicy policy
_ x
result) = x -> payload -> x
forall a b. a -> b -> a
const x
result

-- | All policies that a selector can reach across all branches.
collectPolicies :: (Ord policy) => Selector policy payload a -> Set policy
collectPolicies :: forall policy payload a.
Ord policy =>
Selector policy payload a -> Set policy
collectPolicies = [policy] -> Set policy
forall a. Ord a => [a] -> Set a
Set.fromList ([policy] -> Set policy)
-> (Selector policy payload a -> [policy])
-> Selector policy payload a
-> Set policy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Prim policy payload () -> Maybe policy)
-> [Prim policy payload ()] -> [policy]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Prim policy payload () -> Maybe policy
forall {a} {payload} {a}. Prim a payload a -> Maybe a
used ([Prim policy payload ()] -> [policy])
-> (Selector policy payload a -> [Prim policy payload ()])
-> Selector policy payload a
-> [policy]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selector policy payload a -> [Prim policy payload ()]
forall (f :: * -> *) a. Functor f => Select f a -> [f ()]
getEffects
  where
    used :: Prim a payload a -> Maybe a
used (UsePolicy a
chosen a
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
chosen
    used (ReadField payload -> a
_) = Maybe a
forall a. Maybe a
Nothing

-- | Test for a reachable policy. Stop at the first match.
usesAnyPolicy :: Selector policy payload a -> Bool
usesAnyPolicy :: forall policy payload a. Selector policy payload a -> Bool
usesAnyPolicy = (Prim policy payload () -> Bool)
-> [Prim policy payload ()] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Prim policy payload () -> Bool
forall {policy} {payload} {a}. Prim policy payload a -> Bool
isUse ([Prim policy payload ()] -> Bool)
-> (Selector policy payload a -> [Prim policy payload ()])
-> Selector policy payload a
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selector policy payload a -> [Prim policy payload ()]
forall (f :: * -> *) a. Functor f => Select f a -> [f ()]
getEffects
  where
    isUse :: Prim policy payload a -> Bool
isUse (UsePolicy policy
_ a
_) = Bool
True
    isUse (ReadField payload -> a
_) = Bool
False

-- | Select between two selectors with a job predicate. Policy collection
-- inspects both branches.
chooseWhen
  :: (payload -> Bool)
  -> Selector policy payload a
  -> Selector policy payload a
  -> Selector policy payload a
chooseWhen :: forall payload policy a.
(payload -> Bool)
-> Selector policy payload a
-> Selector policy payload a
-> Selector policy payload a
chooseWhen payload -> Bool
predicate = Select (Prim policy payload) Bool
-> Select (Prim policy payload) a
-> Select (Prim policy payload) a
-> Select (Prim policy payload) a
forall (f :: * -> *) a. Selective f => f Bool -> f a -> f a -> f a
ifS ((payload -> Bool) -> Select (Prim policy payload) Bool
forall payload a policy.
(payload -> a) -> Selector policy payload a
field payload -> Bool
predicate)

-- | N-way 'chooseWhen'. Maps the job to a finite tag, then each tag to its selector.
-- Policy collection evaluates every tag in @[minBound..maxBound]@. The tag's
-- 'Bounded'\/'Enum' and the selector must be total over @k@.
selectByCase
  :: (Bounded k, Enum k, Eq k)
  => (payload -> k)
  -> (k -> Selector policy payload a)
  -> Selector policy payload a
selectByCase :: forall k payload policy a.
(Bounded k, Enum k, Eq k) =>
(payload -> k)
-> (k -> Selector policy payload a) -> Selector policy payload a
selectByCase payload -> k
tag = Select (Prim policy payload) k
-> (k -> Select (Prim policy payload) a)
-> Select (Prim policy payload) a
forall a (f :: * -> *) b.
(Bounded a, Enum a, Eq a, Selective f) =>
f a -> (a -> f b) -> f b
bindS ((payload -> k) -> Select (Prim policy payload) k
forall payload a policy.
(payload -> a) -> Selector policy payload a
field payload -> k
tag)