diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,13 @@ +0.5.2 +===== +* [!1290](https://gitlab.com/morley-framework/morley/-/merge_requests/1290) + Add `or`, `and`, `or1`, `and1`, `not` functions for overloaded booleans + + Add `BooleanMonoid` type class for boolean-like things that can define + `true` and `false`. + 0.5.1 ===== * [!1080](https://gitlab.com/morley-framework/morley/-/merge_requests/1080) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,5 @@ MIT License -Copyright (c) 2021-2022 Oxhead Alpha +Copyright (c) 2021-2023 Oxhead Alpha Copyright (c) 2019-2021 Tocqueville Group Permission is hereby granted, free of charge, to any person obtaining a copy diff --git a/morley-prelude.cabal b/morley-prelude.cabal --- a/morley-prelude.cabal +++ b/morley-prelude.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: morley-prelude -version: 0.5.1 +version: 0.5.2 synopsis: A custom prelude used in Morley description: A custom prelude used in Morley. It re-exports the Universum prelude and makes some tiny changes. category: Prelude @@ -13,7 +13,7 @@ bug-reports: https://gitlab.com/morley-framework/morley/-/issues author: camlCase, Serokell, Tocqueville Group maintainer: Serokell -copyright: 2019-2021 Tocqueville Group, 2021-2022 Oxhead Alpha +copyright: 2019-2021 Tocqueville Group, 2021-2023 Oxhead Alpha license: MIT license-file: LICENSE build-type: Simple @@ -61,6 +61,7 @@ GADTs GeneralizedNewtypeDeriving ImportQualifiedPost + InstanceSigs LambdaCase MultiParamTypeClasses MultiWayIf @@ -89,7 +90,7 @@ UndecidableInstances UndecidableSuperClasses ViewPatterns - ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode build-depends: Cabal , OddWord diff --git a/src/Morley/Prelude/Boolean.hs b/src/Morley/Prelude/Boolean.hs --- a/src/Morley/Prelude/Boolean.hs +++ b/src/Morley/Prelude/Boolean.hs @@ -7,23 +7,209 @@ -- 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 ((&&), (||)) +import Universum hiding (All(..), Any(..), all, and, any, not, or, (&&), (||)) import Universum qualified --- | Generalized boolean operators. +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) @@ -32,6 +218,17 @@ 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) diff --git a/src/Prelude.hs b/src/Prelude.hs --- a/src/Prelude.hs +++ b/src/Prelude.hs @@ -34,7 +34,7 @@ import Morley.Prelude.Show as Show import Morley.Prelude.Word as Word import Universum hiding - (Key, Lens, Lens', Nat, Traversal, Traversal', Val, _1, _2, _3, _4, _5, fromInteger, fromIntegral, - over, preuse, preview, readFile, set, show, use, view, writeFile, (%~), (&&), (&), (.~), (<&>), - (^.), (^..), (^?), (||)) + (All(..), Any(..), Key, Lens, Lens', Nat, Traversal, Traversal', Val, _1, _2, _3, _4, _5, all, + and, any, fromInteger, fromIntegral, not, or, over, preuse, preview, readFile, set, show, use, + view, writeFile, (%~), (&&), (&), (.~), (<&>), (^.), (^..), (^?), (||)) import Unsafe qualified (fromInteger, unsafe, unsafeM)