{-|
Module      : Cohort Criteria
Description : Defines the Criteria and related types and functions
Copyright   : (c) NoviSci, Inc 2020
License     : BSD3
Maintainer  : bsaul@novisci.com
-}
{-# OPTIONS_HADDOCK hide #-}
-- {-# LANGUAGE Safe #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-}


module Cohort.Criteria
  ( Criterion
  , Criteria(..)
  , Status(..)
  , CohortStatus(..)
  , criterion
  , criteria
  , excludeIf
  , includeIf
  , initStatusInfo
  , checkCohortStatus
  ) where

import           Control.Applicative            ( Applicative(pure) )
import           Control.Monad                  ( Functor(..) )
import           Data.Aeson                     ( (.=)
                                                , ToJSON(..)
                                                , object
                                                )
import           Data.Bifunctor                 ( Bifunctor(second) )
import           Data.Bool                      ( (&&)
                                                , Bool(..)
                                                , not
                                                , otherwise
                                                )
import           Data.Either                    ( either )
import           Data.Eq                        ( Eq(..) )
import           Data.Function                  ( ($)
                                                , (.)
                                                , const
                                                , id
                                                )
import           Data.List                      ( (++)
                                                , find
                                                )
import qualified Data.List.NonEmpty            as NE
                                                ( NonEmpty
                                                , fromList
                                                , zip
                                                )
import           Data.Maybe                     ( Maybe(..)
                                                , maybe
                                                )
import           Data.Ord                       ( Ord(..)
                                                , Ordering(..)
                                                )
import           Data.Semigroup                 ( Semigroup((<>)) )
import           Data.Text                      ( Text
                                                , pack
                                                )
import           Data.Tuple                     ( fst
                                                , snd
                                                )
import           Features.Compose               ( Feature
                                                , FeatureN(..)
                                                , getFeatureData
                                                , nameFeature
                                                )
import           GHC.Generics                   ( Generic )
import           GHC.Num                        ( Natural
                                                , Num((+))
                                                )
import           GHC.Show                       ( Show(show) )
import           GHC.TypeLits                   ( KnownSymbol
                                                , symbolVal
                                                )

-- | Defines the return type for @'Criterion'@ indicating whether to include or 
-- exclude a subject.
data Status = Include | Exclude deriving (Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq, Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> Status -> ShowS
Show, (forall x. Status -> Rep Status x)
-> (forall x. Rep Status x -> Status) -> Generic Status
forall x. Rep Status x -> Status
forall x. Status -> Rep Status x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Status x -> Status
$cfrom :: forall x. Status -> Rep Status x
Generic)

-- | Defines subject's diposition in a cohort either included or which criterion
-- they were excluded by. See @'checkCohortStatus'@ for evaluating a @'Criteria'@
-- to determine CohortStatus.
data CohortStatus =
  Included | ExcludedBy (Natural, Text)
    deriving (CohortStatus -> CohortStatus -> Bool
(CohortStatus -> CohortStatus -> Bool)
-> (CohortStatus -> CohortStatus -> Bool) -> Eq CohortStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CohortStatus -> CohortStatus -> Bool
$c/= :: CohortStatus -> CohortStatus -> Bool
== :: CohortStatus -> CohortStatus -> Bool
$c== :: CohortStatus -> CohortStatus -> Bool
Eq, Int -> CohortStatus -> ShowS
[CohortStatus] -> ShowS
CohortStatus -> String
(Int -> CohortStatus -> ShowS)
-> (CohortStatus -> String)
-> ([CohortStatus] -> ShowS)
-> Show CohortStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CohortStatus] -> ShowS
$cshowList :: [CohortStatus] -> ShowS
show :: CohortStatus -> String
$cshow :: CohortStatus -> String
showsPrec :: Int -> CohortStatus -> ShowS
$cshowsPrec :: Int -> CohortStatus -> ShowS
Show, (forall x. CohortStatus -> Rep CohortStatus x)
-> (forall x. Rep CohortStatus x -> CohortStatus)
-> Generic CohortStatus
forall x. Rep CohortStatus x -> CohortStatus
forall x. CohortStatus -> Rep CohortStatus x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CohortStatus x -> CohortStatus
$cfrom :: forall x. CohortStatus -> Rep CohortStatus x
Generic)

-- Defines an ordering to put @Included@ last in a container of @'CohortStatus'@.
-- The @'ExcludedBy'@ are ordered by their number value.
instance Ord CohortStatus where
  compare :: CohortStatus -> CohortStatus -> Ordering
compare CohortStatus
Included            CohortStatus
Included            = Ordering
EQ
  compare CohortStatus
Included            (ExcludedBy (Natural, Text)
_)      = Ordering
GT
  compare (ExcludedBy (Natural, Text)
_     ) CohortStatus
Included            = Ordering
LT
  compare (ExcludedBy (Natural
i, Text
_)) (ExcludedBy (Natural
j, Text
_)) = Natural -> Natural -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Natural
i Natural
j

-- | Helper to convert a @Bool@ to a @'Status'@
-- 
-- >>> includeIf True
-- >>> includeIf False
-- Include
-- Exclude
includeIf :: Bool -> Status
includeIf :: Bool -> Status
includeIf Bool
True  = Status
Include
includeIf Bool
False = Status
Exclude

-- | Helper to convert a @Bool@ to a @'Status'@
-- 
-- >>> excludeIf True
-- >>> excludeIf False
-- Exclude
-- Include
excludeIf :: Bool -> Status
excludeIf :: Bool -> Status
excludeIf Bool
True  = Status
Exclude
excludeIf Bool
False = Status
Include

-- | A type that is simply a @'FeatureN Status'@, that is, a feature that 
-- identifies whether to @'Include'@ or @'Exclude'@ a subject.
newtype Criterion = MkCriterion ( FeatureN Status ) deriving (Criterion -> Criterion -> Bool
(Criterion -> Criterion -> Bool)
-> (Criterion -> Criterion -> Bool) -> Eq Criterion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Criterion -> Criterion -> Bool
$c/= :: Criterion -> Criterion -> Bool
== :: Criterion -> Criterion -> Bool
$c== :: Criterion -> Criterion -> Bool
Eq, Int -> Criterion -> ShowS
[Criterion] -> ShowS
Criterion -> String
(Int -> Criterion -> ShowS)
-> (Criterion -> String)
-> ([Criterion] -> ShowS)
-> Show Criterion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Criterion] -> ShowS
$cshowList :: [Criterion] -> ShowS
show :: Criterion -> String
$cshow :: Criterion -> String
showsPrec :: Int -> Criterion -> ShowS
$cshowsPrec :: Int -> Criterion -> ShowS
Show)

-- | Converts a @'Feature'@ to a @'Criterion'@.
criterion :: (KnownSymbol n) => Feature n Status -> Criterion
criterion :: Feature n Status -> Criterion
criterion Feature n Status
x = FeatureN Status -> Criterion
MkCriterion (Feature n Status -> FeatureN Status
forall (name :: Symbol) d.
KnownSymbol name =>
Feature name d -> FeatureN d
nameFeature Feature n Status
x)

-- | A nonempty collection of @'Criterion'@ paired with a @Natural@ number.
newtype Criteria = MkCriteria {
    Criteria -> NonEmpty (Natural, Criterion)
getCriteria :: NE.NonEmpty (Natural, Criterion)
  } deriving (Criteria -> Criteria -> Bool
(Criteria -> Criteria -> Bool)
-> (Criteria -> Criteria -> Bool) -> Eq Criteria
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Criteria -> Criteria -> Bool
$c/= :: Criteria -> Criteria -> Bool
== :: Criteria -> Criteria -> Bool
$c== :: Criteria -> Criteria -> Bool
Eq, Int -> Criteria -> ShowS
[Criteria] -> ShowS
Criteria -> String
(Int -> Criteria -> ShowS)
-> (Criteria -> String) -> ([Criteria] -> ShowS) -> Show Criteria
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Criteria] -> ShowS
$cshowList :: [Criteria] -> ShowS
show :: Criteria -> String
$cshow :: Criteria -> String
showsPrec :: Int -> Criteria -> ShowS
$cshowsPrec :: Int -> Criteria -> ShowS
Show)

-- | Constructs a @'Criteria'@ from a @'NE.NonEmpty'@ collection of @'Criterion'@.
criteria :: NE.NonEmpty Criterion -> Criteria
criteria :: NonEmpty Criterion -> Criteria
criteria NonEmpty Criterion
l = NonEmpty (Natural, Criterion) -> Criteria
MkCriteria (NonEmpty (Natural, Criterion) -> Criteria)
-> NonEmpty (Natural, Criterion) -> Criteria
forall a b. (a -> b) -> a -> b
$ NonEmpty Natural
-> NonEmpty Criterion -> NonEmpty (Natural, Criterion)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip ([Natural] -> NonEmpty Natural
forall a. [a] -> NonEmpty a
NE.fromList [Natural
1 ..]) NonEmpty Criterion
l

-- | Unpacks a @'Criterion'@ into a (Text, Status) pair where the text is the
-- name of the criterion and its @Status@ is the value of the status in the 
-- @'Criterion'@. In the case, that the value of the @'Features.Compose.FeatureData'@ 
-- within the @'Criterion'@ is @Left@, the status is set to @'Exclude'@. 
getStatus :: Criterion -> (Text, Status)
getStatus :: Criterion -> (Text, Status)
getStatus (MkCriterion FeatureN Status
x) = (MissingReason -> (Text, Status))
-> (Status -> (Text, Status))
-> Either MissingReason Status
-> (Text, Status)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((Text, Status) -> MissingReason -> (Text, Status)
forall a b. a -> b -> a
const (Text
nm, Status
Exclude))
                                   (Text
nm, )
                                   ((FeatureData Status -> Either MissingReason Status
forall d. FeatureData d -> Either MissingReason d
getFeatureData (FeatureData Status -> Either MissingReason Status)
-> (FeatureN Status -> FeatureData Status)
-> FeatureN Status
-> Either MissingReason Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FeatureN Status -> FeatureData Status
forall d. FeatureN d -> FeatureData d
getDataN) FeatureN Status
x)
  where nm :: Text
nm = FeatureN Status -> Text
forall d. FeatureN d -> Text
getNameN FeatureN Status
x

-- | Converts a subject's @'Criteria'@ into a @'NE.NonEmpty'@ triple of 
-- (order of criterion, name of criterion, status)
getStatuses :: Criteria -> NE.NonEmpty (Natural, Text, Status)
getStatuses :: Criteria -> NonEmpty (Natural, Text, Status)
getStatuses (MkCriteria NonEmpty (Natural, Criterion)
x) =
  ((Natural, Criterion) -> (Natural, Text, Status))
-> NonEmpty (Natural, Criterion)
-> NonEmpty (Natural, Text, Status)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Natural, Criterion)
c -> ((Natural, Criterion) -> Natural
forall a b. (a, b) -> a
fst (Natural, Criterion)
c, ((Text, Status) -> Text
forall a b. (a, b) -> a
fst ((Text, Status) -> Text)
-> ((Natural, Criterion) -> (Text, Status))
-> (Natural, Criterion)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Criterion -> (Text, Status)
getStatus (Criterion -> (Text, Status))
-> ((Natural, Criterion) -> Criterion)
-> (Natural, Criterion)
-> (Text, Status)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural, Criterion) -> Criterion
forall a b. (a, b) -> b
snd) (Natural, Criterion)
c, ((Text, Status) -> Status
forall a b. (a, b) -> b
snd ((Text, Status) -> Status)
-> ((Natural, Criterion) -> (Text, Status))
-> (Natural, Criterion)
-> Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Criterion -> (Text, Status)
getStatus (Criterion -> (Text, Status))
-> ((Natural, Criterion) -> Criterion)
-> (Natural, Criterion)
-> (Text, Status)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural, Criterion) -> Criterion
forall a b. (a, b) -> b
snd) (Natural, Criterion)
c)) NonEmpty (Natural, Criterion)
x

-- | An internal function used to @'Data.List.find'@ excluded statuses. Used in
-- 'checkCohortStatus'.
findExclude :: Criteria -> Maybe (Natural, Text, Status)
findExclude :: Criteria -> Maybe (Natural, Text, Status)
findExclude Criteria
x = ((Natural, Text, Status) -> Bool)
-> NonEmpty (Natural, Text, Status)
-> Maybe (Natural, Text, Status)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Natural
_, Text
_, Status
z) -> Status
z Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
Exclude) (Criteria -> NonEmpty (Natural, Text, Status)
getStatuses Criteria
x)

-- | Converts a subject's @'Criteria'@ to a @'CohortStatus'@. The status is set
-- to @'Included'@ if none of the @'Criterion'@ have a status of @'Exclude'@.
checkCohortStatus :: Criteria -> CohortStatus
checkCohortStatus :: Criteria -> CohortStatus
checkCohortStatus Criteria
x =
  CohortStatus
-> ((Natural, Text, Status) -> CohortStatus)
-> Maybe (Natural, Text, Status)
-> CohortStatus
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CohortStatus
Included (\(Natural
i, Text
n, Status
_) -> (Natural, Text) -> CohortStatus
ExcludedBy (Natural
i, Text
n)) (Criteria -> Maybe (Natural, Text, Status)
findExclude Criteria
x)

-- | Utility to get the name of a @'Criterion'@.
getCriterionName :: Criterion -> Text
getCriterionName :: Criterion -> Text
getCriterionName (MkCriterion FeatureN Status
x) = FeatureN Status -> Text
forall d. FeatureN d -> Text
getNameN FeatureN Status
x

-- | Initializes a container of @'CohortStatus'@ from a @'Criteria'@. This can be used
-- to collect generate all the possible Exclusion/Inclusion reasons. 
initStatusInfo :: Criteria -> NE.NonEmpty CohortStatus
initStatusInfo :: Criteria -> NonEmpty CohortStatus
initStatusInfo (MkCriteria NonEmpty (Natural, Criterion)
z) =
  ((Natural, Criterion) -> CohortStatus)
-> NonEmpty (Natural, Criterion) -> NonEmpty CohortStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Natural, Text) -> CohortStatus
ExcludedBy ((Natural, Text) -> CohortStatus)
-> ((Natural, Criterion) -> (Natural, Text))
-> (Natural, Criterion)
-> CohortStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Criterion -> Text) -> (Natural, Criterion) -> (Natural, Text)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
Data.Bifunctor.second Criterion -> Text
getCriterionName) NonEmpty (Natural, Criterion)
z NonEmpty CohortStatus
-> NonEmpty CohortStatus -> NonEmpty CohortStatus
forall a. Semigroup a => a -> a -> a
<> CohortStatus -> NonEmpty CohortStatus
forall (f :: * -> *) a. Applicative f => a -> f a
pure CohortStatus
Included