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

-- | 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)

-- | 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 a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ((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