Introduce Univ newtype

base/Data/Universe/Class.hs

@@ -3,10 +3,11 @@
 {-# LANGUAGE DefaultSignatures #-}
 #endif
 module Data.Universe.Class
-	( -- | Bottoms are ignored for this entire module: only fully-defined inhabitants are considered inhabitants.
-	  Universe(..)
-	, Finite(..)
-	) where
+    ( -- | Bottoms are ignored for this entire module: only fully-defined inhabitants are considered inhabitants.
+      Universe(..)
+    , Finite(..)
+    , Univ(..)
+    ) where
 
 import Data.Universe.Helpers
 
@@ -25,10 +26,17 @@ import Data.Universe.Helpers
 -- in 'length' pfx = 'length' (nub pfx)
 -- @
 class Universe a where
-	universe :: [a]
+    -- | Memoised CAF. Use with care as the expanded value will live forever.
+    --
+    -- See <http://stackoverflow.com/questions/6090932/how-to-make-a-caf-not-a-caf-in-haskell>
+    universe :: [a]
+    universe = getUniv universeUniv
+
+    -- | 'Univ' containing all values of @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
 
 -- | Creating an instance of this class is a declaration that your 'universe'
@@ -54,5 +62,8 @@ class Universe a where
 -- Just 1
 -- @
 class Universe a => Finite a where
-	universeF :: [a]
-	universeF = universe
+    universeF :: [a]
+    universeF = getUniv universeUnivF
+
+    universeUnivF :: Univ a
+    universeUnivF = universeUniv

base/Data/Universe/Helpers.hs

@@ -1,34 +1,58 @@
 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
+    -- | 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 Control.Applicative
 import Data.List
+import Prelude
+
+-- | Type synonym representing container of elements.
+--
+-- 'Univ' has one invariant: all elements in @'Univ' a@ are distinct.
+newtype Univ a = Univ { getUniv :: [a] }
+
+instance Functor Univ where
+    fmap f = Univ . fmap f . getUniv
+
+instance Applicative Univ where
+    pure = Univ . return
+    Univ f <*> Univ x = Univ (f <*> x)
+
+instance Monad Univ where
+    return = Univ . return
+    m >>= f = Univ $ getUniv m >>= getUniv . f
+
+emptyUniv :: Univ a
+emptyUniv = Univ []
+
+univCons :: a -> Univ a -> Univ a
+univCons x (Univ xs) = Univ (x : xs)
 
 -- | 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
+diagonal :: [Univ a] -> Univ a
+diagonal = Univ . concat . diagonals . fmap 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,45 +61,48 @@ 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)
 -- 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]
+(+*+) :: 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 [(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 (:)) .) . (+*+)) [[]]
+choices = foldr ((map (uncurry (:)) .) . unfairProduct) [[]]
 
 -- | 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) [[]]
+--unfairChoices :: [[a]] -> [[a]]
+--unfairChoices = foldr ((map (uncurry (:)) .) . unfairCartesianProduct) [[]]

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
@@ -32,6 +32,7 @@ library
   other-extensions:    CPP
   build-depends:       base >=4 && <5
   default-language:    Haskell2010
+  ghc-options:         -Wall
   if impl(ghc >= 7.4)
     cpp-options:       -DDEFAULT_SIGNATURES
     other-extensions:  DefaultSignatures

instances/base/Data/Universe/Instances/Base.hs

@@ -1,8 +1,9 @@
 {-# 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.Monad
 import Data.Int
@@ -13,40 +14,46 @@ import Data.Universe.Class
 import Data.Universe.Helpers
 import Data.Word
 
-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 = Univ [0, -1..] +++ Univ [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 = diagonal $ Univ [] : [Univ [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
+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 +77,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 = Univ $ fmap tableToFunction tables where
+        tables          = choices [universe | _ <- monoUniverse]
+        tableToFunction = (!) . fromList . zip monoUniverse
+        Univ monoUniverse    = universeUnivF
 
 instance Finite ()
 instance Finite Bool
@@ -101,25 +108,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 = Univ $ fmap tableToFunction tables where
+        tables          = sequence [universeF | _ <- monoUniverse]
+        tableToFunction = (!) . fromList . zip monoUniverse
+        Univ monoUniverse = universeUnivF
 
 -- to add when somebody asks for it: instance (Eq a, Finite a) => Finite (Endo a) (+Universe)

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

instances/containers/Data/Universe/Instances/Containers.hs

@@ -8,12 +8,13 @@ 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 $ Univ $ go universe
       where
         go []     = []
         go (x:xs) = Set.singleton x : inter (go xs)