Add tests for the relationship between leq and compare

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

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

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

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