universe-base-1.1.3.1/0000755000000000000000000000000007346545000012614 5ustar0000000000000000universe-base-1.1.3.1/LICENSE0000644000000000000000000000301207346545000013615 0ustar0000000000000000Copyright (c) 2013, Daniel Wagner All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Daniel Wagner nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. ! This software is provided by the copyright holders and contributors ! "as is" and any express or implied warranties, including, but not ! limited to, the implied warranties of merchantability and fitness for ! a particular purpose are disclaimed. In no event shall the copyright ! owner or contributors be liable for any direct, indirect, incidental, ! special, exemplary, or consequential damages (including, but not ! limited to, procurement of substitute goods or services; loss of use, ! data, or profits; or business interruption) however caused and on any ! theory of liability, whether in contract, strict liability, or tort ! (including negligence or otherwise) arising in any way out of the use ! of this software, even if advised of the possibility of such damage. universe-base-1.1.3.1/Setup.hs0000644000000000000000000000005607346545000014251 0ustar0000000000000000import Distribution.Simple main = defaultMain universe-base-1.1.3.1/changelog0000644000000000000000000000023307346545000014464 0ustar00000000000000001.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 universe-base-1.1.3.1/src/Data/Universe/0000755000000000000000000000000007346545000016054 5ustar0000000000000000universe-base-1.1.3.1/src/Data/Universe/Class.hs0000644000000000000000000005072207346545000017463 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns, TypeFamilies, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} #ifdef DEFAULT_SIGNATURES {-# LANGUAGE DefaultSignatures #-} #endif {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >=704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >=702 {-# LANGUAGE Trustworthy #-} #endif -- | 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 #if MIN_VERSION_OneTuple(0,4,0) import Data.Tuple.Solo (Solo (MkSolo)) #else import Data.Tuple.Solo (Solo (Solo)) #define MkSolo Solo #endif #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] #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. -- -- /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 universe-base-1.1.3.1/src/Data/Universe/Generic.hs0000644000000000000000000000447407346545000017775 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >=704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >=702 {-# LANGUAGE Trustworthy #-} #endif 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 #if __GLASGOW_HASKELL__ >= 804 -- $empty -- -- >>> :set -XEmptyDataDeriving -- -- >>> data Zero deriving (Show, Generic) -- >>> universeGeneric :: [Zero] -- [] #endif universe-base-1.1.3.1/src/Data/Universe/Helpers.hs0000644000000000000000000001136507346545000020020 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >=704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >=702 {-# LANGUAGE Trustworthy #-} #endif 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 (,)) [[]] universe-base-1.1.3.1/tests/0000755000000000000000000000000007346545000013756 5ustar0000000000000000universe-base-1.1.3.1/tests/Tests.hs0000644000000000000000000001100507346545000015411 0ustar0000000000000000{-# 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-1.1.3.1/universe-base.cabal0000644000000000000000000000561107346545000016353 0ustar0000000000000000name: universe-base version: 1.1.3.1 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: BSD3 license-file: LICENSE author: Daniel Wagner maintainer: me@dmwit.com copyright: 2014 Daniel Wagner category: Data build-type: Simple cabal-version: >=1.10 extra-source-files: changelog tested-with: GHC ==7.0.4 || ==7.4.2 || ==7.6.3 || ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4 || ==9.6.1 source-repository head type: git location: https://github.com/dmwit/universe source-repository this type: git location: https://github.com/dmwit/universe tag: instances-extended-1.1 library default-language: Haskell2010 hs-source-dirs: src exposed-modules: Data.Universe.Class Data.Universe.Helpers if impl(ghc >=7.2) exposed-modules: Data.Universe.Generic if impl(ghc <7.6) build-depends: ghc-prim other-extensions: BangPatterns CPP GADTs ScopedTypeVariables TypeFamilies build-depends: base >=4.3 && <4.19 , containers >=0.4.0.0 && <0.7 , tagged >=0.8.6.1 && <0.9 , transformers >=0.3.0.0 && <0.7 if impl(ghc >=7.10.3) build-depends: transformers >=0.4.2.0 if !impl(ghc >=7.10.3) build-depends: transformers-compat >=0.6.1 && <0.8 if !impl(ghc >=7.10) build-depends: nats >=1.1.2 && <1.2 , void >=0.7.3 && <0.8 if !impl(ghc >=8.0) build-depends: semigroups >=0.18.5 && <0.21 if impl(ghc >=7.4) cpp-options: -DDEFAULT_SIGNATURES other-extensions: DefaultSignatures if !impl(ghc >= 9.2) if impl(ghc >= 9.0) build-depends: ghc-prim else build-depends: OneTuple >=0.3 && <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.15 , universe-base if !impl(ghc >=7.10) build-depends: nats