{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Safe #-}
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 :: forall a. [M1 i c f a]
guniverse = (f a -> M1 i c f a) -> [f a] -> [M1 i c f a]
forall a b. (a -> b) -> [a] -> [b]
map f a -> M1 i c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 ([f a] -> [M1 i c f a]) -> [f a] -> [M1 i c f a]
forall a b. (a -> b) -> a -> b
$ [[f a]] -> [f a]
forall a. [[a]] -> [a]
interleave [[f a]]
forall a. [[f a]]
forall (f :: * -> *) a. GUniverseSum f => [[f a]]
guniverseSum

class GUniverseSum f where
  guniverseSum :: [[f a]]

instance GUniverseSum V1 where
  guniverseSum :: forall a. [[V1 a]]
guniverseSum = []

instance (GUniverseSum f, GUniverseSum g) => GUniverseSum (f :+: g) where
  guniverseSum :: forall a. [[(:+:) f g a]]
guniverseSum = ([f a] -> [(:+:) f g a]) -> [[f a]] -> [[(:+:) f g a]]
forall a b. (a -> b) -> [a] -> [b]
map ((f a -> (:+:) f g a) -> [f a] -> [(:+:) f g a]
forall a b. (a -> b) -> [a] -> [b]
map f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1) [[f a]]
forall a. [[f a]]
forall (f :: * -> *) a. GUniverseSum f => [[f a]]
guniverseSum [[(:+:) f g a]] -> [[(:+:) f g a]] -> [[(:+:) f g a]]
forall a. [a] -> [a] -> [a]
++ ([g a] -> [(:+:) f g a]) -> [[g a]] -> [[(:+:) f g a]]
forall a b. (a -> b) -> [a] -> [b]
map ((g a -> (:+:) f g a) -> [g a] -> [(:+:) f g a]
forall a b. (a -> b) -> [a] -> [b]
map g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1) [[g a]]
forall a. [[g a]]
forall (f :: * -> *) a. GUniverseSum f => [[f a]]
guniverseSum

instance GUniverseProduct f => GUniverseSum (M1 i c f) where
  guniverseSum :: forall a. [[M1 i c f a]]
guniverseSum = [(f a -> M1 i c f a) -> [f a] -> [M1 i c f a]
forall a b. (a -> b) -> [a] -> [b]
map f a -> M1 i c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 [f a]
forall a. [f a]
forall (f :: * -> *) a. GUniverseProduct f => [f a]
guniverseProduct]

class GUniverseProduct f where
  guniverseProduct :: [f a]

instance GUniverseProduct U1 where
  guniverseProduct :: forall a. [U1 a]
guniverseProduct = [U1 a
forall k (p :: k). U1 p
U1]

-- This is not completely fair; but enough.
instance (GUniverseProduct f, GUniverseProduct g) => GUniverseProduct (f :*: g) where
  guniverseProduct :: forall a. [(:*:) f g a]
guniverseProduct = (f a -> g a -> (:*:) f g a) -> [f a] -> [g a] -> [(:*:) f g a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
cartesianProduct f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) [f a]
forall a. [f a]
forall (f :: * -> *) a. GUniverseProduct f => [f a]
guniverseProduct [g a]
forall a. [g a]
forall (f :: * -> *) a. GUniverseProduct f => [f a]
guniverseProduct

instance GUniverseProduct f => GUniverseProduct (M1 i c f) where
  guniverseProduct :: forall a. [M1 i c f a]
guniverseProduct = (f a -> M1 i c f a) -> [f a] -> [M1 i c f a]
forall a b. (a -> b) -> [a] -> [b]
map f a -> M1 i c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 [f a]
forall a. [f a]
forall (f :: * -> *) a. GUniverseProduct f => [f a]
guniverseProduct

instance Universe a => GUniverseProduct (K1 r a) where
  guniverseProduct :: forall a. [K1 r a a]
guniverseProduct = (a -> K1 r a a) -> [a] -> [K1 r a a]
forall a b. (a -> b) -> [a] -> [b]
map a -> K1 r a a
forall k i c (p :: k). c -> K1 i c p
K1 [a]
forall a. Universe a => [a]
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 :: forall a. (Generic a, GUniverse (Rep a)) => [a]
universeGeneric = (Rep a Any -> a) -> [Rep a Any] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to [Rep a Any]
forall a. [Rep a a]
forall (f :: * -> *) a. GUniverse f => [f a]
guniverse 

-- $empty
--
-- >>> :set -XEmptyDataDeriving
--
-- >>> data Zero deriving (Show, Generic)
-- >>> universeGeneric :: [Zero]
-- []