Boolean.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# LANGUAGE NoImplicitPrelude #-}

-- | This module replaces the monomorphic boolean operators from "Prelude"
-- with a set of polymorphic operators.
module Morley.Prelude.Boolean
  ( Boolean(..)
  , BooleanMonoid(..)
  , ApplicativeBoolean(..)
  , or
  , and
  , or1
  , and1
  , Any(..)
  , All(..)
  , any
  , all
  , any1
  , all1

  -- * Example definitions
  -- $setup
  ) where

import Universum hiding (All(..), Any(..), all, and, any, not, or, (&&), (||))
import Universum qualified

import Data.Coerce (coerce)
import Data.Data (Data)

{- $setup
>>> :{
data Vote = Yay | Nay deriving Show
--
instance Boolean Vote where
  Yay && Yay = Yay
  _ && _ = Nay
  Nay || Nay = Nay
  _ || _ = Yay
  not Yay = Nay
  not Nay = Yay
--
instance BooleanMonoid Vote where
  true = Yay
  false = Nay
:}
-}

{- | Generalized boolean operators.

This is useful for defining things that behave like booleans, e.g. predicates,
or EDSL for predicates.

>>> Yay && Nay
Nay
>>> and1 $ Yay :| replicate 9 Yay
Yay

There are also instances for these types lifted into 'IO' and @(->) a@:

>>> (const Yay) && (const Nay) $ ()
Nay
>>> (const Yay) || (const Nay) $ ()
Yay
-}
class Boolean a where
  (&&) :: a -> a -> a
  (||) :: a -> a -> a
  infixr 3 &&
  infixr 2 ||
  not :: a -> a

instance Boolean Bool where
  (&&) = (Universum.&&)
  (||) = (Universum.||)
  not = Universum.not

{- | Generalized 'True' and 'False'.

This is useful to complete the isomorphism between regular and generalized
booleans. It's a separate class because not all boolean-like things form a monoid.

>>> or $ replicate 10 Nay
Nay
-}
class Boolean a => BooleanMonoid a where
  false :: a
  false = not true

  true :: a
  true = not false

  {-# MINIMAL true | false #-}

instance BooleanMonoid Bool where
  false = False
  true = True

{- | A generalized version of @All@ monoid wrapper.

>>> All Nay <> All Nay
All {getAll = Nay}
>>> All Yay <> All Nay
All {getAll = Nay}
>>> All Yay <> All Yay
All {getAll = Yay}
-}
newtype All a = All { getAll :: a }
  deriving stock (Generic, Data, Read, Show, Eq, Ord)
  deriving newtype (Bounded, Enum)

{- | A generalized version of @Any@ monoid wrapper.

>>> Any Nay <> Any Nay
Any {getAny = Nay}
>>> Any Yay <> Any Nay
Any {getAny = Yay}
>>> Any Yay <> Any Yay
Any {getAny = Yay}
-}
newtype Any a = Any { getAny :: a }
  deriving stock (Generic, Data, Read, Show, Eq, Ord)
  deriving newtype (Bounded, Enum)

instance Boolean a => Semigroup (Any a) where
  (<>) = coerce $ (||) @a

instance Boolean a => Semigroup (All a) where
  (<>) = coerce $ (&&) @a

instance BooleanMonoid a => Monoid (Any a) where
  mempty = coerce $ false @a

instance BooleanMonoid a => Monoid (All a) where
  mempty = coerce $ true @a

{- | Generalized version of 'Universum.or'.

>>> or $ replicate 10 Nay
Nay
>>> or $ Yay : replicate 10 Nay
Yay
-}
or :: (Container c, BooleanMonoid (Element c)) => c -> Element c
or = any id

{- | Generalized version of 'Universum.and'.

>>> and $ replicate 10 Yay
Yay
>>> and $ Nay : replicate 10 Yay
Nay
-}
and :: (Container c, BooleanMonoid (Element c)) => c -> Element c
and = all id

{- | A version of 'or' that works on 'NonEmpty', thus doesn't require
'BooleanMonoid' instance.

>>> or1 $ Yay :| [Nay]
Yay
-}
or1 :: Boolean a => NonEmpty a -> a
or1 = foldr1 (||)
{-# ANN or1 ("HLint: ignore Use or" :: Text) #-}

{- | A version of 'and' that works on 'NonEmpty', thus doesn't require
'BooleanMonoid' instance.

>>> and1 $ Yay :| [Nay]
Nay
-}
and1 :: Boolean a => NonEmpty a -> a
and1 = foldr1 (&&)
{-# ANN and1 ("HLint: ignore Use and" :: Text) #-}

{- | Generalized 'Universum.any'.

>>> any (\x -> if x > 50 then Yay else Nay) [1..100]
Yay
-}
any :: (Container c, BooleanMonoid b) => (Element c -> b) -> c -> b
any f = getAny . foldMap (Any . f)

{- | Generalized 'Universum.all'.

>>> all (\x -> if x > 50 then Yay else Nay) [1..100]
Nay
-}
all :: (Container c, BooleanMonoid b) => (Element c -> b) -> c -> b
all f = getAll . foldMap (All . f)

{- | A version of 'any' that works on 'NonEmpty', thus doesn't require
'BooleanMonoid' instance.

>>> any1 (\x -> if x > 50 then Yay else Nay) $ 50 :| replicate 10 0
Nay
-}
any1 :: Boolean b => (a -> b) -> NonEmpty a -> b
any1 f = or1 . fmap f

{- | A version of 'all' that works on 'NonEmpty', thus doesn't require
'BooleanMonoid' instance.

>>> all1 (\x -> if x > 50 then Yay else Nay) $ 100 :| replicate 10 51
Yay
-}
all1 :: Boolean b => (a -> b) -> NonEmpty a -> b
all1 f = and1 . fmap f

-- | A newtype for deriving a 'Boolean' instance for any 'Applicative' type
-- constructor using @DerivingVia@.
newtype ApplicativeBoolean f bool = ApplicativeBoolean (f bool)
  deriving newtype (Functor, Applicative)

instance (Applicative f, Boolean bool) => Boolean (ApplicativeBoolean f bool) where
  (&&) = liftA2 (&&)
  (||) = liftA2 (||)
  not = fmap not

deriving via (ApplicativeBoolean IO bool) instance Boolean bool => Boolean (IO bool)
deriving via (ApplicativeBoolean ((->) a) bool) instance Boolean bool => Boolean (a -> bool)

instance (Applicative f, BooleanMonoid bool)
      => BooleanMonoid (ApplicativeBoolean f bool) where
  true = pure true
  false = pure false

deriving via (ApplicativeBoolean IO bool)
  instance BooleanMonoid bool => BooleanMonoid (IO bool)
deriving via (ApplicativeBoolean ((->) a) bool)
  instance BooleanMonoid bool => BooleanMonoid (a -> bool)