{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Semigroup.Join where
import Control.Applicative
import Data.Bool
import Data.Maybe
import Data.Either
import Data.Prd
import Data.Semigroup
import Data.Semigroup.Additive
import Data.Semigroup.Meet
import GHC.Generics (Generic)
import Numeric.Natural
import Data.Word
import Data.Int
import Data.Fixed
import Prelude ( Eq(..), Ord(..), Show, Ordering(..), Applicative(..), Functor(..), Monoid(..), Semigroup(..), (.), ($), (<$>), Integer)
import qualified Prelude as P
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
infixr 5 ∨
(∨) :: (Join-Semigroup) a => a -> a -> a
a ∨ b = unJoin (Join a <> Join b)
{-# INLINE (∨) #-}
bottom :: (Join-Monoid) a => a
bottom = unJoin mempty
{-# INLINE bottom #-}
type JoinSemilattice a = (Prd a, (Join-Semigroup) a)
joinLeq :: Eq a => (Join-Semigroup) a => a -> a -> Bool
joinLeq x y = x ∨ y == y
joinGeq :: Eq a => (Join-Semigroup) a => a -> a -> Bool
joinGeq x y = x ∨ y == x
pcompareJoin :: Eq a => (Join-Semigroup) a => a -> a -> Maybe Ordering
pcompareJoin x y
| x == y = Just EQ
| x ∨ y == y && x /= y = Just LT
| x ∨ y == x && x /= y = Just GT
| otherwise = Nothing
newtype Join a = Join { unJoin :: a } deriving (Eq, Generic, Ord, Show, Functor)
instance Applicative Join where
pure = Join
Join f <*> Join a = Join (f a)
instance (Meet-Semigroup) a => Semigroup (Join (Down a)) where
(<>) = liftA2 . liftA2 $ (∧)
instance (Meet-Monoid) a => Monoid (Join (Down a)) where
mempty = pure . pure $ top
instance (Join-Semigroup) a => Semigroup (Meet (Down a)) where
(<>) = liftA2 . liftA2 $ (∨)
instance (Join-Monoid) a => Monoid (Meet (Down a)) where
mempty = pure . pure $ bottom
instance Semigroup (Max a) => Semigroup (Join (Max a)) where
(<>) = liftA2 (<>)
instance (Join-Semigroup) (Max a) => Semigroup (Additive (Max a)) where
(<>) = liftA2 (∨)
instance (Join-Monoid) (Max a) => Monoid (Additive (Max a)) where
mempty = pure bottom
instance (Minimal a, Semigroup (Max a)) => Monoid (Join (Max a)) where
mempty = pure $ Max minimal
instance ((Join-Semigroup) a, (Join-Semigroup) b) => Semigroup (Join (a, b)) where
Join (x1, y1) <> Join (x2, y2) = Join (x1 ∨ x2, y1 ∨ y2)
instance (Join-Semigroup) a => Semigroup (Join (Maybe a)) where
Join (Just x) <> Join (Just y) = Join . Just $ x ∨ y
Join (x@Just{}) <> _ = Join x
Join Nothing <> y = y
instance (Join-Semigroup) a => Monoid (Join (Maybe a)) where
mempty = Join Nothing
instance ((Join-Semigroup) a, (Join-Semigroup) b) => Semigroup (Join (Either a b)) where
Join (Right x) <> Join (Right y) = Join . Right $ x ∨ y
Join(x@Right{}) <> _ = Join x
Join (Left x) <> Join (Left y) = Join . Left $ x ∨ y
Join (Left _) <> y = y
instance Ord a => Semigroup (Join (Set.Set a)) where
(<>) = liftA2 Set.union
instance (Ord k, (Join-Semigroup) a) => Semigroup (Join (Map.Map k a)) where
(<>) = liftA2 (Map.unionWith (∨))
instance (Join-Semigroup) a => Semigroup (Join (IntMap.IntMap a)) where
(<>) = liftA2 (IntMap.unionWith (∨))
instance Semigroup (Join IntSet.IntSet) where
(<>) = liftA2 IntSet.union
instance Monoid (Join IntSet.IntSet) where
mempty = Join IntSet.empty
instance (Join-Semigroup) a => Monoid (Join (IntMap.IntMap a)) where
mempty = Join IntMap.empty
instance Ord a => Monoid (Join (Set.Set a)) where
mempty = Join Set.empty
instance (Ord k, (Join-Semigroup) a) => Monoid (Join (Map.Map k a)) where
mempty = Join Map.empty
#define deriveJoinSemigroup(ty) \
instance Semigroup (Join ty) where { \
a <> b = (P.max) <$> a <*> b \
; {-# INLINE (<>) #-} \
}
deriveJoinSemigroup(())
deriveJoinSemigroup(Bool)
deriveJoinSemigroup(Int)
deriveJoinSemigroup(Int8)
deriveJoinSemigroup(Int16)
deriveJoinSemigroup(Int32)
deriveJoinSemigroup(Int64)
deriveJoinSemigroup(Integer)
deriveJoinSemigroup(Word)
deriveJoinSemigroup(Word8)
deriveJoinSemigroup(Word16)
deriveJoinSemigroup(Word32)
deriveJoinSemigroup(Word64)
deriveJoinSemigroup(Natural)
deriveJoinSemigroup(Uni)
deriveJoinSemigroup(Deci)
deriveJoinSemigroup(Centi)
deriveJoinSemigroup(Milli)
deriveJoinSemigroup(Micro)
deriveJoinSemigroup(Nano)
deriveJoinSemigroup(Pico)
#define deriveJoinMonoid(ty) \
instance Monoid (Join ty) where { \
mempty = pure minimal \
; {-# INLINE mempty #-} \
}
deriveJoinMonoid(())
deriveJoinMonoid(Bool)
deriveJoinMonoid(Int)
deriveJoinMonoid(Int8)
deriveJoinMonoid(Int16)
deriveJoinMonoid(Int32)
deriveJoinMonoid(Int64)
deriveJoinMonoid(Word)
deriveJoinMonoid(Word8)
deriveJoinMonoid(Word16)
deriveJoinMonoid(Word32)
deriveJoinMonoid(Word64)
deriveJoinMonoid(Natural)