{-# 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.Meet (
type (-)
, module Data.Semigroup.Meet
) where
import Control.Applicative
import Data.Bool
import Data.Either
import Data.Fixed
import Data.Int
import Data.Maybe
import Data.Prd
import Data.Ratio
import Data.Semigroup
import Data.Semigroup.Additive
import Data.Semigroup.Multiplicative
import Data.Word
import GHC.Generics (Generic)
import Numeric.Natural
import Prelude
( Eq(..), Ord, Show, Ordering(..), Applicative(..), Functor(..)
, Monoid(..), Semigroup(..), (.), ($), (<$>), Integer)
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Prelude as P
infixr 6 ∧
(∧) :: (Meet-Semigroup) a => a -> a -> a
a ∧ b = unMeet (Meet a <> Meet b)
{-# INLINE (∧) #-}
top :: (Meet-Monoid) a => a
top = unMeet mempty
{-# INLINE top #-}
meetLeq :: Eq a => (Meet-Semigroup) a => a -> a -> Bool
meetLeq x y = x ∧ y == x
meetGeq :: Eq a => (Meet-Semigroup) a => a -> a -> Bool
meetGeq x y = x ∧ y == y
pcompareMeet :: Eq a => (Meet-Semigroup) a => a -> a -> Maybe Ordering
pcompareMeet x y
| x == y = Just EQ
| x ∧ y == x && x /= y = Just LT
| x ∧ y == y && x /= y = Just GT
| otherwise = Nothing
type MeetSemilattice a = (Prd a, (Meet-Semigroup) a)
newtype Meet a = Meet { unMeet :: a } deriving (Eq, Generic, Ord, Show, Functor)
instance Applicative Meet where
pure = Meet
Meet f <*> Meet a = Meet (f a)
instance Semigroup (Min a) => Semigroup (Meet (Min a)) where
(<>) = liftA2 (<>)
instance (Meet-Semigroup) (Min a) => Semigroup (Additive (Min a)) where
(<>) = liftA2 (∧)
instance (Meet-Monoid) (Min a) => Monoid (Additive (Min a)) where
mempty = pure top
instance (Maximal a, Semigroup (Min a)) => Monoid (Meet (Min a)) where
mempty = pure $ Min maximal
instance (Meet-Semigroup) a => Semigroup (Meet (Max a)) where
Meet a <> Meet b = Meet $ liftA2 (∧) a b
instance (Meet-Monoid) a => Monoid (Meet (Max a)) where
mempty = Meet $ pure top
instance ((Meet-Semigroup) a, (Meet-Semigroup) b) => Semigroup (Meet (a, b)) where
Meet (x1, y1) <> Meet (x2, y2) = Meet (x1 ∧ x2, y1 ∧ y2)
instance (Meet-Semigroup) b => Semigroup (Meet (a -> b)) where
(<>) = liftA2 . liftA2 $ (∧)
{-# INLINE (<>) #-}
instance (Meet-Monoid) b => Monoid (Meet (a -> b)) where
mempty = pure . pure $ top
instance (Meet-Semigroup) a => Semigroup (Meet (Maybe a)) where
Meet Nothing <> _ = Meet Nothing
Meet (Just{}) <> Meet Nothing = Meet Nothing
Meet (Just x) <> Meet (Just y) = Meet . Just $ x ∧ y
instance (Meet-Monoid) a => Monoid (Meet (Maybe a)) where
mempty = Meet $ pure top
instance ((Meet-Semigroup) a, (Meet-Semigroup) b) => Semigroup (Meet (Either a b)) where
Meet (Right x) <> Meet (Right y) = Meet . Right $ x ∧ y
Meet (Right{}) <> y = y
Meet (Left x) <> Meet (Left y) = Meet . Left $ x ∧ y
Meet (x@Left{}) <> _ = Meet x
instance Ord a => Semigroup (Meet (Set.Set a)) where
(<>) = liftA2 Set.intersection
instance (Ord k, (Meet-Semigroup) a) => Semigroup (Meet (Map.Map k a)) where
(<>) = liftA2 (Map.intersectionWith (∧))
instance (Meet-Semigroup) a => Semigroup (Meet (IntMap.IntMap a)) where
(<>) = liftA2 (IntMap.intersectionWith (∧))
instance Semigroup (Meet IntSet.IntSet) where
(<>) = liftA2 IntSet.intersection
#define deriveMeetSemigroup(ty) \
instance Semigroup (Meet ty) where { \
a <> b = (P.min) <$> a <*> b \
; {-# INLINE (<>) #-} \
}
deriveMeetSemigroup(())
deriveMeetSemigroup(Bool)
deriveMeetSemigroup(Int)
deriveMeetSemigroup(Int8)
deriveMeetSemigroup(Int16)
deriveMeetSemigroup(Int32)
deriveMeetSemigroup(Int64)
deriveMeetSemigroup(Integer)
deriveMeetSemigroup(Word)
deriveMeetSemigroup(Word8)
deriveMeetSemigroup(Word16)
deriveMeetSemigroup(Word32)
deriveMeetSemigroup(Word64)
deriveMeetSemigroup(Natural)
deriveMeetSemigroup(Uni)
deriveMeetSemigroup(Deci)
deriveMeetSemigroup(Centi)
deriveMeetSemigroup(Milli)
deriveMeetSemigroup(Micro)
deriveMeetSemigroup(Nano)
deriveMeetSemigroup(Pico)
deriveMeetSemigroup(Rational)
deriveMeetSemigroup((Ratio Natural))
#define deriveMeetMonoid(ty) \
instance Monoid (Meet ty) where { \
mempty = pure maximal \
; {-# INLINE mempty #-} \
}
deriveMeetMonoid(())
deriveMeetMonoid(Bool)
deriveMeetMonoid(Int)
deriveMeetMonoid(Int8)
deriveMeetMonoid(Int16)
deriveMeetMonoid(Int32)
deriveMeetMonoid(Int64)
deriveMeetMonoid(Word)
deriveMeetMonoid(Word8)
deriveMeetMonoid(Word16)
deriveMeetMonoid(Word32)
deriveMeetMonoid(Word64)