Op and predicate

universe-instances-extended/src/Data/Universe/Instances/Extended.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -7,13 +8,35 @@ module Data.Universe.Instances.Extended (
   ) where
 
 import Control.Comonad.Trans.Traced (TracedT (..))
-import Data.Functor.Rep (Representable (..), Co(..))
+import Data.Functor.Contravariant (Op (..), Predicate (..))
+import Data.Functor.Rep (Representable (..), Co (..))
+import Data.Map (Map)
+import Data.Set (Set)
 import Data.Universe.Class (Universe (..), Finite (..))
 import Data.Universe.Helpers (retag, Tagged, Natural)
 
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+#if MIN_VERSION_base(4,7,0)
+import Data.Coerce (coerce)
+#endif
+
+-- $setup
+--
+-- >>> import Data.Int (Int8)
+--
+-- -- Show (a -> b) instance (in universe-reverse-instances, but cannot depend on it here).
+-- >>> instance (Finite a, Show a, Show b) => Show (a -> b) where showsPrec n f = showsPrec n [(a, f a) | a <- universeF]
+--
+-- >>> :set -XStandaloneDeriving
+-- >>> deriving instance (Finite a, Show a) => Show (Predicate a)
+
 -- | We could do this:
 --
+-- @
 -- instance Universe (f a) => Universe (Co f a) where universe = map Rep universe
+-- @
 --
 -- However, since you probably only apply Rep to functors when you want to
 -- think of them as being representable, I think it makes sense to use an
@@ -29,9 +52,47 @@ instance (Representable f, Finite s, Ord s, Finite (Rep f), Ord (Rep f), Univers
   => Universe (TracedT s f a)
   where universe = map tabulate universe
 
+instance (Universe a, Finite b, Ord b) => Universe (Op a b) where
+#if MIN_VERSION_base(4,7,0)
+   universe = coerce (universe :: [b -> a])
+#else
+   universe = map Op universe
+#endif
+instance (Finite a, Ord a) => Universe (Predicate a) where
+  universe = map (Predicate . flip S.member) universe
+
 instance (Representable f, Finite (Rep f), Ord (Rep f), Finite a)
   => Finite (Co f a)
   where universeF = map tabulate universeF; cardinality = retag (cardinality :: Tagged (Rep (Co        f) -> a) Natural)
 instance (Representable f, Finite s, Ord s, Finite (Rep f), Ord (Rep f), Finite a)
   => Finite (TracedT s f a)
   where universeF = map tabulate universeF; cardinality = retag (cardinality :: Tagged (Rep (TracedT s f)) Natural)
+
+instance (Finite a, Finite b, Ord b) => Finite (Op a b) where
+  cardinality = retag (cardinality :: Tagged (b -> a) Natural)
+
+-- |
+--
+-- >>> mapM_ print (universe :: [Predicate Ordering])
+-- Predicate {getPredicate = [(LT,False),(EQ,False),(GT,False)]}
+-- Predicate {getPredicate = [(LT,True),(EQ,False),(GT,False)]}
+-- Predicate {getPredicate = [(LT,False),(EQ,True),(GT,False)]}
+-- Predicate {getPredicate = [(LT,True),(EQ,True),(GT,False)]}
+-- Predicate {getPredicate = [(LT,False),(EQ,False),(GT,True)]}
+-- Predicate {getPredicate = [(LT,True),(EQ,False),(GT,True)]}
+-- Predicate {getPredicate = [(LT,False),(EQ,True),(GT,True)]}
+-- Predicate {getPredicate = [(LT,True),(EQ,True),(GT,True)]}
+--
+-- Beware, function type universes are large...
+--
+-- >>> cardinality :: Tagged (Predicate Int8) Natural
+-- Tagged 115792089237316195423570985008687907853269984665640564039457584007913129639936
+--
+-- ... but thanks to laziness, you can expect at least few:
+--
+-- >>> let Predicate f : _ = universe :: [Predicate Int8]
+-- >>> f 0
+-- False
+--
+instance (Finite a, Ord a) => Finite (Predicate a) where
+  cardinality = retag (cardinality :: Tagged (Set a) Natural)

universe-instances-extended/universe-instances-extended.cabal

@@ -38,6 +38,19 @@ library
   exposed-modules:  Data.Universe.Instances.Extended
   build-depends:
       adjunctions    >=4.3 && <4.5
-    , base           >=4.3 && <4.13
     , comonad        >=4.2 && <5.1
+    , containers
     , universe-base  >=1.1 && <1.1.2
+
+  if impl(ghc >=8.6.1)
+    build-depends:   base           >=4.12 && <4.13
+
+  if impl(ghc  <8.0.1)
+    build-depends:   base           >=4.3  && <4.13
+                   , contravariant
+                   , semigroups
+
+  if impl(ghc >=8.0.1)
+    build-depends:   base           >=4.9  && <4.13
+                   , contravariant
+