{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies               #-}

module Data.Semigroup.Semilattice
    ( FreeSemilattice
    , fromNonEmpty
    , toNonEmpty
    ) where

import           Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import           Data.IntSet (IntSet)
import           Data.Semigroup ( All
                                , Any
                                , sconcat)
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Void (Void)

import           Data.Algebra.Free ( AlgebraType
                                   , AlgebraType0
                                   , FreeAlgebra (..)
                                   )
import           Data.Semigroup.Abelian (AbelianSemigroup)

-- | Class of abelian semigroups in which every element is idempotent, i.e.
-- @a <> a = a@.
--
class AbelianSemigroup m => Semilattice m

instance Semilattice Void
instance Semilattice ()
instance Semilattice All
instance Semilattice Any
instance Ord a => Semilattice (Set a)
instance Semilattice IntSet

-- | @'FreeSemilattice'@ is a non empty set.
--
newtype FreeSemilattice a = FreeSemilattice (Set a)
    deriving (Eq (FreeSemilattice a)
Eq (FreeSemilattice a)
-> (FreeSemilattice a -> FreeSemilattice a -> Ordering)
-> (FreeSemilattice a -> FreeSemilattice a -> Bool)
-> (FreeSemilattice a -> FreeSemilattice a -> Bool)
-> (FreeSemilattice a -> FreeSemilattice a -> Bool)
-> (FreeSemilattice a -> FreeSemilattice a -> Bool)
-> (FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a)
-> (FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a)
-> Ord (FreeSemilattice a)
FreeSemilattice a -> FreeSemilattice a -> Bool
FreeSemilattice a -> FreeSemilattice a -> Ordering
FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
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 (FreeSemilattice a)
forall a. Ord a => FreeSemilattice a -> FreeSemilattice a -> Bool
forall a.
Ord a =>
FreeSemilattice a -> FreeSemilattice a -> Ordering
forall a.
Ord a =>
FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
$ccompare :: forall a.
Ord a =>
FreeSemilattice a -> FreeSemilattice a -> Ordering
compare :: FreeSemilattice a -> FreeSemilattice a -> Ordering
$c< :: forall a. Ord a => FreeSemilattice a -> FreeSemilattice a -> Bool
< :: FreeSemilattice a -> FreeSemilattice a -> Bool
$c<= :: forall a. Ord a => FreeSemilattice a -> FreeSemilattice a -> Bool
<= :: FreeSemilattice a -> FreeSemilattice a -> Bool
$c> :: forall a. Ord a => FreeSemilattice a -> FreeSemilattice a -> Bool
> :: FreeSemilattice a -> FreeSemilattice a -> Bool
$c>= :: forall a. Ord a => FreeSemilattice a -> FreeSemilattice a -> Bool
>= :: FreeSemilattice a -> FreeSemilattice a -> Bool
$cmax :: forall a.
Ord a =>
FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
max :: FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
$cmin :: forall a.
Ord a =>
FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
min :: FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
Ord, FreeSemilattice a -> FreeSemilattice a -> Bool
(FreeSemilattice a -> FreeSemilattice a -> Bool)
-> (FreeSemilattice a -> FreeSemilattice a -> Bool)
-> Eq (FreeSemilattice a)
forall a. Eq a => FreeSemilattice a -> FreeSemilattice a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => FreeSemilattice a -> FreeSemilattice a -> Bool
== :: FreeSemilattice a -> FreeSemilattice a -> Bool
$c/= :: forall a. Eq a => FreeSemilattice a -> FreeSemilattice a -> Bool
/= :: FreeSemilattice a -> FreeSemilattice a -> Bool
Eq, Int -> FreeSemilattice a -> ShowS
[FreeSemilattice a] -> ShowS
FreeSemilattice a -> String
(Int -> FreeSemilattice a -> ShowS)
-> (FreeSemilattice a -> String)
-> ([FreeSemilattice a] -> ShowS)
-> Show (FreeSemilattice a)
forall a. Show a => Int -> FreeSemilattice a -> ShowS
forall a. Show a => [FreeSemilattice a] -> ShowS
forall a. Show a => FreeSemilattice a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> FreeSemilattice a -> ShowS
showsPrec :: Int -> FreeSemilattice a -> ShowS
$cshow :: forall a. Show a => FreeSemilattice a -> String
show :: FreeSemilattice a -> String
$cshowList :: forall a. Show a => [FreeSemilattice a] -> ShowS
showList :: [FreeSemilattice a] -> ShowS
Show, NonEmpty (FreeSemilattice a) -> FreeSemilattice a
FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
(FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a)
-> (NonEmpty (FreeSemilattice a) -> FreeSemilattice a)
-> (forall b.
    Integral b =>
    b -> FreeSemilattice a -> FreeSemilattice a)
-> Semigroup (FreeSemilattice a)
forall b. Integral b => b -> FreeSemilattice a -> FreeSemilattice a
forall a.
Ord a =>
NonEmpty (FreeSemilattice a) -> FreeSemilattice a
forall a.
Ord a =>
FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
forall a b.
(Ord a, Integral b) =>
b -> FreeSemilattice a -> FreeSemilattice a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: forall a.
Ord a =>
FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
<> :: FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
$csconcat :: forall a.
Ord a =>
NonEmpty (FreeSemilattice a) -> FreeSemilattice a
sconcat :: NonEmpty (FreeSemilattice a) -> FreeSemilattice a
$cstimes :: forall a b.
(Ord a, Integral b) =>
b -> FreeSemilattice a -> FreeSemilattice a
stimes :: forall b. Integral b => b -> FreeSemilattice a -> FreeSemilattice a
Semigroup)

instance Ord a => AbelianSemigroup (FreeSemilattice a)

instance Ord a => Semilattice (FreeSemilattice a)

fromNonEmpty :: Ord a => NonEmpty a -> FreeSemilattice a
fromNonEmpty :: forall a. Ord a => NonEmpty a -> FreeSemilattice a
fromNonEmpty = Set a -> FreeSemilattice a
forall a. Set a -> FreeSemilattice a
FreeSemilattice (Set a -> FreeSemilattice a)
-> (NonEmpty a -> Set a) -> NonEmpty a -> FreeSemilattice a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ([a] -> Set a) -> (NonEmpty a -> [a]) -> NonEmpty a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NE.toList

toNonEmpty :: FreeSemilattice a -> NonEmpty a
toNonEmpty :: forall a. FreeSemilattice a -> NonEmpty a
toNonEmpty (FreeSemilattice Set a
as) = [a] -> NonEmpty a
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([a] -> NonEmpty a) -> [a] -> NonEmpty a
forall a b. (a -> b) -> a -> b
$ Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
as

type instance AlgebraType0 FreeSemilattice a = Ord a
type instance AlgebraType  FreeSemilattice a = (Ord a, Semilattice a)
instance FreeAlgebra FreeSemilattice where
    returnFree :: forall a. a -> FreeSemilattice a
returnFree a
a = Set a -> FreeSemilattice a
forall a. Set a -> FreeSemilattice a
FreeSemilattice (Set a -> FreeSemilattice a) -> Set a -> FreeSemilattice a
forall a b. (a -> b) -> a -> b
$ a -> Set a
forall a. a -> Set a
Set.singleton a
a
    foldMapFree :: forall d a.
(AlgebraType FreeSemilattice d, AlgebraType0 FreeSemilattice a) =>
(a -> d) -> FreeSemilattice a -> d
foldMapFree a -> d
f (FreeSemilattice Set a
as) = NonEmpty d -> d
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty d -> d) -> NonEmpty d -> d
forall a b. (a -> b) -> a -> b
$ (a -> d) -> NonEmpty a -> NonEmpty d
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> d
f (NonEmpty a -> NonEmpty d) -> NonEmpty a -> NonEmpty d
forall a b. (a -> b) -> a -> b
$ [a] -> NonEmpty a
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([a] -> NonEmpty a) -> [a] -> NonEmpty a
forall a b. (a -> b) -> a -> b
$ Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
as