diff --git a/Data/Universe.hs b/Data/Universe.hs --- a/Data/Universe.hs +++ b/Data/Universe.hs @@ -1,197 +1,11 @@ -{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies #-} -#ifdef DEFAULT_SIGNATURES -{-# LANGUAGE DefaultSignatures #-} -#endif -module Data.Universe - ( -- | Bottoms are ignored for this entire module: only fully-defined inhabitants are considered inhabitants. - Universe(..) - , Finite(..) +{-# LANGUAGE NoImplicitPrelude #-} +module Data.Universe ( + -- | A convenience module that imports the submodules @Instances.Base@, + -- @Instances.Extended@, and @Instances.Trans@ to provide instances of + -- 'Universe' and 'Finite' for a wide variety of types. + Universe(..), Finite(..) ) where -import Control.Monad -import Data.Int -import Data.Map ((!), fromList) -import Data.Monoid -import Data.Ratio -import Data.Universe.Helpers -import Data.Void -import Data.Word - --- for representable stuff! -import Control.Comonad.Trans.Traced -import Control.Monad.Identity -import Control.Monad.Reader -import Control.Monad.Trans.Identity -import Data.Functor.Compose -import Data.Functor.Rep -import qualified Data.Functor.Product as Functor - --- | 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 - -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 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 Void where universe = [] - -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 All where universe = map All universe -instance Universe Any where universe = map Any universe -instance Universe a => Universe (Sum a) where universe = map Sum universe -instance Universe a => Universe (Product a) where universe = map Product universe -instance Universe a => Universe (Dual a) where universe = map Dual universe -instance Universe a => Universe (First a) where universe = map First universe -instance Universe a => Universe (Last a) where universe = map Last universe - --- 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') --- --- Compiling this code with -O2 and doing some informal tests seems to --- show that positiveRationals and positiveRationals2 have almost exactly --- the same efficiency for generating the entire list (e.g. the times for --- finding the sum of the first 100000 rationals are pretty much --- indistinguishable). positiveRationals is still the clear winner for --- generating just the nth rational for some particular n -- some simple --- experiments seem to indicate that doing this with positiveRationals2 --- scales linearly while with positiveRationals it scales sub-linearly, --- as expected. --- --- Surprisingly, replacing % with :% in positiveRationals seems to make --- no appreciable difference. -positiveRationals :: [Ratio Integer] -positiveRationals = 1 : map lChild positiveRationals +++ map rChild positiveRationals where - lChild frac = numerator frac % (numerator frac + denominator frac) - rChild frac = (numerator frac + denominator frac) % denominator frac - -instance a ~ Integer => Universe (Ratio a) where universe = 0 : map negate positiveRationals +++ positiveRationals - --- could change the Ord constraint to an Eq one, but come on, how many finite --- types can't be ordered? -instance (Finite a, Ord a, Universe b) => Universe (a -> b) where - universe = map tableToFunction tables where - tables = choices [universe | _ <- monoUniverse] - tableToFunction = (!) . fromList . zip monoUniverse - monoUniverse = universeF - -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 (Functor.Product f g a) where universe = [Functor.Pair f g | (f, g) <- universe +*+ universe] - --- We could do this: --- --- instance Universe (f a) => Universe (Co f a) where universe = map Rep universe --- --- However, since you probably only apply Rep to functors when you want to --- think of them as being representable, I think it makes sense to use an --- instance based on the representable-ness rather than the inherent --- universe-ness. --- --- Please complain if you disagree! -instance (Representable f, Finite (Rep f), Ord (Rep f), Universe a) - => Universe (Co f a) - where universe = map tabulate universe -instance (Representable f, Finite s, Ord s, Finite (Rep f), Ord (Rep f), Universe a) - => Universe (TracedT s f a) - where universe = map tabulate universe - -instance Finite () -instance Finite Bool -instance Finite Char -instance Finite Ordering -instance Finite Int -instance Finite Int8 -instance Finite Int16 -instance Finite Int32 -instance Finite Int64 -instance Finite Word -instance Finite Word8 -instance Finite Word16 -instance Finite Word32 -instance Finite Word64 -instance Finite Void -instance Finite a => Finite (Maybe a ) -instance (Finite a, Finite b) => Finite (Either a b) where universeF = map Left universe ++ map Right universe - -instance (Finite a, Finite b) => Finite (a, b) where universeF = liftM2 (,) universeF universeF -instance (Finite a, Finite b, Finite c) => Finite (a, b, c) where universeF = liftM3 (,,) universeF universeF universeF -instance (Finite a, Finite b, Finite c, Finite d) => Finite (a, b, c, d) where universeF = liftM4 (,,,) universeF universeF universeF universeF -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 - -instance Finite All where universeF = map All universeF -instance Finite Any where universeF = map Any universeF -instance Finite a => Finite (Sum a) where universeF = map Sum universeF -instance Finite a => Finite (Product a) where universeF = map Product universeF -instance Finite a => Finite (Dual a) where universeF = map Dual universeF -instance Finite a => Finite (First a) where universeF = map First universeF -instance Finite a => Finite (Last a) where universeF = map Last universeF - -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 - -instance Finite a => Finite (Identity a) where universeF = map Identity universeF -instance Finite (f a) => Finite (IdentityT f a) where universeF = map IdentityT universeF -instance (Finite e, Ord e, Finite (m a)) => Finite (ReaderT e m a) where universeF = map ReaderT universeF -instance Finite (f (g a)) => Finite (Compose f g a) where universeF = map Compose universeF -instance (Finite (f a), Finite (g a)) => Finite (Functor.Product f g a) where universeF = liftM2 Functor.Pair universeF universeF - -instance (Representable f, Finite (Rep f), Ord (Rep f), Finite a) - => Finite (Co f a) - where universeF = map tabulate universeF -instance (Representable f, Finite s, Ord s, Finite (Rep f), Ord (Rep f), Finite a) - => Finite (TracedT s f a) - where universeF = map tabulate universeF - --- to add as people ask for them: --- instance (Eq a, Finite a) => Finite (Endo a) (+Universe) --- instance (Ord a, Universe a) => Universe (Set a) (+Finite) --- instance (Ord k, Universe k, Universe v) => Universe (Map k v) (+Finite) +import Data.Universe.Instances.Base +import Data.Universe.Instances.Extended +import Data.Universe.Instances.Trans diff --git a/Data/Universe/Helpers.hs b/Data/Universe/Helpers.hs deleted file mode 100644 --- a/Data/Universe/Helpers.hs +++ /dev/null @@ -1,69 +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 xss = go ([], xss) where - go (b, [] ) = interleave b - go (b, e:es) = [h | h:_ <- b] ++ go (e:[t | _:t <- b],es) - --- | 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/Data/Universe/Instances.hs b/Data/Universe/Instances.hs --- a/Data/Universe/Instances.hs +++ b/Data/Universe/Instances.hs @@ -1,11 +1,8 @@ -module Data.Universe.Instances ( - -- | A convenience module that imports the submodules @Eq@, @Ord@, @Show@, - -- @Read@, and @Traversable@ to provide instances of these classes for - -- functions over finite inputs. +{-# LANGUAGE NoImplicitPrelude #-} + -- the extra space is to make the error line up in a pretty way +module Data.Universe.Instances {-# DEPRECATED " Use `Data.Universe.Instances.Reverse' instead." #-} ( + -- | A deprecated convenience module. New applications should import + -- "Data.Universe.Instances.Reverse" instead. ) where -import Data.Universe.Instances.Eq -import Data.Universe.Instances.Ord -import Data.Universe.Instances.Show -import Data.Universe.Instances.Read -import Data.Universe.Instances.Traversable +import Data.Universe.Instances.Reverse () diff --git a/Data/Universe/Instances/Eq.hs b/Data/Universe/Instances/Eq.hs deleted file mode 100644 --- a/Data/Universe/Instances/Eq.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Data.Universe.Instances.Eq ( - -- | An 'Eq' instance for functions, given the input is 'Finite' and the - -- output is 'Eq'. Compares pointwise. - ) where - -import Data.Monoid -import Data.Universe - -instance (Finite a, Eq b) => Eq (a -> b) where - f == g = and [f x == g x | x <- universeF] diff --git a/Data/Universe/Instances/Ord.hs b/Data/Universe/Instances/Ord.hs deleted file mode 100644 --- a/Data/Universe/Instances/Ord.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Data.Universe.Instances.Ord ( - -- | An 'Ord' instance for functions, given the input is 'Finite' and the - -- output is 'Ord'. Compares pointwise, with higher priority to inputs - -- that appear earlier in 'universeF'. - ) where - -import Data.Monoid -import Data.Universe -import Data.Universe.Instances.Eq - -instance (Finite a, Ord b) => Ord (a -> b) where - f `compare` g = mconcat [f x `compare` g x | x <- universeF] diff --git a/Data/Universe/Instances/Read.hs b/Data/Universe/Instances/Read.hs deleted file mode 100644 --- a/Data/Universe/Instances/Read.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Data.Universe.Instances.Read ( - -- | A 'Read' instance for functions, given the input is 'Finite' and - -- 'Ord' and both the input and output are 'Read'. - ) where - -import Data.Map (fromList, (!)) -import Data.Universe - --- actually, the "Finite a" part of the context wouldn't be inferred if you --- asked GHC -- but it's kind of hopeless otherwise! -instance (Finite a, Ord a, Read a, Read b) => Read (a -> b) where - readsPrec n s = [((fromList v !), s') | (v, s') <- readsPrec n s] diff --git a/Data/Universe/Instances/Reverse.hs b/Data/Universe/Instances/Reverse.hs new file mode 100644 --- /dev/null +++ b/Data/Universe/Instances/Reverse.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Data.Universe.Instances.Reverse ( + -- | A convenience module that imports the sibling modules @Eq@, @Ord@, + -- @Show@, @Read@, and @Traversable@ to provide instances of these classes + -- for functions over finite inputs. + Eq(..), Ord(..), Show(..), Read(..), Foldable(..), Traversable(..) + ) where + +import Data.Universe.Instances.Eq +import Data.Universe.Instances.Ord +import Data.Universe.Instances.Show +import Data.Universe.Instances.Read +import Data.Universe.Instances.Traversable diff --git a/Data/Universe/Instances/Show.hs b/Data/Universe/Instances/Show.hs deleted file mode 100644 --- a/Data/Universe/Instances/Show.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Data.Universe.Instances.Show ( - -- | A 'Show' instance for functions, given the input is 'Finite' and both - -- the input and output are 'Show'. - ) where - -import Data.Universe - -instance (Finite a, Show a, Show b) => Show (a -> b) where - showsPrec n f = showsPrec n [(a, f a) | a <- universeF] diff --git a/Data/Universe/Instances/Traversable.hs b/Data/Universe/Instances/Traversable.hs deleted file mode 100644 --- a/Data/Universe/Instances/Traversable.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Data.Universe.Instances.Traversable ( - -- | A 'Foldable' instance for functions, given the input is 'Finite', and - -- a 'Traversable' instance for functions, given the input is 'Ord' and - -- 'Finite'. - ) where - -import Control.Applicative -import Data.Foldable -import Data.Map ((!), fromList) -import Data.Monoid -import Data.Traversable -import Data.Universe - -instance Finite e => Foldable ((->) e) where - foldMap f g = mconcat $ map (f . g) universeF - -instance (Ord e, Finite e) => Traversable ((->) e) where - sequenceA f = (!) . fromList <$> sequenceA [(,) x <$> f x | x <- universeF] diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -17,14 +17,14 @@ 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. +! 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. diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,6 @@ +0.6: +* split package into small pieces: + * six packages, all dependencies of a top-level "universe" package + * a base installation requires many fewer dependencies +* moved Data.Universe.Instances to D.U.I.Base for consistency +* modules export the classes that they export instances of diff --git a/universe.cabal b/universe.cabal --- a/universe.cabal +++ b/universe.cabal @@ -1,39 +1,31 @@ name: universe -version: 0.5 +version: 1.0 synopsis: Classes for types where we know all the values description: Munge finite and recursively enumerable types +homepage: https://github.com/dmwit/universe license: BSD3 license-file: LICENSE author: Daniel Wagner -maintainer: daniel@wagner-home.com -copyright: 2013 Daniel Wagner +maintainer: me@dmwit.com +copyright: Daniel Wagner 2014 category: Data build-type: Simple -cabal-version: >=1.8 +cabal-version: >=1.10 +extra-source-files: changelog source-repository head type: git location: https://github.com/dmwit/universe source-repository this type: git location: https://github.com/dmwit/universe - tag: 0.5 + tag: 1.0 library exposed-modules: Data.Universe, - Data.Universe.Helpers, Data.Universe.Instances, - Data.Universe.Instances.Eq, - Data.Universe.Instances.Ord, - Data.Universe.Instances.Read, - Data.Universe.Instances.Show, - Data.Universe.Instances.Traversable - if impl(ghc >= 7.4) - cpp-options: -DDEFAULT_SIGNATURES - build-depends: base >=4 && <5 , - comonad >=4 && <4.1, - containers >=0.1 && <1 , - keys >=0.1 && <4 , - mtl >=1.0 && <2.2, - adjunctions >=4 && <4.1, - transformers >=0.2 && <0.4, - void >=0.1 && <0.7 + Data.Universe.Instances.Reverse + build-depends: universe-instances-base >=1.0 && <1.1, + universe-instances-extended >=1.0 && <1.1, + universe-reverse-instances >=1.0 && <1.1, + universe-instances-trans >=1.0 && <1.1 + default-language: Haskell2010