Introduce Univ newtype

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

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 <https://hackage.haskell.org/package/control-monad-omega-0.3.1/docs/Control-Monad-Omega.html>
+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,45 +106,52 @@ 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 [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) [[]]
+-}

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