{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeSynonymInstances #-}
module MultiInstance
(
MultiSemigroup (multi'append, multi'sconcat, multi'stimes)
, MultiMonoid (multi'empty, multi'mconcat)
, Default
, Conjunction, Disjunction
, Addition, Multiplication, multi'sum, multi'product
, And, Or, multi'and, multi'or, multi'any, multi'all
, Min, Max, MinMaybe, MaxMaybe
, First, Last
, ArrowComposition
, MultiDual
, multi'fold, multi'foldMap
, multi'find
) where
import Control.Arrow (Kleisli)
import Control.Category (id, (.))
import Control.Monad (Monad)
import Data.Bool (Bool (..), otherwise, (&&), (||))
import Data.Eq (Eq (..))
import Data.Foldable (Foldable)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (Maybe (..))
import Data.Ord (Ord (..))
import Numeric.Natural (Natural)
import Prelude (Int, Integer, Integral, Num (..),
errorWithoutStackTrace, even, pred, quot)
import qualified Data.Foldable
import qualified Data.Monoid
import qualified Data.Semigroup
class MultiSemigroup x a where
multi'append :: a -> a -> a
multi'sconcat :: NonEmpty a -> a
multi'sconcat (a
a :| [a]
as) = a -> [a] -> a
forall t. MultiSemigroup x t => t -> [t] -> t
go a
a [a]
as where
go :: t -> [t] -> t
go t
b (t
c:[t]
cs) = t -> t -> t
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x t
b (t -> [t] -> t
go t
c [t]
cs)
go t
b [] = t
b
multi'stimes :: Integral b => b -> a -> a
multi'stimes b
y0 a
x0
| b
y0 b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= b
0 = [Char] -> a
forall a. [Char] -> a
errorWithoutStackTrace
[Char]
"multi'stimes: positive multiplier expected"
| Bool
otherwise = a -> b -> a
forall a a. (Integral a, MultiSemigroup x a) => a -> a -> a
f a
x0 b
y0
where
f :: a -> a -> a
f a
x a
y
| a -> Bool
forall a. Integral a => a -> Bool
even a
y = a -> a -> a
f (a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
x a
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
2)
| a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 = a
x
| Bool
otherwise = a -> a -> a -> a
forall a a. (Integral a, MultiSemigroup x a) => a -> a -> a -> a
g (a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
x a
x) (a -> a
forall a. Enum a => a -> a
pred a
y a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
2) a
x
g :: a -> a -> a -> a
g a
x a
y a
z
| a -> Bool
forall a. Integral a => a -> Bool
even a
y = a -> a -> a -> a
g (a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
x a
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
2) a
z
| a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 = a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
x a
z
| Bool
otherwise = a -> a -> a -> a
g (a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
x a
x) (a -> a
forall a. Enum a => a -> a
pred a
y a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
2)
(a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
x a
z)
class MultiSemigroup x a => MultiMonoid x a where
multi'empty :: a
multi'mconcat :: [a] -> a
multi'mconcat = (a -> a -> a) -> a -> [a] -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Data.Foldable.foldr (forall a. MultiSemigroup x a => a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x) (forall a. MultiMonoid x a => a
forall x a. MultiMonoid x a => a
multi'empty @x)
multi'fold :: forall x t m. (MultiMonoid x m, Foldable t) => t m -> m
multi'fold :: t m -> m
multi'fold = (m -> m) -> t m -> m
forall x (t :: * -> *) m a.
(MultiMonoid x m, Foldable t) =>
(a -> m) -> t a -> m
multi'foldMap @x m -> m
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
multi'foldMap :: forall x t m a. (MultiMonoid x m, Foldable t)
=> (a -> m) -> t a -> m
multi'foldMap :: (a -> m) -> t a -> m
multi'foldMap a -> m
f = (a -> m -> m) -> m -> t a -> m
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Data.Foldable.foldr (forall a. MultiSemigroup x a => a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x (m -> m -> m) -> (a -> m) -> a -> m -> m
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> m
f) (forall a. MultiMonoid x a => a
forall x a. MultiMonoid x a => a
multi'empty @x)
multi'sum :: (Foldable t, MultiMonoid Addition a) => t a -> a
multi'sum :: t a -> a
multi'sum = forall x (t :: * -> *) m. (MultiMonoid x m, Foldable t) => t m -> m
forall (t :: * -> *) m.
(MultiMonoid Addition m, Foldable t) =>
t m -> m
multi'fold @Addition
multi'product :: (Foldable t, MultiMonoid Multiplication a) => t a -> a
multi'product :: t a -> a
multi'product = forall x (t :: * -> *) m. (MultiMonoid x m, Foldable t) => t m -> m
forall (t :: * -> *) m.
(MultiMonoid Multiplication m, Foldable t) =>
t m -> m
multi'fold @Multiplication
multi'and :: (Foldable t, MultiMonoid And a) => t a -> a
multi'and :: t a -> a
multi'and = forall x (t :: * -> *) m. (MultiMonoid x m, Foldable t) => t m -> m
forall (t :: * -> *) m.
(MultiMonoid Multiplication m, Foldable t) =>
t m -> m
multi'fold @And
multi'or :: (Foldable t, MultiMonoid Or a) => t a -> a
multi'or :: t a -> a
multi'or = forall x (t :: * -> *) m. (MultiMonoid x m, Foldable t) => t m -> m
forall (t :: * -> *) m.
(MultiMonoid Addition m, Foldable t) =>
t m -> m
multi'fold @Or
multi'any :: (Foldable t, MultiMonoid Or b) => (a -> b) -> t a -> b
multi'any :: (a -> b) -> t a -> b
multi'any = forall x (t :: * -> *) m a.
(MultiMonoid x m, Foldable t) =>
(a -> m) -> t a -> m
forall (t :: * -> *) m a.
(MultiMonoid Addition m, Foldable t) =>
(a -> m) -> t a -> m
multi'foldMap @Or
multi'all :: Foldable t => (a -> Bool) -> t a -> Bool
multi'all :: (a -> Bool) -> t a -> Bool
multi'all = forall x (t :: * -> *) m a.
(MultiMonoid x m, Foldable t) =>
(a -> m) -> t a -> m
forall (t :: * -> *) m a.
(MultiMonoid Multiplication m, Foldable t) =>
(a -> m) -> t a -> m
multi'foldMap @And
multi'find :: Foldable t => (a -> Bool) -> t a -> Maybe a
multi'find :: (a -> Bool) -> t a -> Maybe a
multi'find a -> Bool
p = (a -> Maybe a) -> t a -> Maybe a
forall x (t :: * -> *) m a.
(MultiMonoid x m, Foldable t) =>
(a -> m) -> t a -> m
multi'foldMap @First (\a
x -> if a -> Bool
p a
x then a -> Maybe a
forall a. a -> Maybe a
Just a
x else Maybe a
forall a. Maybe a
Nothing)
instance MultiSemigroup x ()
where multi'append :: () -> () -> ()
multi'append ()
_ ()
_ = ()
instance MultiMonoid x ()
where multi'empty :: ()
multi'empty = ()
data Default
instance Data.Semigroup.Semigroup a => MultiSemigroup Default a
where multi'append :: a -> a -> a
multi'append = a -> a -> a
forall a. Semigroup a => a -> a -> a
(Data.Semigroup.<>)
instance (Data.Semigroup.Semigroup a, Data.Monoid.Monoid a) =>
MultiMonoid Default a
where multi'empty :: a
multi'empty = a
forall a. Monoid a => a
Data.Monoid.mempty
data Conjunction
data Disjunction
type And = Conjunction
type Or = Disjunction
instance MultiSemigroup And Bool
where multi'append :: Bool -> Bool -> Bool
multi'append = Bool -> Bool -> Bool
(&&)
instance MultiMonoid And Bool
where multi'empty :: Bool
multi'empty = Bool
True
instance MultiSemigroup Or Bool
where multi'append :: Bool -> Bool -> Bool
multi'append = Bool -> Bool -> Bool
(||)
instance MultiMonoid Or Bool
where multi'empty :: Bool
multi'empty = Bool
False
type Addition = Disjunction
type Multiplication = Conjunction
instance MultiSemigroup Addition Int
where multi'append :: Int -> Int -> Int
multi'append = Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
instance MultiSemigroup Addition Integer
where multi'append :: Integer -> Integer -> Integer
multi'append = Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+)
instance MultiSemigroup Addition Natural
where multi'append :: Natural -> Natural -> Natural
multi'append = Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(+)
instance MultiMonoid Addition Int
where multi'empty :: Int
multi'empty = Int
0
instance MultiMonoid Addition Integer
where multi'empty :: Integer
multi'empty = Integer
0
instance MultiMonoid Addition Natural
where multi'empty :: Natural
multi'empty = Natural
0
instance MultiSemigroup Multiplication Int
where multi'append :: Int -> Int -> Int
multi'append = Int -> Int -> Int
forall a. Num a => a -> a -> a
(*)
instance MultiSemigroup Multiplication Integer
where multi'append :: Integer -> Integer -> Integer
multi'append = Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*)
instance MultiSemigroup Multiplication Natural
where multi'append :: Natural -> Natural -> Natural
multi'append = Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(*)
instance MultiMonoid Multiplication Int
where multi'empty :: Int
multi'empty = Int
1
instance MultiMonoid Multiplication Integer
where multi'empty :: Integer
multi'empty = Integer
1
instance MultiMonoid Multiplication Natural
where multi'empty :: Natural
multi'empty = Natural
1
data Min
data Max
instance Ord a => MultiSemigroup Min a
where multi'append :: a -> a -> a
multi'append = a -> a -> a
forall a. Ord a => a -> a -> a
min
instance Ord a => MultiSemigroup Max a
where multi'append :: a -> a -> a
multi'append = a -> a -> a
forall a. Ord a => a -> a -> a
max
data MinMaybe
data MaxMaybe
instance Ord a => MultiSemigroup MinMaybe (Maybe a)
where multi'append :: Maybe a -> Maybe a -> Maybe a
multi'append Maybe a
Nothing Maybe a
x = Maybe a
x
multi'append Maybe a
x Maybe a
Nothing = Maybe a
x
multi'append (Just a
x) (Just a
y) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> a -> a
forall a. Ord a => a -> a -> a
min a
x a
y)
instance Ord a => MultiMonoid MinMaybe (Maybe a)
where multi'empty :: Maybe a
multi'empty = Maybe a
forall a. Maybe a
Nothing
instance Ord a => MultiSemigroup MaxMaybe (Maybe a)
where multi'append :: Maybe a -> Maybe a -> Maybe a
multi'append Maybe a
Nothing Maybe a
x = Maybe a
x
multi'append Maybe a
x Maybe a
Nothing = Maybe a
x
multi'append (Just a
x) (Just a
y) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> a -> a
forall a. Ord a => a -> a -> a
max a
x a
y)
instance Ord a => MultiMonoid MaxMaybe (Maybe a)
where multi'empty :: Maybe a
multi'empty = Maybe a
forall a. Maybe a
Nothing
data First
data Last
instance MultiSemigroup First (Maybe a)
where multi'append :: Maybe a -> Maybe a -> Maybe a
multi'append x :: Maybe a
x@(Just a
_) Maybe a
_ = Maybe a
x
multi'append Maybe a
_ Maybe a
x = Maybe a
x
instance MultiMonoid First (Maybe a)
where multi'empty :: Maybe a
multi'empty = Maybe a
forall a. Maybe a
Nothing
instance MultiSemigroup Last (Maybe a)
where multi'append :: Maybe a -> Maybe a -> Maybe a
multi'append Maybe a
_ x :: Maybe a
x@(Just a
_) = Maybe a
x
multi'append Maybe a
x Maybe a
_ = Maybe a
x
instance MultiMonoid Last (Maybe a)
where multi'empty :: Maybe a
multi'empty = Maybe a
forall a. Maybe a
Nothing
data ArrowComposition
instance MultiSemigroup ArrowComposition (a -> a)
where multi'append :: (a -> a) -> (a -> a) -> a -> a
multi'append = (a -> a) -> (a -> a) -> a -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.)
instance MultiMonoid ArrowComposition (a -> a)
where multi'empty :: a -> a
multi'empty = a -> a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
instance Monad m => MultiSemigroup ArrowComposition (Kleisli m a a)
where multi'append :: Kleisli m a a -> Kleisli m a a -> Kleisli m a a
multi'append = Kleisli m a a -> Kleisli m a a -> Kleisli m a a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.)
instance Monad m => MultiMonoid ArrowComposition (Kleisli m a a)
where multi'empty :: Kleisli m a a
multi'empty = Kleisli m a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
instance MultiSemigroup Addition [a]
where multi'append :: [a] -> [a] -> [a]
multi'append = forall a. MultiSemigroup Default a => a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @Default
instance MultiMonoid Addition [a]
where multi'empty :: [a]
multi'empty = forall a. MultiMonoid Default a => a
forall x a. MultiMonoid x a => a
multi'empty @Default
instance MultiSemigroup Addition (NonEmpty a)
where multi'append :: NonEmpty a -> NonEmpty a -> NonEmpty a
multi'append = forall a. MultiSemigroup Default a => a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @Default
data MultiDual a
instance MultiSemigroup x a => MultiSemigroup (MultiDual x) a
where multi'append :: a -> a -> a
multi'append a
a a
b = a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
b a
a
instance MultiMonoid x a => MultiMonoid (MultiDual x) a
where multi'empty :: a
multi'empty = forall a. MultiMonoid x a => a
forall x a. MultiMonoid x a => a
multi'empty @x