{-# 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 idempontent, 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 (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
min :: FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
$cmin :: forall a.
Ord a =>
FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
max :: FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
$cmax :: forall a.
Ord a =>
FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
>= :: 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
$c< :: forall a. Ord a => FreeSemilattice a -> FreeSemilattice a -> Bool
compare :: FreeSemilattice a -> FreeSemilattice a -> Ordering
$ccompare :: forall a.
Ord a =>
FreeSemilattice a -> FreeSemilattice a -> Ordering
Ord, FreeSemilattice a -> FreeSemilattice a -> Bool
forall a. Eq a => FreeSemilattice a -> FreeSemilattice a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FreeSemilattice a -> FreeSemilattice a -> Bool
$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
Eq, Int -> FreeSemilattice a -> ShowS
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
showList :: [FreeSemilattice a] -> ShowS
$cshowList :: forall a. Show a => [FreeSemilattice a] -> ShowS
show :: FreeSemilattice a -> String
$cshow :: forall a. Show a => FreeSemilattice a -> String
showsPrec :: Int -> FreeSemilattice a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FreeSemilattice a -> ShowS
Show, NonEmpty (FreeSemilattice a) -> FreeSemilattice a
FreeSemilattice a -> FreeSemilattice a -> 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
stimes :: forall b. Integral b => b -> FreeSemilattice a -> FreeSemilattice a
$cstimes :: forall a b.
(Ord a, Integral b) =>
b -> FreeSemilattice a -> FreeSemilattice a
sconcat :: NonEmpty (FreeSemilattice a) -> FreeSemilattice a
$csconcat :: forall a.
Ord a =>
NonEmpty (FreeSemilattice a) -> FreeSemilattice a
<> :: FreeSemilattice a -> FreeSemilattice a -> FreeSemilattice a
$c<> :: forall a.
Ord a =>
FreeSemilattice a -> 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 = forall a. Set a -> FreeSemilattice a
FreeSemilattice forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NE.toList

toNonEmpty :: FreeSemilattice a -> NonEmpty a
toNonEmpty :: forall a. FreeSemilattice a -> NonEmpty a
toNonEmpty (FreeSemilattice Set a
as) = forall a. [a] -> NonEmpty a
NE.fromList forall a b. (a -> b) -> a -> b
$ 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 = forall a. Set a -> FreeSemilattice a
FreeSemilattice forall a b. (a -> b) -> a -> b
$ 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) = forall a. Semigroup a => NonEmpty a -> a
sconcat forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> d
f forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set a
as