diff --git a/base/Data/Universe/Class.hs b/base/Data/Universe/Class.hs index 98118d6..1ccb95b 100644 --- a/base/Data/Universe/Class.hs +++ b/base/Data/Universe/Class.hs @@ -1,12 +1,23 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} #ifdef DEFAULT_SIGNATURES {-# LANGUAGE DefaultSignatures #-} #endif +-- | Bottoms are ignored for this entire module: only fully-defined inhabitants +-- are considered inhabitants. module Data.Universe.Class - ( -- | Bottoms are ignored for this entire module: only fully-defined inhabitants are considered inhabitants. - Universe(..) - , Finite(..) - ) where + ( + -- * Classes + Universe(..) + , Finite(..) + , Univ + -- * Lists + , universe + , universeF + ) where + +import Prelude.Compat +import Data.Foldable (toList) import Data.Universe.Helpers @@ -25,12 +36,15 @@ import Data.Universe.Helpers -- in 'length' pfx = 'length' (nub pfx) -- @ class Universe a where - universe :: [a] + universeUniv :: Univ a #ifdef DEFAULT_SIGNATURES - default universe :: (Enum a, Bounded a) => [a] - universe = universeDef + default universeUniv :: (Enum a, Bounded a) => Univ a + universeUniv = universeDef #endif +universe :: Universe a => [a] +universe = toList universeUniv + -- | 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' @@ -54,5 +68,8 @@ class Universe a where -- Just 1 -- @ class Universe a => Finite a where - universeF :: [a] - universeF = universe + universeUnivF :: Univ a + universeUnivF = universeUniv + +universeF :: Finite a => [a] +universeF = toList universeUnivF diff --git a/base/Data/Universe/Helpers.hs b/base/Data/Universe/Helpers.hs index b6f8c1e..24b1977 100644 --- a/base/Data/Universe/Helpers.hs +++ b/base/Data/Universe/Helpers.hs @@ -1,34 +1,103 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | 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 ( - -- | 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 + -- * 'Univ' type + Univ, + emptyUniv, + univCons, + univUncons, + univFromList, + (+++), + (+*+), + choices, + -- * Default definitions + universeDef, + ) where -import Data.List +import Prelude.Compat + +import Control.Applicative (Alternative (..)) +import Data.Foldable (toList) +import Data.Typeable (Typeable) +import Data.Semigroup (Semigroup (..)) +import Data.List.Compat + +-- | Type synonym representing container of elements. +-- +-- 'Univ' has one invariant: all elements in @'Univ' a@ are distinct. +-- +-- See +newtype Univ a = Univ { getUniv :: [a] } + deriving (Functor, Foldable, Traversable, Typeable) + +-- | This instance is useful in debugging, outputs at most 50 first items. +instance Show a => Show (Univ a) where + show = show . take 50 . toList + +instance Applicative Univ where + pure = Univ . return + f <*> x = uncurry ($) <$> f +*+ x + +instance Monad Univ where + return = Univ . return + m >>= f = diagonal $ fmap f m + +instance Alternative Univ where + empty = mempty + (<|>) = (<>) + +emptyUniv :: Univ a +emptyUniv = Univ [] + +univCons :: a -> Univ a -> Univ a +univCons x xs = pure x <> xs + +univUncons :: Univ a -> Maybe (a, Univ a) +univUncons (Univ []) = Nothing +univUncons (Univ (x:xs)) = Just (x, Univ xs) + +-- | Create 'Univ' from potentially infinite list. +univFromList :: [a] -> Univ a +univFromList = Univ + +-- | Appending is fair interleaving, associativity rule holds if one consider equality on `Univ` as sets. +instance Semigroup (Univ a) where + (<>) = (+++) + +instance Monoid (Univ a) where + mempty = emptyUniv + mappend = (+++) -- | 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] +universeDef :: (Bounded a, Enum a) => Univ a +universeDef = Univ [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 +interleave :: [Univ a] -> Univ a +interleave = Univ . concat . transpose . fmap getUniv -- | 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 +-- +-- TODO: `join`, check use-cases +diagonal :: Univ (Univ a) -> Univ a +diagonal = Univ . concat . diagonals . fmap getUniv . getUniv -- | 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 @@ -37,15 +106,15 @@ diagonal = concat . diagonals -- 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] + -- 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] +(+++) :: Univ a -> Univ a -> Univ a xs +++ ys = interleave [xs,ys] -- | Slightly unfair 2-way Cartesian product: given two (possibly infinite) @@ -53,29 +122,36 @@ xs +++ ys = interleave [xs,ys] -- 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] +(+*+) :: Univ a -> Univ b -> Univ (a,b) +Univ xs +*+ Univ ys = Univ $ unfairProduct xs ys + +unfairProduct :: [a] -> [b] -> [(a,b)] +unfairProduct [] _ = [] -- special case: don't want to construct an infinite list of empty lists to pass to diagonal +unfairProduct xs ys = getUniv $ diagonal $ Univ [Univ [(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 (:)) .) . (+*+)) [[]] +-- +-- TODO: this is probably the same as 'unfairCartesianProduct' atm. +choices :: [Univ a] -> Univ [a] +choices = sequenceA +{- -- | 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 = [] +unfairCartesianProduct :: Univ a -> Univ b -> Univ (a,b) +unfairCartesianProduct _ (Univ []) = emptyUniv -- special case: don't want to walk down xs forever hoping one of them will produce a nonempty thing +unfairCartesianProduct (Univ xs') ys = go xs' where + go (x:xs) = fmap ((,) x) ys +++ go xs + go [] = emptyUniv -- | 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/base/universe-base.cabal b/base/universe-base.cabal index 4b9767c..437b293 100644 --- a/base/universe-base.cabal +++ b/base/universe-base.cabal @@ -1,5 +1,5 @@ name: universe-base -version: 1.0.2.1 +version: 2 synopsis: A class for finite and recursively enumerable types and some helper functions for enumerating them homepage: https://github.com/dmwit/universe license: BSD3 @@ -30,8 +30,17 @@ source-repository this library exposed-modules: Data.Universe.Class, Data.Universe.Helpers other-extensions: CPP - build-depends: base >=4 && <5 + NoImplicitPrelude + DeriveDataTypeable + DeriveFunctor + DeriveFoldable + DeriveTraversable + NoImplicitPrelude + build-depends: base >= 4.3 && <4.10, base-compat >=0.9.0 && <0.10 default-language: Haskell2010 + ghc-options: -Wall if impl(ghc >= 7.4) cpp-options: -DDEFAULT_SIGNATURES other-extensions: DefaultSignatures + if !impl(ghc >= 8.0) + build-depends: semigroups >= 0.16 diff --git a/instances/base/Data/Universe/Instances/Base.hs b/instances/base/Data/Universe/Instances/Base.hs index cb7a785..ee4678e 100644 --- a/instances/base/Data/Universe/Instances/Base.hs +++ b/instances/base/Data/Universe/Instances/Base.hs @@ -1,9 +1,11 @@ {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Universe.Instances.Base ( - -- | Instances of 'Universe' and 'Finite' for built-in types. - Universe(..), Finite(..) - ) where + -- | Instances of 'Universe' and 'Finite' for built-in types. + Universe(..), Finite(..) + ) where +import Control.Applicative import Control.Monad import Data.Int import Data.Map ((!), fromList) @@ -12,41 +14,48 @@ import Data.Ratio import Data.Universe.Class import Data.Universe.Helpers import Data.Word +import Prelude -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 () where universeUniv = universeDef +instance Universe Bool where universeUniv = universeDef +instance Universe Char where universeUniv = universeDef +instance Universe Ordering where universeUniv = universeDef +instance Universe Integer where universeUniv = univFromList [0, -1..] +++ univFromList [1..] +instance Universe Int where universeUniv = universeDef +instance Universe Int8 where universeUniv = universeDef +instance Universe Int16 where universeUniv = universeDef +instance Universe Int32 where universeUniv = universeDef +instance Universe Int64 where universeUniv = universeDef +instance Universe Word where universeUniv = universeDef +instance Universe Word8 where universeUniv = universeDef +instance Universe Word16 where universeUniv = universeDef +instance Universe Word32 where universeUniv = universeDef +instance Universe Word64 where universeUniv = 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 (Either a b) where universeUniv = fmap Left universeUniv +++ fmap Right universeUniv +instance Universe a => Universe (Maybe a ) where universeUniv = univCons Nothing $ fmap Just universeUniv -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 b) => Universe (a, b) where universeUniv = universeUniv +*+ universeUniv +instance (Universe a, Universe b, Universe c) => Universe (a, b, c) where + universeUniv = fmap mk $ universeUniv +*+ universeUniv +*+ universeUniv where + mk ((a,b),c) = (a,b,c) +instance (Universe a, Universe b, Universe c, Universe d) => Universe (a, b, c, d) where + universeUniv = fmap mk $ universeUniv +*+ universeUniv +*+ universeUniv +*+ universeUniv where + mk (((a,b),c),d) = (a,b,c,d) +instance (Universe a, Universe b, Universe c, Universe d, Universe e) => Universe (a, b, c, d, e) where + universeUniv = fmap mk $ universeUniv +*+ universeUniv +*+ universeUniv +*+ universeUniv +*+ universeUniv where + mk ((((a,b),c),d),e) = (a,b,c,d,e) instance Universe a => Universe [a] where - universe = diagonal $ [[]] : [[h:t | t <- universe] | h <- universe] + universeUniv = univCons [] ((:) <$> universeUniv <*> universeUniv) -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 +instance Universe All where universeUniv = fmap All universeUniv +instance Universe Any where universeUniv = fmap Any universeUniv +instance Universe a => Universe (Sum a) where universeUniv = fmap Sum universeUniv +instance Universe a => Universe (Product a) where universeUniv = fmap Product universeUniv +instance Universe a => Universe (Dual a) where universeUniv = fmap Dual universeUniv +instance Universe a => Universe (First a) where universeUniv = fmap First universeUniv +instance Universe a => Universe (Last a) where universeUniv = fmap Last universeUniv -- see http://mathlesstraveled.com/2008/01/07/recounting-the-rationals-part-ii-fractions-grow-on-trees/ -- @@ -70,20 +79,20 @@ instance Universe a => Universe (Last a) where universe = map Last univers -- -- 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 +positiveRationals :: Univ (Ratio Integer) +positiveRationals = univCons 1 $ fmap lChild positiveRationals +++ fmap 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 +instance a ~ Integer => Universe (Ratio a) where universeUniv = univCons 0 $ fmap 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 + universeUniv = fmap tableToFunction tables where + tables = choices [universeUniv | _ <- monoUniverse] + tableToFunction = (!) . fromList . zip monoUniverse + monoUniverse = universeF instance Finite () instance Finite Bool @@ -101,25 +110,25 @@ instance Finite Word32 instance Finite Word64 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 (Either a b) -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 a, Finite b) => Finite (a, b) where universeUnivF = liftM2 (,) universeUnivF universeUnivF +instance (Finite a, Finite b, Finite c) => Finite (a, b, c) where universeUnivF = liftM3 (,,) universeUnivF universeUnivF universeUnivF +instance (Finite a, Finite b, Finite c, Finite d) => Finite (a, b, c, d) where universeUnivF = liftM4 (,,,) universeUnivF universeUnivF universeUnivF universeUnivF +instance (Finite a, Finite b, Finite c, Finite d, Finite e) => Finite (a, b, c, d, e) where universeUnivF = liftM5 (,,,,) universeUnivF universeUnivF universeUnivF universeUnivF universeUnivF -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 Finite All where universeUnivF = fmap All universeUnivF +instance Finite Any where universeUnivF = fmap Any universeUnivF +instance Finite a => Finite (Sum a) where universeUnivF = fmap Sum universeUnivF +instance Finite a => Finite (Product a) where universeUnivF = fmap Product universeUnivF +instance Finite a => Finite (Dual a) where universeUnivF = fmap Dual universeUnivF +instance Finite a => Finite (First a) where universeUnivF = fmap First universeUnivF +instance Finite a => Finite (Last a) where universeUnivF = fmap Last universeUnivF 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 + universeUnivF = fmap tableToFunction tables where + tables = choices [universeUniv | _ <- monoUniverse] + tableToFunction = (!) . fromList . zip monoUniverse + monoUniverse = universeF -- to add when somebody asks for it: instance (Eq a, Finite a) => Finite (Endo a) (+Universe) diff --git a/instances/base/tests/Tests.hs b/instances/base/tests/Tests.hs index 6377d45..4ec7cce 100644 --- a/instances/base/tests/Tests.hs +++ b/instances/base/tests/Tests.hs @@ -1,10 +1,11 @@ {-# LANGUAGE ScopedTypeVariables #-} module Main (main) where -import Data.List (elemIndex, nub) +import Data.List (elemIndex) import Data.Int (Int8) import Test.QuickCheck -import Data.Universe.Instances.Base (Universe(..), Finite(..)) +import Data.Universe.Class +import Data.Universe.Instances.Base () import qualified Data.Set as Set diff --git a/instances/base/universe-instances-base.cabal b/instances/base/universe-instances-base.cabal index 41e95a4..78874d7 100644 --- a/instances/base/universe-instances-base.cabal +++ b/instances/base/universe-instances-base.cabal @@ -1,5 +1,5 @@ name: universe-instances-base -version: 1.0 +version: 2 synopsis: Universe instances for types from the base package homepage: https://github.com/dmwit/universe license: BSD3 @@ -23,7 +23,7 @@ library other-extensions: TypeFamilies build-depends: base >=4 && <5, containers >=0.4 && <0.6, - universe-base >=1.0 && <1.1 + universe-base >=2 && <3 default-language: Haskell2010 test-suite tests diff --git a/instances/containers/Data/Universe/Instances/Containers.hs b/instances/containers/Data/Universe/Instances/Containers.hs index 69571ca..328d5d8 100644 --- a/instances/containers/Data/Universe/Instances/Containers.hs +++ b/instances/containers/Data/Universe/Instances/Containers.hs @@ -8,20 +8,25 @@ module Data.Universe.Instances.Containers ( ) where import Data.Universe.Class +import Data.Universe.Helpers import qualified Data.Set as Set -- import qualified Data.Map as Map instance (Ord a, Universe a, Show a) => Universe (Set.Set a) where - universe = Set.empty : go universe + universeUniv = univCons Set.empty $ go universeUniv 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 - + go :: Ord b => Univ b -> Univ (Set.Set b) + go u = case univUncons u of + Nothing -> emptyUniv + Just (x, xs) -> univCons (Set.singleton x) $ inter (go xs) + where + -- Probably more efficient than using (+++) + -- TODO: add to Helpers + inter v = case univUncons v of + Nothing -> emptyUniv + Just (y,ys) -> univCons y $ univCons (Set.insert x y) $ + inter ys instance (Ord a, Finite a, Show a) => Finite (Set.Set a) diff --git a/instances/containers/tests/Tests.hs b/instances/containers/tests/Tests.hs index 8790ab8..d4808f0 100644 --- a/instances/containers/tests/Tests.hs +++ b/instances/containers/tests/Tests.hs @@ -3,8 +3,9 @@ module Main (main) where import Data.Set (Set) import Test.QuickCheck +import Data.Universe.Class import Data.Universe.Instances.Base () -import Data.Universe.Instances.Containers (Universe(..), Finite(..)) +import Data.Universe.Instances.Containers () import qualified Data.Set as Set diff --git a/instances/containers/universe-instances-containers.cabal b/instances/containers/universe-instances-containers.cabal index db94726..081f713 100644 --- a/instances/containers/universe-instances-containers.cabal +++ b/instances/containers/universe-instances-containers.cabal @@ -1,5 +1,5 @@ name: universe-instances-containers -version: 1.0 +version: 2 synopsis: Universe instances for types from the containers package homepage: https://github.com/dmwit/universe license: BSD3 @@ -23,7 +23,7 @@ library ghc-options: -Wall build-depends: base >=4 && <5, containers >=0.4 && <0.6, - universe-base >=1.0 && <1.1 + universe-base >=2 && <3 default-language: Haskell2010 test-suite tests diff --git a/instances/extended/Data/Universe/Instances/Extended.hs b/instances/extended/Data/Universe/Instances/Extended.hs index f75546e..2777100 100644 --- a/instances/extended/Data/Universe/Instances/Extended.hs +++ b/instances/extended/Data/Universe/Instances/Extended.hs @@ -1,15 +1,17 @@ {-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Universe.Instances.Extended ( - -- | Instances for 'Universe' and 'Finite' for function-like functors and the empty type. - Universe(..), Finite(..) - ) where + -- | Instances for 'Universe' and 'Finite' for function-like functors and the empty type. + Universe(..), Finite(..) + ) where import Data.Void import Control.Comonad.Trans.Traced import Data.Functor.Rep +import Data.Universe.Helpers (emptyUniv) import Data.Universe.Instances.Base -instance Universe Void where universe = [] +instance Universe Void where universeUniv = emptyUniv -- We could do this: -- @@ -22,17 +24,17 @@ instance Universe Void where universe = [] -- -- 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 + => Universe (Co f a) + where universeUniv = fmap tabulate universeUniv 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 + => Universe (TracedT s f a) + where universeUniv = fmap tabulate universeUniv instance Finite Void instance (Representable f, Finite (Rep f), Ord (Rep f), Finite a) - => Finite (Co f a) - where universeF = map tabulate universeF + => Finite (Co f a) + where universeUnivF = fmap tabulate universeUnivF 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 + => Finite (TracedT s f a) + where universeUnivF = fmap tabulate universeUnivF diff --git a/instances/extended/universe-instances-extended.cabal b/instances/extended/universe-instances-extended.cabal index 9b2051b..310979e 100644 --- a/instances/extended/universe-instances-extended.cabal +++ b/instances/extended/universe-instances-extended.cabal @@ -1,5 +1,5 @@ name: universe-instances-extended -version: 1.0.0.1 +version: 2 synopsis: Universe instances for types from select extra packages homepage: https://github.com/dmwit/universe license: BSD3 @@ -20,9 +20,11 @@ source-repository this library exposed-modules: Data.Universe.Instances.Extended + ghc-options: -Wall build-depends: adjunctions >=4 && <4.4, base >=4 && <5 , comonad >=4 && <5.1, - universe-instances-base >=1.0 && <1.1, + universe-base >=2 && <3, + universe-instances-base >=2 && <3, void >=0.1 && <0.8 default-language: Haskell2010 diff --git a/instances/reverse/Data/Universe/Instances/Eq.hs b/instances/reverse/Data/Universe/Instances/Eq.hs index cc34522..27a69f4 100644 --- a/instances/reverse/Data/Universe/Instances/Eq.hs +++ b/instances/reverse/Data/Universe/Instances/Eq.hs @@ -1,11 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Universe.Instances.Eq ( - -- | An 'Eq' instance for functions, given the input is 'Finite' and the - -- output is 'Eq'. Compares pointwise. - Eq(..) - ) where + -- | An 'Eq' instance for functions, given the input is 'Finite' and the + -- output is 'Eq'. Compares pointwise. + Eq(..) + ) where -import Data.Monoid -import Data.Universe.Instances.Base +import Data.Universe.Class instance (Finite a, Eq b) => Eq (a -> b) where - f == g = and [f x == g x | x <- universeF] + f == g = and [f x == g x | x <- universeF] diff --git a/instances/reverse/Data/Universe/Instances/Ord.hs b/instances/reverse/Data/Universe/Instances/Ord.hs index 9f934b7..e9a276d 100644 --- a/instances/reverse/Data/Universe/Instances/Ord.hs +++ b/instances/reverse/Data/Universe/Instances/Ord.hs @@ -1,13 +1,15 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} 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'. - Ord(..) - ) where + -- | 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'. + Ord(..) + ) where import Data.Monoid -import Data.Universe.Instances.Base -import Data.Universe.Instances.Eq +import Data.Universe.Class +import Data.Universe.Instances.Eq () +import Prelude instance (Finite a, Ord b) => Ord (a -> b) where - f `compare` g = mconcat [f x `compare` g x | x <- universeF] + f `compare` g = mconcat [f x `compare` g x | x <- universeF] diff --git a/instances/reverse/Data/Universe/Instances/Read.hs b/instances/reverse/Data/Universe/Instances/Read.hs index 4348484..9689d64 100644 --- a/instances/reverse/Data/Universe/Instances/Read.hs +++ b/instances/reverse/Data/Universe/Instances/Read.hs @@ -1,13 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} 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'. - Read(..) - ) where + -- | A 'Read' instance for functions, given the input is 'Finite' and + -- 'Ord' and both the input and output are 'Read'. + Read(..) + ) where import Data.Map (fromList, (!)) -import Data.Universe.Instances.Base +import Data.Universe.Class -- 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] + readsPrec n s = [((fromList v !), s') | (v, s') <- readsPrec n s] diff --git a/instances/reverse/Data/Universe/Instances/Show.hs b/instances/reverse/Data/Universe/Instances/Show.hs index 3d0382f..bdd74d1 100644 --- a/instances/reverse/Data/Universe/Instances/Show.hs +++ b/instances/reverse/Data/Universe/Instances/Show.hs @@ -1,10 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Universe.Instances.Show ( - -- | A 'Show' instance for functions, given the input is 'Finite' and both - -- the input and output are 'Show'. - Show(..) - ) where + -- | A 'Show' instance for functions, given the input is 'Finite' and both + -- the input and output are 'Show'. + Show(..) + ) where -import Data.Universe.Instances.Base +import Data.Universe.Class instance (Finite a, Show a, Show b) => Show (a -> b) where - showsPrec n f = showsPrec n [(a, f a) | a <- universeF] + showsPrec n f = showsPrec n [(a, f a) | a <- universeF] diff --git a/instances/reverse/Data/Universe/Instances/Traversable.hs b/instances/reverse/Data/Universe/Instances/Traversable.hs index d390066..a6df953 100644 --- a/instances/reverse/Data/Universe/Instances/Traversable.hs +++ b/instances/reverse/Data/Universe/Instances/Traversable.hs @@ -1,19 +1,21 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} 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'. - Foldable(..), Traversable(..) - ) where + -- | A 'Foldable' instance for functions, given the input is 'Finite', and + -- a 'Traversable' instance for functions, given the input is 'Ord' and + -- 'Finite'. + Foldable(..), Traversable(..) + ) where import Control.Applicative import Data.Foldable import Data.Map ((!), fromList) import Data.Monoid import Data.Traversable -import Data.Universe.Instances.Base +import Data.Universe.Class +import Prelude instance Finite e => Foldable ((->) e) where - foldMap f g = mconcat $ map (f . g) universeF + 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] + sequenceA f = (!) . fromList <$> sequenceA [(,) x <$> f x | x <- universeF] diff --git a/instances/reverse/universe-reverse-instances.cabal b/instances/reverse/universe-reverse-instances.cabal index 22ded92..35a7c8a 100644 --- a/instances/reverse/universe-reverse-instances.cabal +++ b/instances/reverse/universe-reverse-instances.cabal @@ -1,5 +1,5 @@ name: universe-reverse-instances -version: 1.0 +version: 2 synopsis: instances of standard classes that are made possible by enumerations homepage: https://github.com/dmwit/universe license: BSD3 @@ -26,5 +26,6 @@ library Data.Universe.Instances.Traversable build-depends: base >=4 && <5 , containers >=0.4 && <0.6, - universe-instances-base >=1.0 && <1.1 + universe-base >=2 && <3 default-language: Haskell2010 + ghc-options: -Wall diff --git a/instances/trans/Data/Universe/Instances/Trans.hs b/instances/trans/Data/Universe/Instances/Trans.hs index 207ece1..1533211 100644 --- a/instances/trans/Data/Universe/Instances/Trans.hs +++ b/instances/trans/Data/Universe/Instances/Trans.hs @@ -1,8 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Universe.Instances.Trans ( - -- | Instances of 'Universe' and 'Finite' for the standard monad and functor transformers. - Universe(..), Finite(..) - ) where + -- | Instances of 'Universe' and 'Finite' for the standard monad and functor transformers. + Universe(..), Finite(..) + ) where import Control.Monad.Identity import Control.Monad.Reader @@ -12,13 +13,13 @@ import Data.Functor.Product import Data.Universe.Helpers import Data.Universe.Instances.Base -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 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 (Product f g a) where universeF = liftM2 Pair universeF universeF +instance Universe a => Universe (Identity a) where universeUniv = fmap Identity universeUniv +instance Universe (f a) => Universe (IdentityT f a) where universeUniv = fmap IdentityT universeUniv +instance (Finite e, Ord e, Universe (m a)) => Universe (ReaderT e m a) where universeUniv = fmap ReaderT universeUniv +instance Universe (f (g a)) => Universe (Compose f g a) where universeUniv = fmap Compose universeUniv +instance (Universe (f a), Universe (g a)) => Universe (Product f g a) where universeUniv = fmap (uncurry Pair) $ universeUniv +*+ universeUniv +instance Finite a => Finite (Identity a) where universeUnivF = fmap Identity universeUnivF +instance Finite (f a) => Finite (IdentityT f a) where universeUnivF = fmap IdentityT universeUnivF +instance (Finite e, Ord e, Finite (m a) ) => Finite (ReaderT e m a) where universeUnivF = fmap ReaderT universeUnivF +instance Finite (f (g a)) => Finite (Compose f g a) where universeUnivF = fmap Compose universeUnivF +instance (Finite (f a), Finite (g a)) => Finite (Product f g a) where universeUnivF = fmap (uncurry Pair) $ universeUnivF +*+ universeUnivF diff --git a/instances/trans/universe-instances-trans.cabal b/instances/trans/universe-instances-trans.cabal index bff7eca..4efb860 100644 --- a/instances/trans/universe-instances-trans.cabal +++ b/instances/trans/universe-instances-trans.cabal @@ -1,5 +1,5 @@ name: universe-instances-trans -version: 1.0.0.1 +version: 2 synopsis: Universe instances for types from the transformers and mtl packages homepage: https://github.com/dmwit/universe license: BSD3 @@ -23,7 +23,8 @@ library build-depends: base >=4 && <5 , mtl >=1.0 && <2.3, transformers >=0.2 && <0.6, - universe-base >=1.0 && <1.1, - universe-instances-base >=1.0 && <1.1 + universe-base >=2 && <3, + universe-instances-base >=2 && <3 default-language: Haskell2010 other-extensions: FlexibleContexts + ghc-options: -Wall diff --git a/top/Data/Universe.hs b/top/Data/Universe.hs index afc619f..b90e85b 100644 --- a/top/Data/Universe.hs +++ b/top/Data/Universe.hs @@ -1,11 +1,12 @@ {-# 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 + -- | 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 Data.Universe.Instances.Base -import Data.Universe.Instances.Extended -import Data.Universe.Instances.Trans +import Data.Universe.Class (Universe (..), Finite (..)) +import Data.Universe.Instances.Base () +import Data.Universe.Instances.Extended () +import Data.Universe.Instances.Trans () diff --git a/top/Data/Universe/Instances.hs b/top/Data/Universe/Instances.hs deleted file mode 100644 index c78049d..0000000 --- a/top/Data/Universe/Instances.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# 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.Reverse () diff --git a/top/Data/Universe/Instances/Reverse.hs b/top/Data/Universe/Instances/Reverse.hs index b4c4db4..2b1c13d 100644 --- a/top/Data/Universe/Instances/Reverse.hs +++ b/top/Data/Universe/Instances/Reverse.hs @@ -1,10 +1,13 @@ {-# LANGUAGE NoImplicitPrelude #-} +-- | TODO: move to universe-instances-reverse module +-- Then @universe@ can not depend on @universe-instances-reverse@ module, +-- which introduces problematic instances. 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 + -- | 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 diff --git a/top/universe.cabal b/top/universe.cabal index effc794..290b754 100644 --- a/top/universe.cabal +++ b/top/universe.cabal @@ -1,5 +1,5 @@ name: universe -version: 1.0 +version: 2 synopsis: Classes for types where we know all the values description: Munge finite and recursively enumerable types homepage: https://github.com/dmwit/universe @@ -22,10 +22,11 @@ source-repository this library exposed-modules: Data.Universe, - Data.Universe.Instances, 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 + build-depends: universe-base >=2 && <2.1, + universe-instances-base >=2 && <3, + universe-instances-containers >=2 && <3, + universe-instances-extended >=2 && <3, + universe-reverse-instances >=2 && <3, + universe-instances-trans >=2 && <3 default-language: Haskell2010