{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeOperators #-}

module Test.Util.BoolProps (
    CollectReqs (..)
  , Prereq (..)
  , Requirement (..)
  , checkReqs
  , enabledIf
  , gCollectReqs
  , requiredIf
  ) where

import           Data.Kind (Type)
import           GHC.Generics

{-------------------------------------------------------------------------------
  Generic boolean properties
-------------------------------------------------------------------------------}

-- | A prerequisite
--
-- If any prereq is 'Blocked', then the ultimate observation must be @False@.
--
-- See 'Requirement'.
data Prereq = Blocked | Enabled
  deriving (Prereq -> Prereq -> Bool
(Prereq -> Prereq -> Bool)
-> (Prereq -> Prereq -> Bool) -> Eq Prereq
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Prereq -> Prereq -> Bool
== :: Prereq -> Prereq -> Bool
$c/= :: Prereq -> Prereq -> Bool
/= :: Prereq -> Prereq -> Bool
Eq, Int -> Prereq -> ShowS
[Prereq] -> ShowS
Prereq -> String
(Int -> Prereq -> ShowS)
-> (Prereq -> String) -> ([Prereq] -> ShowS) -> Show Prereq
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Prereq -> ShowS
showsPrec :: Int -> Prereq -> ShowS
$cshow :: Prereq -> String
show :: Prereq -> String
$cshowList :: [Prereq] -> ShowS
showList :: [Prereq] -> ShowS
Show)

enabledIf :: Bool -> Prereq
enabledIf :: Bool -> Prereq
enabledIf Bool
b = if Bool
b then Prereq
Enabled else Prereq
Blocked

-- | A requirement
--
-- If all prereqs are 'Enabled' and all reqs are 'Required' then the ultimate
-- observation must be @True@.
data Requirement = Optional | Required
  deriving (Requirement -> Requirement -> Bool
(Requirement -> Requirement -> Bool)
-> (Requirement -> Requirement -> Bool) -> Eq Requirement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Requirement -> Requirement -> Bool
== :: Requirement -> Requirement -> Bool
$c/= :: Requirement -> Requirement -> Bool
/= :: Requirement -> Requirement -> Bool
Eq, Int -> Requirement -> ShowS
[Requirement] -> ShowS
Requirement -> String
(Int -> Requirement -> ShowS)
-> (Requirement -> String)
-> ([Requirement] -> ShowS)
-> Show Requirement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Requirement -> ShowS
showsPrec :: Int -> Requirement -> ShowS
$cshow :: Requirement -> String
show :: Requirement -> String
$cshowList :: [Requirement] -> ShowS
showList :: [Requirement] -> ShowS
Show)

requiredIf :: Bool -> Requirement
requiredIf :: Bool -> Requirement
requiredIf Bool
b = if Bool
b then Requirement
Required else Requirement
Optional

-- | Collect all of the 'Prereq's and 'Requirement's from a composite type
--
-- The default definition uses "GHC.Generics" to automatically handle algebraic
-- types containing only 'Prereq', 'Requirement', 'Bool', lists, and small
-- tuples.
--
-- Note that 'collectReqs' ignores 'Bool's. It's up to the user to interpret
-- 'Bool's as either disjunctive\/conjunctive\/etc observations.
class CollectReqs a where
  collectReqs :: a -> ([Prereq], [Requirement])

  default collectReqs :: (Generic a, GCollectReqs (Rep a))
                      => a -> ([Prereq], [Requirement])
  collectReqs = Rep a Any -> ([Prereq], [Requirement])
forall x. Rep a x -> ([Prereq], [Requirement])
forall (rep :: * -> *) x.
GCollectReqs rep =>
rep x -> ([Prereq], [Requirement])
gCollectReqs (Rep a Any -> ([Prereq], [Requirement]))
-> (a -> Rep a Any) -> a -> ([Prereq], [Requirement])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

instance CollectReqs Bool where
  collectReqs :: Bool -> ([Prereq], [Requirement])
collectReqs = Bool -> ([Prereq], [Requirement])
forall a. Monoid a => a
mempty

instance CollectReqs a => CollectReqs [a] where
  collectReqs :: [a] -> ([Prereq], [Requirement])
collectReqs = (a -> ([Prereq], [Requirement]))
-> [a] -> ([Prereq], [Requirement])
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> ([Prereq], [Requirement])
forall a. CollectReqs a => a -> ([Prereq], [Requirement])
collectReqs

instance (CollectReqs a, CollectReqs b) => CollectReqs (a, b) where
  collectReqs :: (a, b) -> ([Prereq], [Requirement])
collectReqs (a
a, b
b) = a -> ([Prereq], [Requirement])
forall a. CollectReqs a => a -> ([Prereq], [Requirement])
collectReqs a
a ([Prereq], [Requirement])
-> ([Prereq], [Requirement]) -> ([Prereq], [Requirement])
forall a. Semigroup a => a -> a -> a
<> b -> ([Prereq], [Requirement])
forall a. CollectReqs a => a -> ([Prereq], [Requirement])
collectReqs b
b

instance (CollectReqs a, CollectReqs b, CollectReqs c)
      => CollectReqs (a, b, c) where
  collectReqs :: (a, b, c) -> ([Prereq], [Requirement])
collectReqs (a
a, b
b, c
c) = a -> ([Prereq], [Requirement])
forall a. CollectReqs a => a -> ([Prereq], [Requirement])
collectReqs a
a ([Prereq], [Requirement])
-> ([Prereq], [Requirement]) -> ([Prereq], [Requirement])
forall a. Semigroup a => a -> a -> a
<> b -> ([Prereq], [Requirement])
forall a. CollectReqs a => a -> ([Prereq], [Requirement])
collectReqs b
b ([Prereq], [Requirement])
-> ([Prereq], [Requirement]) -> ([Prereq], [Requirement])
forall a. Semigroup a => a -> a -> a
<> c -> ([Prereq], [Requirement])
forall a. CollectReqs a => a -> ([Prereq], [Requirement])
collectReqs c
c

instance (CollectReqs a, CollectReqs b, CollectReqs c, CollectReqs d)
      => CollectReqs (a, b, c, d) where
  collectReqs :: (a, b, c, d) -> ([Prereq], [Requirement])
collectReqs (a
a, b
b, c
c, d
d) =
      a -> ([Prereq], [Requirement])
forall a. CollectReqs a => a -> ([Prereq], [Requirement])
collectReqs a
a ([Prereq], [Requirement])
-> ([Prereq], [Requirement]) -> ([Prereq], [Requirement])
forall a. Semigroup a => a -> a -> a
<> b -> ([Prereq], [Requirement])
forall a. CollectReqs a => a -> ([Prereq], [Requirement])
collectReqs b
b ([Prereq], [Requirement])
-> ([Prereq], [Requirement]) -> ([Prereq], [Requirement])
forall a. Semigroup a => a -> a -> a
<> c -> ([Prereq], [Requirement])
forall a. CollectReqs a => a -> ([Prereq], [Requirement])
collectReqs c
c ([Prereq], [Requirement])
-> ([Prereq], [Requirement]) -> ([Prereq], [Requirement])
forall a. Semigroup a => a -> a -> a
<> d -> ([Prereq], [Requirement])
forall a. CollectReqs a => a -> ([Prereq], [Requirement])
collectReqs d
d

instance CollectReqs Requirement where
  collectReqs :: Requirement -> ([Prereq], [Requirement])
collectReqs Requirement
req = ([], [Requirement
req])

instance CollectReqs Prereq where
  collectReqs :: Prereq -> ([Prereq], [Requirement])
collectReqs Prereq
prereq = ([Prereq
prereq], [])

-- | Via 'CollectReqs', check if the ultimate observation has a required value
checkReqs :: CollectReqs a => a -> Maybe Bool
checkReqs :: forall a. CollectReqs a => a -> Maybe Bool
checkReqs a
x
      | Prereq
Blocked  Prereq -> [Prereq] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Prereq]
prereqs = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
      | Requirement
Optional Requirement -> [Requirement] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Requirement]
reqs    = Maybe Bool
forall a. Maybe a
Nothing
      | Bool
otherwise               = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    where
      ([Prereq]
prereqs, [Requirement]
reqs) = a -> ([Prereq], [Requirement])
forall a. CollectReqs a => a -> ([Prereq], [Requirement])
collectReqs a
x

{-------------------------------------------------------------------------------
  Generic boolean properties, generically
-------------------------------------------------------------------------------}

class GCollectReqs rep where
  gCollectReqs :: rep (x :: Type) -> ([Prereq], [Requirement])

instance GCollectReqs U1 where
  gCollectReqs :: forall x. U1 x -> ([Prereq], [Requirement])
gCollectReqs U1 x
U1 = ([Prereq], [Requirement])
forall a. Monoid a => a
mempty

instance GCollectReqs rep => GCollectReqs (M1 c meta rep) where
  gCollectReqs :: forall x. M1 c meta rep x -> ([Prereq], [Requirement])
gCollectReqs (M1 rep x
rep) = rep x -> ([Prereq], [Requirement])
forall x. rep x -> ([Prereq], [Requirement])
forall (rep :: * -> *) x.
GCollectReqs rep =>
rep x -> ([Prereq], [Requirement])
gCollectReqs rep x
rep

instance (GCollectReqs rep1, GCollectReqs rep2)
      => GCollectReqs (rep1 :*: rep2) where
  gCollectReqs :: forall x. (:*:) rep1 rep2 x -> ([Prereq], [Requirement])
gCollectReqs (rep1 x
rep1 :*: rep2 x
rep2) = rep1 x -> ([Prereq], [Requirement])
forall x. rep1 x -> ([Prereq], [Requirement])
forall (rep :: * -> *) x.
GCollectReqs rep =>
rep x -> ([Prereq], [Requirement])
gCollectReqs rep1 x
rep1 ([Prereq], [Requirement])
-> ([Prereq], [Requirement]) -> ([Prereq], [Requirement])
forall a. Semigroup a => a -> a -> a
<> rep2 x -> ([Prereq], [Requirement])
forall x. rep2 x -> ([Prereq], [Requirement])
forall (rep :: * -> *) x.
GCollectReqs rep =>
rep x -> ([Prereq], [Requirement])
gCollectReqs rep2 x
rep2

instance (GCollectReqs rep1, GCollectReqs rep2)
      => GCollectReqs (rep1 :+: rep2) where
  gCollectReqs :: forall x. (:+:) rep1 rep2 x -> ([Prereq], [Requirement])
gCollectReqs = \case
      L1 rep1 x
rep -> rep1 x -> ([Prereq], [Requirement])
forall x. rep1 x -> ([Prereq], [Requirement])
forall (rep :: * -> *) x.
GCollectReqs rep =>
rep x -> ([Prereq], [Requirement])
gCollectReqs rep1 x
rep
      R1 rep2 x
rep -> rep2 x -> ([Prereq], [Requirement])
forall x. rep2 x -> ([Prereq], [Requirement])
forall (rep :: * -> *) x.
GCollectReqs rep =>
rep x -> ([Prereq], [Requirement])
gCollectReqs rep2 x
rep

instance CollectReqs c => GCollectReqs (K1 meta c) where
  gCollectReqs :: forall x. K1 meta c x -> ([Prereq], [Requirement])
gCollectReqs (K1 c
c) = c -> ([Prereq], [Requirement])
forall a. CollectReqs a => a -> ([Prereq], [Requirement])
collectReqs c
c