universe-base 1.0.2.1 → 1.1.4
raw patch · 8 files changed
Files
- Data/Universe/Class.hs +0/−30
- Data/Universe/Helpers.hs +0/−81
- changelog +15/−0
- src/Data/Universe/Class.hs +454/−0
- src/Data/Universe/Generic.hs +77/−0
- src/Data/Universe/Helpers.hs +124/−0
- tests/Tests.hs +124/−0
- universe-base.cabal +83/−25
− Data/Universe/Class.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE CPP #-}-#ifdef DEFAULT_SIGNATURES-{-# LANGUAGE DefaultSignatures #-}-#endif-module Data.Universe.Class- ( -- | Bottoms are ignored for this entire module: only fully-defined inhabitants are considered inhabitants.- Universe(..)- , Finite(..)- ) where--import Data.Universe.Helpers---- | Creating an instance of this class is a declaration that your type is--- recursively enumerable (and that 'universe' is that enumeration). In--- particular, you promise that any finite inhabitant has a finite index in--- 'universe', and that no inhabitant appears at two different finite indices.-class Universe a where- universe :: [a]-#ifdef DEFAULT_SIGNATURES- default universe :: (Enum a, Bounded a) => [a]- universe = universeDef-#endif---- | Creating an instance of this class is a declaration that your 'universe'--- eventually ends. Minimal definition: no methods defined. By default,--- @universeF = universe@, but for some types (like 'Either') the 'universeF'--- method may have a more intuitive ordering.-class Universe a => Finite a where- universeF :: [a]- universeF = universe
− Data/Universe/Helpers.hs
@@ -1,81 +0,0 @@-module Data.Universe.Helpers (- -- | This module is for functions that are useful for writing instances,- -- but not necessarily for using them (and hence are not exported by the- -- main module to avoid cluttering up the namespace).- module Data.Universe.Helpers- ) where--import Data.List---- | For many types, the 'universe' should be @[minBound .. maxBound]@;--- 'universeDef' makes it easy to make such types an instance of 'Universe' via--- the snippet------ > instance Universe Foo where universe = universeDef-universeDef :: (Bounded a, Enum a) => [a]-universeDef = [minBound .. maxBound]---- | Fair n-way interleaving: given a finite number of (possibly infinite)--- lists, produce a single list such that whenever @v@ has finite index in one--- of the input lists, @v@ also has finite index in the output list. No list's--- elements occur more frequently (on average) than another's.-interleave :: [[a]] -> [a]-interleave = concat . transpose---- | Unfair n-way interleaving: given a possibly infinite number of (possibly--- infinite) lists, produce a single list such that whenever @v@ has finite--- index in an input list at finite index, @v@ also has finite index in the--- output list. Elements from lists at lower index occur more frequently, but--- not exponentially so.-diagonal :: [[a]] -> [a]-diagonal = concat . diagonals---- | Like 'diagonal', but expose a tiny bit more (non-semantic) information:--- if you lay out the input list in two dimensions, each list in the result--- will be one of the diagonals of the input. In particular, each element of--- the output will be a list whose elements are each from a distinct input--- list.-diagonals :: [[a]] -> [[a]]-diagonals = tail . go [] where- -- it is critical for some applications that we start producing answers- -- before inspecting es_- go b es_ = [h | h:_ <- b] : case es_ of- [] -> transpose ts- e:es -> go (e:ts) es- where ts = [t | _:t <- b]---- | Fair 2-way interleaving.-(+++) :: [a] -> [a] -> [a]-xs +++ ys = interleave [xs,ys]---- | Slightly unfair 2-way Cartesian product: given two (possibly infinite)--- lists, produce a single list such that whenever @v@ and @w@ have finite--- indices in the input lists, @(v,w)@ has finite index in the output list.--- Lower indices occur as the @fst@ part of the tuple more frequently, but not--- exponentially so.-(+*+) :: [a] -> [b] -> [(a,b)]-[] +*+ _ = [] -- special case: don't want to construct an infinite list of empty lists to pass to diagonal-xs +*+ ys = diagonal [[(x, y) | x <- xs] | y <- ys]---- | Slightly unfair n-way Cartesian product: given a finite number of--- (possibly infinite) lists, produce a single list such that whenever @vi@ has--- finite index in list i for each i, @[v1, ..., vn]@ has finite index in the--- output list.-choices :: [[a]] -> [[a]]-choices = foldr ((map (uncurry (:)) .) . (+*+)) [[]]---- | Very unfair 2-way Cartesian product: same guarantee as the slightly unfair--- one, except that lower indices may occur as the @fst@ part of the tuple--- exponentially more frequently. This mainly exists as a specification to test--- against.-unfairCartesianProduct :: [a] -> [b] -> [(a,b)]-unfairCartesianProduct _ [] = [] -- special case: don't want to walk down xs forever hoping one of them will produce a nonempty thing-unfairCartesianProduct xs ys = go xs ys where- go (x:xs) ys = map ((,) x) ys +++ go xs ys- go [] ys = []---- | Very unfair n-way Cartesian product: same guarantee as the slightly unfair--- one, but not as good in the same sense that the very unfair 2-way product is--- worse than the slightly unfair 2-way product. Mainly for testing purposes.-unfairChoices :: [[a]] -> [[a]]-unfairChoices = foldr ((map (uncurry (:)) .) . unfairCartesianProduct) [[]]
+ changelog view
@@ -0,0 +1,15 @@+1.1.4++* Support GHC-9.6.5..9.10.1++1.1.3++* Add Solo instances++1.1.2++* Explicitly mark modules as Safe or Trustworthy++1.1.1++* Make Data.Universe.Helpers.cartesianProduct more generative
+ src/Data/Universe/Class.hs view
@@ -0,0 +1,454 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns, TypeFamilies, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE Safe #-}+-- | Bottoms are ignored for this entire module:+-- only fully-defined inhabitants are considered inhabitants.+module Data.Universe.Class+ ( Universe(..)+ , Finite(..)+ ) where++import Data.Universe.Helpers++import Control.Applicative (Const (..))+import Control.Monad (liftM2, liftM3, liftM4, liftM5)+import Control.Monad.Trans.Identity (IdentityT (..))+import Control.Monad.Trans.Reader (ReaderT (..))+import Data.Functor.Compose (Compose (..))+import Data.Functor.Identity (Identity (..))+import Data.Functor.Product (Product (..))+import Data.Functor.Sum (Sum (..))+import Data.Int (Int, Int8, Int16, Int32, Int64)+import Data.List (genericLength)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map ((!), fromList)+import Data.Proxy (Proxy (..))+import Data.Ratio (Ratio, numerator, denominator, (%))+import Data.Tagged (Tagged (..), retag)+import Data.Void (Void)+import Data.Word (Word, Word8, Word16, Word32, Word64)+import GHC.Real (Ratio (..))+import Numeric.Natural (Natural)++import qualified Data.Monoid as Mon+import qualified Data.Semigroup as Semi+import qualified Data.Set as Set+import qualified Data.Map as Map++#if MIN_VERSION_base(4,18,0)+import Data.Tuple (Solo (MkSolo))+#elif MIN_VERSION_base(4,16,0)+import Data.Tuple (Solo (Solo))+#define MkSolo Solo+#elif MIN_VERSION_base(4,15,0)+import GHC.Tuple (Solo (Solo))+#define MkSolo Solo+#else+import Data.Tuple.Solo (Solo (MkSolo))+#endif++-- $setup+-- >>> import Data.List+-- >>> import Data.Universe.Helpers+--+-- -- 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]++-- | Creating an instance of this class is a declaration that your type is+-- recursively enumerable (and that 'universe' is that enumeration). In+-- particular, you promise that any finite inhabitant has a finite index in+-- 'universe', and that no inhabitant appears at two different finite indices.+--+-- Well-behaved instance should produce elements lazily.+--+-- /Laws:/+--+-- @+-- 'elem' x 'universe' -- any inhabitant has a finite index+-- let pfx = 'take' n 'universe' -- any finite prefix of universe has unique elements+-- in 'length' pfx = 'length' (nub pfx)+-- @+class Universe a where+ universe :: [a]+ default universe :: (Enum a, Bounded a) => [a]+ universe = universeDef++-- | Creating an instance of this class is a declaration that your 'universe'+-- eventually ends. Minimal definition: no methods defined. By default,+-- @universeF = universe@, but for some types (like 'Either') the 'universeF'+-- method may have a more intuitive ordering.+--+-- /Laws:/+--+-- @+-- 'elem' x 'universeF' -- any inhabitant has a finite index+-- 'length' ('filter' (== x) 'universeF') == 1 -- should terminate+-- (\xs -> 'cardinality' xs == 'genericLength' xs) 'universeF'+-- @+--+-- /Note:/ @'elemIndex' x 'universe' == 'elemIndex' x 'universeF'@+-- may not hold for all types, though the laws imply that `universe`+-- is a permutation of `universeF`.+--+-- >>> elemIndex (Left True :: Either Bool Bool) universe+-- Just 2+--+-- >>> elemIndex (Left True :: Either Bool Bool) universeF+-- Just 1+--+class Universe a => Finite a where+ universeF :: [a]+ universeF = universe++ cardinality :: Tagged a Natural+ cardinality = Tagged (genericLength (universeF :: [a]))++-------------------------------------------------------------------------------+-- Base+-------------------------------------------------------------------------------++instance Universe () where universe = universeDef+instance Universe Bool where universe = universeDef+instance Universe Char where universe = universeDef+instance Universe Ordering where universe = universeDef+instance Universe Integer where universe = [0, -1..] +++ [1..]+instance Universe Natural where universe = [0..]+instance Universe Int where universe = universeDef+instance Universe Int8 where universe = universeDef+instance Universe Int16 where universe = universeDef+instance Universe Int32 where universe = universeDef+instance Universe Int64 where universe = universeDef+instance Universe Word where universe = universeDef+instance Universe Word8 where universe = universeDef+instance Universe Word16 where universe = universeDef+instance Universe Word32 where universe = universeDef+instance Universe Word64 where universe = universeDef++instance (Universe a, Universe b) => Universe (Either a b) where universe = map Left universe +++ map Right universe+instance Universe a => Universe (Maybe a ) where universe = Nothing : map Just universe++instance (Universe a, Universe b) => Universe (a, b) where universe = universe +*+ universe+instance (Universe a, Universe b, Universe c) => Universe (a, b, c) where universe = [(a,b,c) | ((a,b),c) <- universe +*+ universe +*+ universe]+instance (Universe a, Universe b, Universe c, Universe d) => Universe (a, b, c, d) where universe = [(a,b,c,d) | (((a,b),c),d) <- universe +*+ universe +*+ universe +*+ universe]+instance (Universe a, Universe b, Universe c, Universe d, Universe e) => Universe (a, b, c, d, e) where universe = [(a,b,c,d,e) | ((((a,b),c),d),e) <- universe +*+ universe +*+ universe +*+ universe +*+ universe]++instance Universe a => Universe [a] where+ universe = diagonal $ [[]] : [[h:t | t <- universe] | h <- universe]++instance Universe a => Universe (NonEmpty a) where+ universe = diagonal [[h :| t | t <- universe] | h <- universe]++instance Universe Mon.All where universe = map Mon.All universe+instance Universe Mon.Any where universe = map Mon.Any universe+instance Universe a => Universe (Mon.Sum a) where universe = map Mon.Sum universe+instance Universe a => Universe (Mon.Product a) where universe = map Mon.Product universe+instance Universe a => Universe (Mon.Dual a) where universe = map Mon.Dual universe+instance Universe a => Universe (Mon.First a) where universe = map Mon.First universe+instance Universe a => Universe (Mon.Last a) where universe = map Mon.Last universe++-------------------------------------------------------------------------------+-- Semi+-------------------------------------------------------------------------------++instance Universe a => Universe (Semi.Max a) where universe = map Semi.Max universe+instance Universe a => Universe (Semi.Min a) where universe = map Semi.Min universe+instance Universe a => Universe (Semi.First a) where universe = map Semi.First universe+instance Universe a => Universe (Semi.Last a) where universe = map Semi.Last universe++-------------------------------------------------------------------------------+-- Rational+-------------------------------------------------------------------------------++-- see http://mathlesstraveled.com/2008/01/07/recounting-the-rationals-part-ii-fractions-grow-on-trees/+--+-- also, Brent Yorgey writes:+--+-- positiveRationals2 :: [Ratio Integer]+-- positiveRationals2 = iterate' next 1+-- where+-- next x = let (n,y) = properFraction x in recip (fromInteger n + 1 - y)+-- iterate' f x = let x' = f x in x' `seq` (x : iterate' f x')+--+-- But this turns out to be substantially slower.+--+-- We used to use+--+-- positiveRationals =+-- 1 : map lChild positiveRationals +++ map rChild positiveRationals+--+-- where lChild and rChild produced the left and right child of each fraction,+-- respectively. Aside from building unnecessary thunks (thanks to the lazy+-- map), this had the problem of calculating each sum at least four times:+-- once for a denominator, a second time for the following numerator, and then two+-- more times on the other side of the Calkin-Wilf tree. That doesn't+-- sound too bad, since in practice the integers will be small. But taking each+-- sum allocates a constructor to wrap the result, and that's not+-- free. We can avoid the problem with very little additional effort by+-- interleaving manually. Negative rationals, unfortunately, don't get the+-- full benefit of sharing here, but we can still share their denominators.++infixr 5 :<+data Stream a = !a :< Stream a++-- All the rational numbers on the left side of the Calkin-Wilf tree,+-- in breadth-first order.+leftSideStream :: Integral a => Stream (Ratio a)+leftSideStream = 1 :% 2 :< go leftSideStream+ where+ go (x :< xs) = lChild :< rChild :< go xs+ where+ nd = numerator x + denominator x+ !lChild = numerator x :% nd+ !rChild = nd :% denominator x++instance RationalUniverse a => Universe (Ratio a) where+ universe = rationalUniverse++class RationalUniverse a where+ rationalUniverse :: [Ratio a]++instance RationalUniverse Integer where+ -- Why force the negations and reciprocals? This is more expensive if we+ -- ignore most of the result: it allocates four words (generally) for a+ -- negative element rather than two words for a thunk that will evaluate to+ -- one. But it's presumably more common to use the elements in a universe+ -- than to leap over them, so we optimize for the former case. We+ -- interleave manually to avoid allocating four intermediate lists.+ rationalUniverse = 0 : 1 : (-1) : go leftSideStream+ where+ go (x@(xn :% xd) :< xs) =+ let !nx = -x+ !rx = xd :% xn+ !nrx = -rx+ in x : rx : nx : nrx : go xs++instance RationalUniverse Natural where+ rationalUniverse = 0 : 1 : go leftSideStream+ where+ go (x@(xn :% xd) :< xs) =+ let !rx = xd :% xn+ in x : rx : go xs++-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------++-- |+-- >>> mapM_ print (universe :: [Bool -> Bool])+-- [(False,False),(True,False)]+-- [(False,False),(True,True)]+-- [(False,True),(True,False)]+-- [(False,True),(True,True)]+--+instance (Finite a, Ord a, Universe b) => Universe (a -> b) where+ -- could change the Ord constraint to an Eq one, but come on, how many finite+ -- types can't be ordered?+ universe = map tableToFunction tables where+ tables = choices [universe | _ <- monoUniverse]+ tableToFunction = (!) . fromList . zip monoUniverse+ monoUniverse = universeF++instance Finite () where cardinality = 1+instance Finite Bool where cardinality = 2+instance Finite Char where cardinality = 1114112+instance Finite Ordering where cardinality = 3+instance Finite Int where cardinality = fromIntegral (maxBound :: Int) - fromIntegral (minBound :: Int) + 1+instance Finite Int8 where cardinality = 2^8+instance Finite Int16 where cardinality = 2^16+instance Finite Int32 where cardinality = 2^32+instance Finite Int64 where cardinality = 2^64+instance Finite Word where cardinality = fromIntegral (maxBound :: Word) - fromIntegral (minBound :: Word) + 1+instance Finite Word8 where cardinality = Tagged $ 2^8+instance Finite Word16 where cardinality = Tagged $ 2^16+instance Finite Word32 where cardinality = Tagged $ 2^32+instance Finite Word64 where cardinality = Tagged $ 2^64++instance Finite a => Finite (Maybe a ) where+ cardinality = fmap succ (retag (cardinality :: Tagged a Natural))+instance (Finite a, Finite b) => Finite (Either a b) where+ universeF = map Left universe ++ map Right universe+ cardinality = liftM2 (\a b -> a + b)+ (retag (cardinality :: Tagged a Natural))+ (retag (cardinality :: Tagged b Natural))++instance (Finite a, Finite b) => Finite (a, b) where+ universeF = liftM2 (,) universeF universeF+ cardinality = liftM2 (\a b -> a * b)+ (retag (cardinality :: Tagged a Natural))+ (retag (cardinality :: Tagged b Natural))++instance (Finite a, Finite b, Finite c) => Finite (a, b, c) where+ universeF = liftM3 (,,) universeF universeF universeF+ cardinality = liftM3 (\a b c -> a * b * c)+ (retag (cardinality :: Tagged a Natural))+ (retag (cardinality :: Tagged b Natural))+ (retag (cardinality :: Tagged c Natural))++instance (Finite a, Finite b, Finite c, Finite d) => Finite (a, b, c, d) where+ universeF = liftM4 (,,,) universeF universeF universeF universeF+ cardinality = liftM4 (\a b c d -> a * b * c * d)+ (retag (cardinality :: Tagged a Natural))+ (retag (cardinality :: Tagged b Natural))+ (retag (cardinality :: Tagged c Natural))+ (retag (cardinality :: Tagged d Natural))++instance (Finite a, Finite b, Finite c, Finite d, Finite e) => Finite (a, b, c, d, e) where+ universeF = liftM5 (,,,,) universeF universeF universeF universeF universeF+ cardinality = liftM5 (\a b c d e -> a * b * c * d * e)+ (retag (cardinality :: Tagged a Natural))+ (retag (cardinality :: Tagged b Natural))+ (retag (cardinality :: Tagged c Natural))+ (retag (cardinality :: Tagged d Natural))+ (retag (cardinality :: Tagged e Natural))++instance Finite Mon.All where universeF = map Mon.All universeF; cardinality = 2+instance Finite Mon.Any where universeF = map Mon.Any universeF; cardinality = 2+instance Finite a => Finite (Mon.Sum a) where universeF = map Mon.Sum universeF; cardinality = retagWith Mon.Sum cardinality+instance Finite a => Finite (Mon.Product a) where universeF = map Mon.Product universeF; cardinality = retagWith Mon.Product cardinality+instance Finite a => Finite (Mon.Dual a) where universeF = map Mon.Dual universeF; cardinality = retagWith Mon.Dual cardinality+instance Finite a => Finite (Mon.First a) where universeF = map Mon.First universeF; cardinality = retagWith Mon.First cardinality+instance Finite a => Finite (Mon.Last a) where universeF = map Mon.Last universeF; cardinality = retagWith Mon.Last cardinality++instance Finite a => Finite (Semi.Max a) where universeF = map Semi.Max universeF; cardinality = retagWith Semi.Max cardinality+instance Finite a => Finite (Semi.Min a) where universeF = map Semi.Min universeF; cardinality = retagWith Semi.Min cardinality+instance Finite a => Finite (Semi.First a) where universeF = map Semi.First universeF; cardinality = retagWith Semi.First cardinality+instance Finite a => Finite (Semi.Last a) where universeF = map Semi.Last universeF; cardinality = retagWith Semi.Last cardinality++-- |+-- >>> mapM_ print (universeF :: [Bool -> Bool])+-- [(False,False),(True,False)]+-- [(False,False),(True,True)]+-- [(False,True),(True,False)]+-- [(False,True),(True,True)]+--+-- >>> cardinality :: Tagged (Bool -> Ordering) Natural+-- Tagged 9+--+-- >>> cardinality :: Tagged (Ordering -> Bool) Natural+-- Tagged 8+--+instance (Ord a, Finite a, Finite b) => Finite (a -> b) where+ universeF = map tableToFunction tables where+ tables = sequence [universeF | _ <- monoUniverse]+ tableToFunction = (!) . fromList . zip monoUniverse+ monoUniverse = universeF+ cardinality = liftM2 (^)+ (retag (cardinality :: Tagged b Natural))+ (retag (cardinality :: Tagged a Natural))++-- to add when somebody asks for it: instance (Eq a, Finite a) => Finite (Endo a) (+Universe)++-------------------------------------------------------------------------------+-- void+-------------------------------------------------------------------------------++instance Universe Void where universe = []+instance Finite Void where cardinality = 0++-------------------------------------------------------------------------------+-- tagged+-------------------------------------------------------------------------------++instance Universe (Proxy a) where universe = [Proxy]+instance Finite (Proxy a) where cardinality = 1++instance Universe a => Universe (Tagged b a) where universe = map Tagged universe+instance Finite a => Finite (Tagged b a) where cardinality = retagWith Tagged cardinality++-------------------------------------------------------------------------------+-- containers+-------------------------------------------------------------------------------++-- |+-- >>> import qualified Data.Set as Set+-- >>> mapM_ print (universe :: [Set.Set Bool])+-- fromList []+-- fromList [False]+-- fromList [True]+-- fromList [False,True]+--+instance (Ord a, Universe a) => Universe (Set.Set a) where+ universe = Set.empty : go universe+ where+ go [] = []+ go (x:xs) = Set.singleton x : inter (go xs)+ where+ -- Probably more efficient than using (+++)+ inter [] = []+ inter (y:ys) = y : Set.insert x y : inter ys++instance (Ord a, Finite a) => Finite (Set.Set a) where+ cardinality = retag (fmap (2 ^) (cardinality :: Tagged a Natural))++-- |+-- >>> import qualified Data.Map as Map+-- >>> mapM_ print (universe :: [Map.Map Bool Bool])+-- fromList []+-- fromList [(True,False)]+-- fromList [(False,False)]+-- fromList [(True,True)]+-- fromList [(False,False),(True,False)]+-- fromList [(False,True)]+-- fromList [(False,False),(True,True)]+-- fromList [(False,True),(True,False)]+-- fromList [(False,True),(True,True)]+--+--+instance (Ord k, Finite k, Universe v) => Universe (Map.Map k v) where+ universe = map tableToFunction tables where+ tables = choices [universe | _ <- monoUniverse]+ tableToFunction = fromList' . zip monoUniverse+ monoUniverse = universeF+ fromList' xs = fromList [ (k,v) | (k, Just v) <- xs ]++instance (Ord k, Finite k, Finite v) => Finite (Map.Map k v) where+ universeF = map tableToFunction tables where+ tables = sequence [universeF | _ <- monoUniverse]+ tableToFunction = fromList' . zip monoUniverse+ monoUniverse = universeF+ fromList' xs = fromList [ (k,v) | (k, Just v) <- xs ]++ cardinality = liftM2 (\b a -> (1 + b) ^ a)+ (retag (cardinality :: Tagged v Natural))+ (retag (cardinality :: Tagged k Natural))++-------------------------------------------------------------------------------+-- transformers+-------------------------------------------------------------------------------++instance Universe a => Universe (Const a b) where universe = map Const universe+instance Finite a => Finite (Const a b) where universeF = map Const universeF; cardinality = retagWith Const cardinality++instance Universe a => Universe (Identity a) where universe = map Identity universe+instance Universe (f a) => Universe (IdentityT f a) where universe = map IdentityT universe+instance (Finite e, Ord e, Universe (m a)) => Universe (ReaderT e m a) where universe = map ReaderT universe+instance Universe (f (g a)) => Universe (Compose f g a) where universe = map Compose universe+instance (Universe (f a), Universe (g a)) => Universe (Product f g a) where universe = [Pair f g | (f, g) <- universe +*+ universe]+instance (Universe (f a), Universe (g a)) => Universe (Sum f g a) where universe = map InL universe +++ map InR universe++instance Finite a => Finite (Identity a) where universeF = map Identity universeF; cardinality = retagWith Identity cardinality+instance Finite (f a) => Finite (IdentityT f a) where universeF = map IdentityT universeF; cardinality = retagWith IdentityT cardinality+instance (Finite e, Ord e, Finite (m a)) => Finite (ReaderT e m a) where universeF = map ReaderT universeF; cardinality = retagWith ReaderT cardinality+instance Finite (f (g a)) => Finite (Compose f g a) where universeF = map Compose universeF; cardinality = retagWith Compose cardinality+instance (Finite (f a), Finite (g a)) => Finite (Product f g a) where+ universeF = liftM2 Pair universeF universeF+ cardinality = liftM2 (*)+ (retag (cardinality :: Tagged (f a) Natural))+ (retag (cardinality :: Tagged (g a) Natural))+instance (Finite (f a), Finite (g a)) => Finite (Sum f g a) where+ universeF = map InL universe ++ map InR universe+ cardinality = liftM2 (+)+ (retag (cardinality :: Tagged (f a) Natural))+ (retag (cardinality :: Tagged (g a) Natural))++-------------------------------------------------------------------------------+-- OneTuple+-------------------------------------------------------------------------------++-- @since 1.1.3+instance Universe a => Universe (Solo a) where universe = map MkSolo universe++-- @since 1.1.3+instance Finite a => Finite (Solo a) where universeF = map MkSolo universeF; cardinality = retagWith MkSolo cardinality
+ src/Data/Universe/Generic.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}+module Data.Universe.Generic where++import GHC.Generics++import Data.Universe.Class+import Data.Universe.Helpers++-- $setup+-- >>> :set -XDeriveGeneric+-- >>> import GHC.Generics+ +class GUniverse f where+ guniverse :: [f a]++instance GUniverseSum f => GUniverse (M1 i c f) where+ guniverse = map M1 $ interleave guniverseSum++class GUniverseSum f where+ guniverseSum :: [[f a]]++instance GUniverseSum V1 where+ guniverseSum = []++instance (GUniverseSum f, GUniverseSum g) => GUniverseSum (f :+: g) where+ guniverseSum = map (map L1) guniverseSum ++ map (map R1) guniverseSum++instance GUniverseProduct f => GUniverseSum (M1 i c f) where+ guniverseSum = [map M1 guniverseProduct]++class GUniverseProduct f where+ guniverseProduct :: [f a]++instance GUniverseProduct U1 where+ guniverseProduct = [U1]++-- This is not completely fair; but enough.+instance (GUniverseProduct f, GUniverseProduct g) => GUniverseProduct (f :*: g) where+ guniverseProduct = cartesianProduct (:*:) guniverseProduct guniverseProduct++instance GUniverseProduct f => GUniverseProduct (M1 i c f) where+ guniverseProduct = map M1 guniverseProduct++instance Universe a => GUniverseProduct (K1 r a) where+ guniverseProduct = map K1 universe++-- |+--+-- >>> data One = One deriving (Show, Generic)+-- >>> universeGeneric :: [One] +-- [One]+--+-- >>> data Big = B0 Bool Bool | B1 Bool deriving (Show, Generic)+-- >>> universeGeneric :: [Big]+-- [B0 False False,B1 False,B0 False True,B1 True,B0 True False,B0 True True]+--+-- >>> universeGeneric :: [Maybe Ordering]+-- [Nothing,Just LT,Just EQ,Just GT]+--+-- >>> take 10 (universeGeneric :: [Either Integer Integer])+-- [Left 0,Right 0,Left 1,Right 1,Left (-1),Right (-1),Left 2,Right 2,Left (-2),Right (-2)]+--+-- >>> take 10 (universeGeneric :: [(Integer, Integer, Integer)])+-- [(0,0,0),(0,0,1),(1,0,0),(0,1,0),(1,0,1),(-1,0,0),(0,0,-1),(1,1,0),(-1,0,1),(2,0,0)]+--+universeGeneric :: (Generic a, GUniverse (Rep a)) => [a]+universeGeneric = map to guniverse ++-- $empty+--+-- >>> :set -XEmptyDataDeriving+--+-- >>> data Zero deriving (Show, Generic)+-- >>> universeGeneric :: [Zero]+-- []
+ src/Data/Universe/Helpers.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE Safe #-}+module Data.Universe.Helpers (+ -- | This module is for functions that are useful for writing instances,+ -- but not necessarily for using them (and hence are not exported by the+ -- main module to avoid cluttering up the namespace).++ -- * Building lists+ universeDef,+ interleave,+ diagonal,+ diagonals,+ (+++),+ cartesianProduct,+ (+*+),+ (<+*+>),+ choices,++ -- * Building cardinalities+ -- | These functions are handy for inheriting the definition of+ -- 'Data.Universe.Class.cardinality' in a newtype instance. For example,+ -- one might write+ --+ -- > newtype Foo = Foo Bar+ -- > instance Finite Foo where cardinality = retagWith Foo cardinality+ retagWith,+ retag,+ Tagged (..),+ Natural,++ -- * Debugging+ -- | These functions exist primarily as a specification to test against.+ unfairCartesianProduct,+ unfairChoices+ ) where++import Data.List+import Data.Tagged (Tagged (..), retag)+import Numeric.Natural (Natural)++-- | For many types, the 'universe' should be @[minBound .. maxBound]@;+-- 'universeDef' makes it easy to make such types an instance of 'Universe' via+-- the snippet+--+-- > instance Universe Foo where universe = universeDef+universeDef :: (Bounded a, Enum a) => [a]+universeDef = [minBound .. maxBound]++-- | Fair n-way interleaving: given a finite number of (possibly infinite)+-- lists, produce a single list such that whenever @v@ has finite index in one+-- of the input lists, @v@ also has finite index in the output list. No list's+-- elements occur more frequently (on average) than another's.+interleave :: [[a]] -> [a]+interleave = concat . transpose++-- | Unfair n-way interleaving: given a possibly infinite number of (possibly+-- infinite) lists, produce a single list such that whenever @v@ has finite+-- index in an input list at finite index, @v@ also has finite index in the+-- output list. Elements from lists at lower index occur more frequently, but+-- not exponentially so.+diagonal :: [[a]] -> [a]+diagonal = concat . diagonals++-- | Like 'diagonal', but expose a tiny bit more (non-semantic) information:+-- if you lay out the input list in two dimensions, each list in the result+-- will be one of the diagonals of the input. In particular, each element of+-- the output will be a list whose elements are each from a distinct input+-- list.+diagonals :: [[a]] -> [[a]]+diagonals = tail . go [] where+ -- it is critical for some applications that we start producing answers+ -- before inspecting es_+ go b es_ = [h | h:_ <- b] : case es_ of+ [] -> transpose ts+ e:es -> go (e:ts) es+ where ts = [t | _:t <- b]++-- | Fair 2-way interleaving.+(+++) :: [a] -> [a] -> [a]+xs +++ ys = interleave [xs,ys]++-- | Slightly unfair 2-way Cartesian product: given two (possibly infinite)+-- lists, produce a single list such that whenever @v@ and @w@ have finite+-- indices in the input lists, @(v,w)@ has finite index in the output list.+-- Lower indices occur as the @fst@ part of the tuple more frequently, but not+-- exponentially so.+cartesianProduct :: (a -> b -> c) -> [a] -> [b] -> [c]+-- special case: don't want to construct an infinite list of empty lists to pass to diagonal+cartesianProduct _ [] _ = []+cartesianProduct f xs ys = diagonal [[f x y | x <- xs] | y <- ys]++-- | @'cartesianProduct' (,)@+(+*+) :: [a] -> [b] -> [(a,b)]+(+*+) = cartesianProduct (,)++-- | A '+*+' with application.+--+-- @'cartesianProduct' ($)@+(<+*+>) :: [a -> b] -> [a] -> [b]+(<+*+>) = cartesianProduct ($)++-- | Slightly unfair n-way Cartesian product: given a finite number of+-- (possibly infinite) lists, produce a single list such that whenever @vi@ has+-- finite index in list i for each i, @[v1, ..., vn]@ has finite index in the+-- output list.+choices :: [[a]] -> [[a]]+choices = foldr (cartesianProduct (:)) [[]]++retagWith :: (a -> b) -> Tagged a x -> Tagged b x+retagWith _ (Tagged n) = Tagged n++-- | Very unfair 2-way Cartesian product: same guarantee as the slightly unfair+-- one, except that lower indices may occur as the @fst@ part of the tuple+-- exponentially more frequently.+unfairCartesianProduct :: (a -> b -> c) -> [a] -> [b] -> [c]+unfairCartesianProduct _ _ [] = [] -- special case: don't want to walk down xs forever hoping one of them will produce a nonempty thing+unfairCartesianProduct f xs ys = go xs ys where+ go (x:xs) ys = map (f x) ys +++ go xs ys+ go [] ys = []++-- | Very unfair n-way Cartesian product: same guarantee as the slightly unfair+-- one, but not as good in the same sense that the very unfair 2-way product is+-- worse than the slightly unfair 2-way product.+unfairChoices :: [[a]] -> [[a]]+unfairChoices = foldr ((map (uncurry (:)) .) . unfairCartesianProduct (,)) [[]]
+ tests/Tests.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main (main) where++import Control.Exception (evaluate)+import Data.List (elemIndex)+import Data.Int (Int8)+import Test.QuickCheck+import Data.Universe.Class (Universe(..), Finite(..))+import Data.Universe.Helpers (interleave, choices)+import Data.Set (Set)+import Data.Ratio (Ratio, (%))+import Numeric.Natural (Natural)+import System.Timeout (timeout)++import qualified Data.Set as Set++data P a = P++-------------------------------------------------------------------------------+-- Universe laws+-------------------------------------------------------------------------------++universeLaw :: (Eq a, Show a, Arbitrary a, Universe a) => P a -> a -> Property+universeLaw _ x = counterexample (show x) (elem x universe)++universeProdLaw+ :: forall a. (Ord a, Show a, Arbitrary a, Universe a)+ => P a -> NonNegative Int -> Property+universeProdLaw _ (NonNegative n) = label (show $ div n 10) $+ let pfx = take n universe :: [a]+ in length pfx === nubLength pfx++nubLength :: Ord a => [a] -> Int+nubLength = Set.size . Set.fromList++universeLaws :: (Ord a, Show a, Arbitrary a, Universe a) => P a -> Property+universeLaws p = universeLaw p .&&. universeProdLaw p++rationalLaw :: Gen Property+-- We have to keep the numbers fairly small here to avoid needing to+-- dig too deep.+rationalLaw = do+ n <- choose (-19, 19 :: Integer)+ d <- choose (1, 19)+ return $ let nd = n % d in counterexample (show nd) (elem nd universe)++natRatioLaw :: Gen Property+natRatioLaw = do+ n <- choose (0, 19 :: Int)+ d <- choose (1, 19 :: Int)+ return $ let nd = (fromIntegral n :: Natural) % fromIntegral d+ in counterexample (show nd) (elem nd universe)++-------------------------------------------------------------------------------+-- Finite laws+-------------------------------------------------------------------------------++finiteLaw1 :: (Eq a, Show a, Arbitrary a, Finite a) => P a -> a -> Property+finiteLaw1 _ x = counterexample (show x) (elem x universeF)++finiteLaw2 :: (Eq a, Show a, Arbitrary a, Finite a) => P a -> a -> Property+finiteLaw2 _ x = length (filter (== x) universeF) === 1++finiteLaws :: (Ord a, Show a, Arbitrary a, Finite a) => P a -> Property+finiteLaws p = universeLaws p .&&. finiteLaw1 p .&&. finiteLaw2 p++-------------------------------------------------------------------------------+-- Special examples+-------------------------------------------------------------------------------++eitherExample :: Property+eitherExample = once $ u /= f+ where+ u = elemIndex (Left True :: Either Bool Bool) universe+ f = elemIndex (Left True :: Either Bool Bool) universeF++choicesLazinessProperty :: IO ()+choicesLazinessProperty = do+ v <- timeout oneSecond (evaluate (s !! 1))+ case v of+ Just _ -> putStrLn "OK"+ Nothing -> putStrLn "ERROR: Timeout while evaluating a sneaky, self-referential collection of helpers"+ where+ -- generate strings from the grammar S -> x | S S+ s = interleave [["x"], map concat $ choices [s, s]]+ oneSecond = 1000000++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++main :: IO ()+main = do+ -- Note: checking on 'Int' is bad idea as it's definition is 'universeDef',+ -- i.e. it takes lots of time to get to small numbers!+ quickCheck eitherExample+ quickCheck $ universeLaws (P :: P Integer)+ quickCheck $ universeLaws (P :: P Natural')+ quickCheck $ rationalLaw+ quickCheck $ natRatioLaw+ quickCheck $ universeProdLaw (P :: P Rational)+ quickCheck $ universeProdLaw (P :: P (Ratio Natural))+ quickCheck $ finiteLaws (P :: P Char)+ quickCheck $ finiteLaws (P :: P (Maybe Int8))+ quickCheck $ finiteLaws (P :: P (Either Int8 Int8))+ -- Even this is a bad idea:+ -- quickCheck $ universeLaw (P :: P [Bool])++ quickCheck $ universeProdLaw (P :: P (Set Integer))+ quickCheck $ finiteLaws (P :: P (Set ()))+ quickCheck $ finiteLaws (P :: P (Set Bool))+ quickCheck $ finiteLaws (P :: P (Set (Maybe Bool)))+ quickCheck $ finiteLaws (P :: P (Set (Set (Maybe Bool))))++ choicesLazinessProperty++-------------------------------------------------------------------------------+-- Natural'+-------------------------------------------------------------------------------++newtype Natural' = Natural' Natural deriving (Eq, Ord, Show)+instance Universe Natural' where universe = map Natural' universe+instance Arbitrary Natural' where+ arbitrary = fmap (Natural' . fromInteger . abs) arbitrary
universe-base.cabal view
@@ -1,28 +1,86 @@-name: universe-base-version: 1.0.2.1-synopsis: A class for finite and recursively enumerable types and some helper functions for enumerating them-homepage: https://github.com/dmwit/universe-license: BSD3-license-file: LICENSE-author: Daniel Wagner-maintainer: me@dmwit.com-copyright: 2014 Daniel Wagner-category: Data-build-type: Simple-cabal-version: >=1.10+cabal-version: 2.2+name: universe-base+version: 1.1.4+synopsis: A class for finite and recursively enumerable types.+description:+ A class for finite and recursively enumerable types and some helper functions for enumerating them.+ .+ @+ class Universe a where universe :: [a]+ class Universe a => Finite a where universeF :: [a]; universeF = universe+ @+ .+ This is slim package definiting only the type-classes and instances+ for types in GHC boot libraries.+ For more instances check @universe-instances-*@ packages.++homepage: https://github.com/dmwit/universe+license: BSD-3-Clause+license-file: LICENSE+author: Daniel Wagner+maintainer: me@dmwit.com+copyright: 2014 Daniel Wagner+category: Data+build-type: Simple+extra-source-files: changelog+tested-with:+ GHC ==8.6.5+ || ==8.8.4+ || ==8.10.7+ || ==9.0.2+ || ==9.2.8+ || ==9.4.8+ || ==9.6.5+ || ==9.8.2+ || ==9.10.1+ source-repository head- type: git- location: https://github.com/dmwit/universe-source-repository this- type: git- location: https://github.com/dmwit/universe- tag: base-1.0.2.1+ type: git+ location: https://github.com/dmwit/universe+ subdir: universe-base library- exposed-modules: Data.Universe.Class, Data.Universe.Helpers- other-extensions: CPP- build-depends: base >=4 && <5- default-language: Haskell2010- if impl(ghc >= 7.4)- cpp-options: -DDEFAULT_SIGNATURES- other-extensions: DefaultSignatures+ default-language: Haskell2010+ hs-source-dirs: src+ exposed-modules:+ Data.Universe.Class+ Data.Universe.Helpers+ Data.Universe.Generic++ other-extensions:+ BangPatterns+ DefaultSignatures+ GADTs+ ScopedTypeVariables+ TypeFamilies++ build-depends:+ base >=4.12 && <4.21+ , containers >=0.6.0.1 && <0.8+ , tagged >=0.8.8 && <0.9+ , transformers >=0.5.6.2 && <0.7++ if !impl(ghc >=9.2)+ if impl(ghc >=9.0)+ build-depends: ghc-prim++ else+ build-depends: OneTuple >=0.4.2 && <0.5++ if impl(ghc >=9.0)+ -- these flags may abort compilation with GHC-8.10+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295+ ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode++test-suite tests+ default-language: Haskell2010+ other-extensions: ScopedTypeVariables+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ hs-source-dirs: tests+ ghc-options: -Wall+ build-depends:+ base+ , containers+ , QuickCheck >=2.8.2 && <2.16+ , universe-base