{-# LANGUAGE DeriveFunctor, Rank2Types #-}
module Data.Magma 
       ( Magma(..)
       , BinaryTree(..)
       , cataBinaryTree
       , anaBinaryTree
       , foldMap
       , _Leaf
       , _Node
       , nodeLeft
       , nodeRight
       ) where

import Prelude hiding (foldMap, (<>))
import qualified Data.Foldable as F
import qualified Data.Monoid as M hiding ((<>))
import Data.Profunctor
import qualified Data.Semigroup as S hiding ((<>))
import Control.DeepSeq
import Control.Applicative
import Data.Traversable

class Magma a where
  (<>) :: a -> a -> a
  

instance Magma () where
  ()
_ <> :: () -> () -> ()
<> ()
_ = ()

instance (Magma a, Magma b) => Magma (a, b) where
  (a
a, b
b) <> :: (a, b) -> (a, b) -> (a, b)
<> (a
a', b
b') = (a
a forall a. Magma a => a -> a -> a
<> a
a', b
b forall a. Magma a => a -> a -> a
<> b
b')

instance Magma a => Magma (M.Dual a) where
  M.Dual a
a <> :: Dual a -> Dual a -> Dual a
<> M.Dual a
b = forall a. a -> Dual a
M.Dual (a
b forall a. Magma a => a -> a -> a
<> a
a)

instance Magma (M.Endo a) where
  M.Endo a -> a
f <> :: Endo a -> Endo a -> Endo a
<> M.Endo a -> a
g = forall a. (a -> a) -> Endo a
M.Endo (a -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
g)

instance Magma M.All where
  M.All Bool
a <> :: All -> All -> All
<> M.All Bool
b = Bool -> All
M.All (Bool
a Bool -> Bool -> Bool
&& Bool
b)

instance Magma M.Any where
  M.Any Bool
a <> :: Any -> Any -> Any
<> M.Any Bool
b = Bool -> Any
M.Any (Bool
a Bool -> Bool -> Bool
|| Bool
b)

instance Num a => Magma (M.Sum a) where
  M.Sum a
a <> :: Sum a -> Sum a -> Sum a
<> M.Sum a
b = forall a. a -> Sum a
M.Sum (a
a forall a. Num a => a -> a -> a
+ a
b)

instance Num a => Magma (M.Product a) where
  M.Product a
a <> :: Product a -> Product a -> Product a
<> M.Product a
b = forall a. a -> Product a
M.Product (a
a forall a. Num a => a -> a -> a
* a
b)

instance Magma (M.First a) where
  r :: First a
r@(M.First (Just a
_)) <> :: First a -> First a -> First a
<> First a
_ = First a
r
  M.First Maybe a
Nothing <> First a
r = First a
r

instance Magma (M.Last a) where
  Last a
_ <> :: Last a -> Last a -> Last a
<> r :: Last a
r@(M.Last (Just a
_)) = Last a
r
  Last a
r <> M.Last Maybe a
Nothing = Last a
r

instance Ord a => Magma (S.Min a) where
  S.Min a
a <> :: Min a -> Min a -> Min a
<> S.Min a
b = forall a. a -> Min a
S.Min (forall a. Ord a => a -> a -> a
min a
a a
b)

instance Ord a => Magma (S.Max a) where
  S.Max a
a <> :: Max a -> Max a -> Max a
<> S.Max a
b = forall a. a -> Max a
S.Max (forall a. Ord a => a -> a -> a
max a
a a
b)

instance M.Monoid m => Magma (S.WrappedMonoid m) where
  S.WrapMonoid m
a <> :: WrappedMonoid m -> WrappedMonoid m -> WrappedMonoid m
<> S.WrapMonoid m
b = forall m. m -> WrappedMonoid m
S.WrapMonoid (forall a. Monoid a => a -> a -> a
M.mappend m
a m
b)

data BinaryTree a = Leaf a 
                  | Node (BinaryTree a) (BinaryTree a)
                  deriving (Int -> BinaryTree a -> ShowS
forall a. Show a => Int -> BinaryTree a -> ShowS
forall a. Show a => [BinaryTree a] -> ShowS
forall a. Show a => BinaryTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BinaryTree a] -> ShowS
$cshowList :: forall a. Show a => [BinaryTree a] -> ShowS
show :: BinaryTree a -> String
$cshow :: forall a. Show a => BinaryTree a -> String
showsPrec :: Int -> BinaryTree a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> BinaryTree a -> ShowS
Show, ReadPrec [BinaryTree a]
ReadPrec (BinaryTree a)
ReadS [BinaryTree a]
forall a. Read a => ReadPrec [BinaryTree a]
forall a. Read a => ReadPrec (BinaryTree a)
forall a. Read a => Int -> ReadS (BinaryTree a)
forall a. Read a => ReadS [BinaryTree a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BinaryTree a]
$creadListPrec :: forall a. Read a => ReadPrec [BinaryTree a]
readPrec :: ReadPrec (BinaryTree a)
$creadPrec :: forall a. Read a => ReadPrec (BinaryTree a)
readList :: ReadS [BinaryTree a]
$creadList :: forall a. Read a => ReadS [BinaryTree a]
readsPrec :: Int -> ReadS (BinaryTree a)
$creadsPrec :: forall a. Read a => Int -> ReadS (BinaryTree a)
Read, BinaryTree a -> BinaryTree a -> Bool
forall a. Eq a => BinaryTree a -> BinaryTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BinaryTree a -> BinaryTree a -> Bool
$c/= :: forall a. Eq a => BinaryTree a -> BinaryTree a -> Bool
== :: BinaryTree a -> BinaryTree a -> Bool
$c== :: forall a. Eq a => BinaryTree a -> BinaryTree a -> Bool
Eq, BinaryTree a -> BinaryTree a -> Bool
BinaryTree a -> BinaryTree a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (BinaryTree a)
forall a. Ord a => BinaryTree a -> BinaryTree a -> Bool
forall a. Ord a => BinaryTree a -> BinaryTree a -> Ordering
forall a. Ord a => BinaryTree a -> BinaryTree a -> BinaryTree a
min :: BinaryTree a -> BinaryTree a -> BinaryTree a
$cmin :: forall a. Ord a => BinaryTree a -> BinaryTree a -> BinaryTree a
max :: BinaryTree a -> BinaryTree a -> BinaryTree a
$cmax :: forall a. Ord a => BinaryTree a -> BinaryTree a -> BinaryTree a
>= :: BinaryTree a -> BinaryTree a -> Bool
$c>= :: forall a. Ord a => BinaryTree a -> BinaryTree a -> Bool
> :: BinaryTree a -> BinaryTree a -> Bool
$c> :: forall a. Ord a => BinaryTree a -> BinaryTree a -> Bool
<= :: BinaryTree a -> BinaryTree a -> Bool
$c<= :: forall a. Ord a => BinaryTree a -> BinaryTree a -> Bool
< :: BinaryTree a -> BinaryTree a -> Bool
$c< :: forall a. Ord a => BinaryTree a -> BinaryTree a -> Bool
compare :: BinaryTree a -> BinaryTree a -> Ordering
$ccompare :: forall a. Ord a => BinaryTree a -> BinaryTree a -> Ordering
Ord, forall a b. a -> BinaryTree b -> BinaryTree a
forall a b. (a -> b) -> BinaryTree a -> BinaryTree b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> BinaryTree b -> BinaryTree a
$c<$ :: forall a b. a -> BinaryTree b -> BinaryTree a
fmap :: forall a b. (a -> b) -> BinaryTree a -> BinaryTree b
$cfmap :: forall a b. (a -> b) -> BinaryTree a -> BinaryTree b
Functor)

cataBinaryTree :: (a -> r) -> (r -> r -> r) -> BinaryTree a -> r
cataBinaryTree :: forall a r. (a -> r) -> (r -> r -> r) -> BinaryTree a -> r
cataBinaryTree a -> r
f r -> r -> r
_ (Leaf a
a) = a -> r
f a
a
cataBinaryTree a -> r
f r -> r -> r
g (Node BinaryTree a
l BinaryTree a
r) = r -> r -> r
g (forall a r. (a -> r) -> (r -> r -> r) -> BinaryTree a -> r
cataBinaryTree a -> r
f r -> r -> r
g BinaryTree a
l) (forall a r. (a -> r) -> (r -> r -> r) -> BinaryTree a -> r
cataBinaryTree a -> r
f r -> r -> r
g BinaryTree a
r)

anaBinaryTree :: (b -> Either a (b, b)) -> b -> BinaryTree a
anaBinaryTree :: forall b a. (b -> Either a (b, b)) -> b -> BinaryTree a
anaBinaryTree b -> Either a (b, b)
f = b -> BinaryTree a
go where
  go :: b -> BinaryTree a
go b
b = case b -> Either a (b, b)
f b
b of
    Left a
a -> forall a. a -> BinaryTree a
Leaf a
a
    Right (b
c, b
d) -> forall a. BinaryTree a -> BinaryTree a -> BinaryTree a
Node (b -> BinaryTree a
go b
c) (b -> BinaryTree a
go b
d)

foldMap :: Magma m => (a -> m) -> BinaryTree a -> m
foldMap :: forall m a. Magma m => (a -> m) -> BinaryTree a -> m
foldMap a -> m
f (Leaf a
x) = a -> m
f a
x
foldMap a -> m
f (Node BinaryTree a
l BinaryTree a
r) = forall m a. Magma m => (a -> m) -> BinaryTree a -> m
foldMap a -> m
f BinaryTree a
l forall a. Magma a => a -> a -> a
<> forall m a. Magma m => (a -> m) -> BinaryTree a -> m
foldMap a -> m
f BinaryTree a
r

instance F.Foldable BinaryTree where
  foldMap :: forall m a. Monoid m => (a -> m) -> BinaryTree a -> m
foldMap a -> m
f (Leaf a
x) = a -> m
f a
x
  foldMap a -> m
f (Node BinaryTree a
l BinaryTree a
r) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap a -> m
f BinaryTree a
l forall a. Monoid a => a -> a -> a
`M.mappend` forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap a -> m
f BinaryTree a
r

instance Magma (BinaryTree a) where
  <> :: BinaryTree a -> BinaryTree a -> BinaryTree a
(<>) = forall a. BinaryTree a -> BinaryTree a -> BinaryTree a
Node

instance Traversable BinaryTree where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> BinaryTree a -> f (BinaryTree b)
traverse a -> f b
f (Leaf a
x) = forall a. a -> BinaryTree a
Leaf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x
  traverse a -> f b
f (Node BinaryTree a
l BinaryTree a
r) = forall a. BinaryTree a -> BinaryTree a -> BinaryTree a
Node forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f BinaryTree a
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f BinaryTree a
r

instance Applicative BinaryTree where
  pure :: forall a. a -> BinaryTree a
pure = forall a. a -> BinaryTree a
Leaf
  {-# INLINE pure #-}
  Leaf a -> b
f <*> :: forall a b. BinaryTree (a -> b) -> BinaryTree a -> BinaryTree b
<*> Leaf a
x = forall a. a -> BinaryTree a
Leaf (a -> b
f a
x)
  Leaf a -> b
f <*> Node BinaryTree a
l BinaryTree a
r = forall a. BinaryTree a -> BinaryTree a -> BinaryTree a
Node (a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinaryTree a
l) (a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinaryTree a
r)
  Node BinaryTree (a -> b)
l BinaryTree (a -> b)
r <*> BinaryTree a
t = forall a. BinaryTree a -> BinaryTree a -> BinaryTree a
Node (BinaryTree (a -> b)
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinaryTree a
t) (BinaryTree (a -> b)
r forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinaryTree a
t)

instance Monad BinaryTree where
  Leaf a
a >>= :: forall a b. BinaryTree a -> (a -> BinaryTree b) -> BinaryTree b
>>= a -> BinaryTree b
k = a -> BinaryTree b
k a
a
  Node BinaryTree a
l BinaryTree a
r >>= a -> BinaryTree b
k = forall a. BinaryTree a -> BinaryTree a -> BinaryTree a
Node (BinaryTree a
l forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> BinaryTree b
k) (BinaryTree a
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> BinaryTree b
k)

instance NFData a => NFData (BinaryTree a) where
  rnf :: BinaryTree a -> ()
rnf (Leaf a
a) = forall a. NFData a => a -> ()
rnf a
a
  rnf (Node BinaryTree a
l BinaryTree a
r) = forall a. NFData a => a -> ()
rnf BinaryTree a
l seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf BinaryTree a
r

-- | @'_Leaf' :: Prism' ('BinaryTree' a) a@
_Leaf :: forall p f a. (Choice p, Applicative f) => p a (f a) -> p (BinaryTree a) (f (BinaryTree a))
_Leaf :: forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
p a (f a) -> p (BinaryTree a) (f (BinaryTree a))
_Leaf = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap forall {b}. BinaryTree b -> Either (BinaryTree b) b
go (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> BinaryTree a
Leaf)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' where
  go :: BinaryTree b -> Either (BinaryTree b) b
go (Leaf b
a) = forall a b. b -> Either a b
Right b
a
  go BinaryTree b
t = forall a b. a -> Either a b
Left BinaryTree b
t

-- | @'_Node' :: Prism' ('BinaryTree' a) ('BinaryTree' a, 'BinaryTree' a)@
_Node :: forall p f a. (Choice p, Applicative f) => p (BinaryTree a, BinaryTree a) (f (BinaryTree a, BinaryTree a)) -> p (BinaryTree a) (f (BinaryTree a))
_Node :: forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
p (BinaryTree a, BinaryTree a) (f (BinaryTree a, BinaryTree a))
-> p (BinaryTree a) (f (BinaryTree a))
_Node = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap forall {a}.
BinaryTree a -> Either (BinaryTree a) (BinaryTree a, BinaryTree a)
go (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. BinaryTree a -> BinaryTree a -> BinaryTree a
Node))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' where
  go :: BinaryTree a -> Either (BinaryTree a) (BinaryTree a, BinaryTree a)
go (Node BinaryTree a
l BinaryTree a
r) = forall a b. b -> Either a b
Right (BinaryTree a
l, BinaryTree a
r)
  go BinaryTree a
t = forall a b. a -> Either a b
Left BinaryTree a
t

-- | @'nodeLeft' :: Traversal' ('BinaryTree' a) ('BinaryTree' a)@
nodeLeft :: Applicative f => (BinaryTree a -> f (BinaryTree a)) -> BinaryTree a -> f (BinaryTree a)
nodeLeft :: forall (f :: * -> *) a.
Applicative f =>
(BinaryTree a -> f (BinaryTree a))
-> BinaryTree a -> f (BinaryTree a)
nodeLeft BinaryTree a -> f (BinaryTree a)
f (Node BinaryTree a
l BinaryTree a
r) = (\BinaryTree a
l' -> forall a. BinaryTree a -> BinaryTree a -> BinaryTree a
Node BinaryTree a
l' BinaryTree a
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinaryTree a -> f (BinaryTree a)
f BinaryTree a
l
nodeLeft BinaryTree a -> f (BinaryTree a)
_ BinaryTree a
t = forall (f :: * -> *) a. Applicative f => a -> f a
pure BinaryTree a
t

-- | @'nodeRight' :: Traversal' ('BinaryTree' a) ('BinaryTree' a)@
nodeRight :: Applicative f => (BinaryTree a -> f (BinaryTree a)) -> BinaryTree a -> f (BinaryTree a)
nodeRight :: forall (f :: * -> *) a.
Applicative f =>
(BinaryTree a -> f (BinaryTree a))
-> BinaryTree a -> f (BinaryTree a)
nodeRight BinaryTree a -> f (BinaryTree a)
f (Node BinaryTree a
l BinaryTree a
r) = (\BinaryTree a
r' -> forall a. BinaryTree a -> BinaryTree a -> BinaryTree a
Node BinaryTree a
l BinaryTree a
r') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinaryTree a -> f (BinaryTree a)
f BinaryTree a
r
nodeRight BinaryTree a -> f (BinaryTree a)
_ BinaryTree a
t = forall (f :: * -> *) a. Applicative f => a -> f a
pure BinaryTree a
t