diff --git a/Data/Universe/Class.hs b/Data/Universe/Class.hs deleted file mode 100644 --- a/Data/Universe/Class.hs +++ /dev/null @@ -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 diff --git a/Data/Universe/Helpers.hs b/Data/Universe/Helpers.hs deleted file mode 100644 --- a/Data/Universe/Helpers.hs +++ /dev/null @@ -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) [[]] diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -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 diff --git a/src/Data/Universe/Class.hs b/src/Data/Universe/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Universe/Class.hs @@ -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 diff --git a/src/Data/Universe/Generic.hs b/src/Data/Universe/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Universe/Generic.hs @@ -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] +-- [] diff --git a/src/Data/Universe/Helpers.hs b/src/Data/Universe/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Data/Universe/Helpers.hs @@ -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 (,)) [[]] diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -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 diff --git a/universe-base.cabal b/universe-base.cabal --- a/universe-base.cabal +++ b/universe-base.cabal @@ -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