diff --git a/src/Algebra/Lattice/Dropped.hs b/src/Algebra/Lattice/Dropped.hs index ea43eab..2ec7fe1 100644 --- a/src/Algebra/Lattice/Dropped.hs +++ b/src/Algebra/Lattice/Dropped.hs @@ -29,6 +29,7 @@ import Prelude () import Prelude.Compat import Algebra.Lattice +import Algebra.PartialOrd import Control.DeepSeq import Control.Monad @@ -42,8 +43,8 @@ import GHC.Generics -- | Graft a distinct top onto an otherwise unbounded lattice. -- As a bonus, the top will be an absorbing element for the join. -data Dropped a = Top - | Drop a +data Dropped a = Drop a + | Top deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Functor, Foldable, Traversable #if __GLASGOW_HASKELL__ >= 706 , Generic1 @@ -65,6 +66,14 @@ instance NFData a => NFData (Dropped a) where instance Hashable a => Hashable (Dropped a) +instance PartialOrd a => PartialOrd (Dropped a) where + leq _ Top = True + leq Top _ = False + leq (Drop x) (Drop y) = leq x y + comparable Top _ = True + comparable _ Top = True + comparable (Drop x) (Drop y) = comparable x y + instance JoinSemiLattice a => JoinSemiLattice (Dropped a) where Top \/ _ = Top _ \/ Top = Top diff --git a/src/Algebra/Lattice/Levitated.hs b/src/Algebra/Lattice/Levitated.hs index 5939f07..3271f4d 100644 --- a/src/Algebra/Lattice/Levitated.hs +++ b/src/Algebra/Lattice/Levitated.hs @@ -29,6 +29,7 @@ import Prelude () import Prelude.Compat import Algebra.Lattice +import Algebra.PartialOrd import Control.DeepSeq import Control.Monad @@ -43,9 +44,9 @@ import GHC.Generics -- | Graft a distinct top and bottom onto an otherwise unbounded lattice. -- The top is the absorbing element for the join, and the bottom is the absorbing -- element for the meet. -data Levitated a = Top +data Levitated a = Bottom | Levitate a - | Bottom + | Top deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Functor, Foldable, Traversable #if __GLASGOW_HASKELL__ >= 706 , Generic1 @@ -69,6 +70,18 @@ instance NFData a => NFData (Levitated a) where instance Hashable a => Hashable (Levitated a) +instance PartialOrd a => PartialOrd (Levitated a) where + leq _ Top = True + leq Top _ = False + leq Bottom _ = True + leq _ Bottom = False + leq (Levitate x) (Levitate y) = leq x y + comparable Top _ = True + comparable _ Top = True + comparable Bottom _ = True + comparable _ Bottom = True + comparable (Levitate x) (Levitate y) = comparable x y + instance JoinSemiLattice a => JoinSemiLattice (Levitated a) where Top \/ _ = Top _ \/ Top = Top diff --git a/src/Algebra/Lattice/Lifted.hs b/src/Algebra/Lattice/Lifted.hs index 81cc95f..0f2820e 100644 --- a/src/Algebra/Lattice/Lifted.hs +++ b/src/Algebra/Lattice/Lifted.hs @@ -29,6 +29,7 @@ import Prelude () import Prelude.Compat import Algebra.Lattice +import Algebra.PartialOrd import Control.DeepSeq import Control.Monad @@ -42,8 +43,8 @@ import GHC.Generics -- | Graft a distinct bottom onto an otherwise unbounded lattice. -- As a bonus, the bottom will be an absorbing element for the meet. -data Lifted a = Lift a - | Bottom +data Lifted a = Bottom + | Lift a deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Functor, Foldable, Traversable #if __GLASGOW_HASKELL__ >= 706 , Generic1 @@ -65,6 +66,14 @@ instance NFData a => NFData (Lifted a) where instance Hashable a => Hashable (Lifted a) +instance PartialOrd a => PartialOrd (Lifted a) where + leq Bottom _ = True + leq _ Bottom = False + leq (Lift x) (Lift y) = leq x y + comparable Bottom _ = True + comparable _ Bottom = True + comparable (Lift x) (Lift y) = comparable x y + instance JoinSemiLattice a => JoinSemiLattice (Lifted a) where Lift x \/ Lift y = Lift (x \/ y) Bottom \/ lift_y = lift_y diff --git a/src/Algebra/Lattice/Op.hs b/src/Algebra/Lattice/Op.hs index 9a25653..11e920e 100644 --- a/src/Algebra/Lattice/Op.hs +++ b/src/Algebra/Lattice/Op.hs @@ -11,6 +11,11 @@ #else {-# LANGUAGE Safe #-} #endif +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +#endif + ---------------------------------------------------------------------------- -- | -- Module : Algebra.Lattice.Op @@ -34,6 +39,7 @@ import Control.DeepSeq import Control.Monad import Data.Data import Data.Hashable +import Data.Ord import GHC.Generics -- @@ -43,11 +49,17 @@ import GHC.Generics -- | The opposite lattice of a given lattice. That is, switch -- meets and joins. newtype Op a = Op { getOp :: a } - deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic, Functor, Foldable, Traversable + deriving ( Eq, Show, Read, Data, Typeable, Generic, Functor, Foldable, Traversable #if __GLASGOW_HASKELL__ >= 706 , Generic1 #endif ) +#if __GLASGOW_HASKELL__ >= 806 + deriving Ord via (Down a) +#else +instance Ord a => Ord (Op a) where + compare (Op a) (Op b) = compare b a +#endif instance Applicative Op where pure = return