{-# LANGUAGE
  CPP,
  FlexibleContexts,
  TypeFamilies,
  UndecidableInstances,
  UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-noncanonical-monoid-instances #-}
#if __GLASGOW_HASKELL__ >= 904
{-# OPTIONS_GHC -Wno-orphans #-}
#endif

-- | Newtypes with instances implemented using generic combinators.
--
-- === Warning
--
-- This is an internal module: it is not subject to any versioning policy,
-- breaking changes can happen at any time.
--
-- If something here seems useful, please report it or create a pull request to
-- export it from an external module.

module Generic.Data.Internal.Generically
  ( Generically(..)
  , Generically1(..)
  , FiniteEnumeration(..)
  , GenericProduct(..) ) where

import GHC.Generics
import Data.Functor.Classes
import Data.Ix
import Text.Read

import Generic.Data.Internal.Prelude hiding (gfoldMap, gtraverse, gsequenceA)
import Generic.Data.Internal.Enum
import Generic.Data.Internal.Error
import Generic.Data.Internal.Read
import Generic.Data.Internal.Show
import Generic.Data.Internal.Traversable (GFoldable, GTraversable, gfoldMap, gtraverse, gsequenceA)

#if __GLASGOW_HASKELL__ < 904
import Control.Applicative
import Data.Semigroup
#endif

-- $setup
-- >>> :set -XDerivingVia -XDeriveGeneric
-- >>> import GHC.Generics (Generic, Generic1)

#if __GLASGOW_HASKELL__ < 904
-- | Type with instances derived via 'Generic'.
--
-- === Examples
--
-- ==== __Deriving 'Eq', 'Ord', 'Show', 'Read'__
--
-- >>> :{
-- data T = C Int Bool
--   deriving Generic
--   deriving (Eq, Ord, Show, Read) via (Generically T)
-- :}
--
-- ==== __Deriving 'Semigroup', 'Monoid'__
--
-- The type must have only one constructor.
--
-- >>> import Data.Monoid (Sum)
-- >>> :{
-- data U = D [Int] (Sum Int)
--   deriving Generic
--   deriving (Semigroup, Monoid) via (Generically U)
-- :}
--
-- ==== __Deriving 'Enum', 'Bounded'__
--
-- The type must have only nullary constructors.
-- To lift that restriction, see 'FiniteEnumeration'.
--
-- >>> :{
-- data V = X | Y | Z
--   deriving Generic
--   deriving (Eq, Ord, Enum, Bounded) via (Generically V)
-- :}
newtype Generically a = Generically a

instance (AssertNoSum Semigroup a, Generic a, Semigroup (Rep a ())) => Semigroup (Generically a) where
  (<>) = gmappend

-- | This uses the 'Semigroup' instance of the wrapped type @a@ to define 'mappend'.
-- The purpose of this instance is to derive 'mempty', while remaining consistent
-- with possibly custom 'Semigroup' instances.
instance (AssertNoSum Semigroup a, Semigroup a, Generic a, Monoid (Rep a ())) => Monoid (Generically a) where
  mempty = gmempty
  mappend (Generically x) (Generically y) = Generically (x <> y)
#endif

-- | This is a hack to implicitly wrap/unwrap in the instances of 'Generically'.
instance Generic a => Generic (Generically a) where
  type Rep (Generically a) = Rep a
  to :: forall x. Rep (Generically a) x -> Generically a
to = a -> Generically a
forall a. a -> Generically a
Generically (a -> Generically a) -> (Rep a x -> a) -> Rep a x -> Generically a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a x -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to
  from :: forall x. Generically a -> Rep (Generically a) x
from (Generically a
x) = a -> Rep a x
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
x

instance (Generic a, Eq (Rep a ())) => Eq (Generically a) where
  == :: Generically a -> Generically a -> Bool
(==) = Generically a -> Generically a -> Bool
forall a. (Generic a, Eq (Rep a ())) => a -> a -> Bool
geq

instance (Generic a, Ord (Rep a ())) => Ord (Generically a) where
  compare :: Generically a -> Generically a -> Ordering
compare = Generically a -> Generically a -> Ordering
forall a. (Generic a, Ord (Rep a ())) => a -> a -> Ordering
gcompare

instance (Generic a, GRead0 (Rep a)) => Read (Generically a) where
  readPrec :: ReadPrec (Generically a)
readPrec = ReadPrec (Generically a)
forall a. (Generic a, GRead0 (Rep a)) => ReadPrec a
greadPrec
  readListPrec :: ReadPrec [Generically a]
readListPrec = ReadPrec [Generically a]
forall a. Read a => ReadPrec [a]
readListPrecDefault

instance (Generic a, GShow0 (Rep a)) => Show (Generically a) where
  showsPrec :: Int -> Generically a -> ShowS
showsPrec = Int -> Generically a -> ShowS
forall a. (Generic a, GShow0 (Rep a)) => Int -> a -> ShowS
gshowsPrec

instance (Generic a, GEnum StandardEnum (Rep a)) => Enum (Generically a) where
  toEnum :: Int -> Generically a
toEnum = Int -> Generically a
forall a. (Generic a, GEnum StandardEnum (Rep a)) => Int -> a
gtoEnum
  fromEnum :: Generically a -> Int
fromEnum = Generically a -> Int
forall a. (Generic a, GEnum StandardEnum (Rep a)) => a -> Int
gfromEnum
  enumFrom :: Generically a -> [Generically a]
enumFrom = Generically a -> [Generically a]
forall a. (Generic a, GEnum StandardEnum (Rep a)) => a -> [a]
genumFrom
  enumFromThen :: Generically a -> Generically a -> [Generically a]
enumFromThen = Generically a -> Generically a -> [Generically a]
forall a. (Generic a, GEnum StandardEnum (Rep a)) => a -> a -> [a]
genumFromThen
  enumFromTo :: Generically a -> Generically a -> [Generically a]
enumFromTo = Generically a -> Generically a -> [Generically a]
forall a. (Generic a, GEnum StandardEnum (Rep a)) => a -> a -> [a]
genumFromTo
  enumFromThenTo :: Generically a -> Generically a -> Generically a -> [Generically a]
enumFromThenTo = Generically a -> Generically a -> Generically a -> [Generically a]
forall a.
(Generic a, GEnum StandardEnum (Rep a)) =>
a -> a -> a -> [a]
genumFromThenTo

instance (Generic a, Ord (Rep a ()), GIx (Rep a)) => Ix (Generically a) where
  range :: (Generically a, Generically a) -> [Generically a]
range = (Generically a, Generically a) -> [Generically a]
forall a. (Generic a, GIx (Rep a)) => (a, a) -> [a]
grange
  index :: (Generically a, Generically a) -> Generically a -> Int
index = (Generically a, Generically a) -> Generically a -> Int
forall a. (Generic a, GIx (Rep a)) => (a, a) -> a -> Int
gindex
  inRange :: (Generically a, Generically a) -> Generically a -> Bool
inRange = (Generically a, Generically a) -> Generically a -> Bool
forall a. (Generic a, GIx (Rep a)) => (a, a) -> a -> Bool
ginRange

instance (Generic a, GBounded (Rep a)) => Bounded (Generically a) where
  minBound :: Generically a
minBound = Generically a
forall a. (Generic a, GBounded (Rep a)) => a
gminBound
  maxBound :: Generically a
maxBound = Generically a
forall a. (Generic a, GBounded (Rep a)) => a
gmaxBound


-- | Type with 'Enum' instance derived via 'Generic' with 'FiniteEnum' option.
-- This allows deriving 'Enum' for types whose constructors have fields.
--
-- Some caution is advised; see details in 'FiniteEnum'.
--
-- === __Example__
--
-- >>> :{
-- data Booool = Booool Bool Bool
--   deriving Generic
--   deriving (Enum, Bounded) via (FiniteEnumeration Booool)
-- :}
newtype FiniteEnumeration a = FiniteEnumeration a

instance Generic a => Generic (FiniteEnumeration a) where
  type Rep (FiniteEnumeration a) = Rep a
  to :: forall x. Rep (FiniteEnumeration a) x -> FiniteEnumeration a
to = a -> FiniteEnumeration a
forall a. a -> FiniteEnumeration a
FiniteEnumeration (a -> FiniteEnumeration a)
-> (Rep a x -> a) -> Rep a x -> FiniteEnumeration a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a x -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to
  from :: forall x. FiniteEnumeration a -> Rep (FiniteEnumeration a) x
from (FiniteEnumeration a
x) = a -> Rep a x
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
x

instance (Generic a, GEnum FiniteEnum (Rep a)) => Enum (FiniteEnumeration a) where
  toEnum :: Int -> FiniteEnumeration a
toEnum = Int -> FiniteEnumeration a
forall a. (Generic a, GEnum FiniteEnum (Rep a)) => Int -> a
gtoFiniteEnum
  fromEnum :: FiniteEnumeration a -> Int
fromEnum = FiniteEnumeration a -> Int
forall a. (Generic a, GEnum FiniteEnum (Rep a)) => a -> Int
gfromFiniteEnum
  enumFrom :: FiniteEnumeration a -> [FiniteEnumeration a]
enumFrom = FiniteEnumeration a -> [FiniteEnumeration a]
forall a. (Generic a, GEnum FiniteEnum (Rep a)) => a -> [a]
gfiniteEnumFrom
  enumFromThen :: FiniteEnumeration a -> FiniteEnumeration a -> [FiniteEnumeration a]
enumFromThen = FiniteEnumeration a -> FiniteEnumeration a -> [FiniteEnumeration a]
forall a. (Generic a, GEnum FiniteEnum (Rep a)) => a -> a -> [a]
gfiniteEnumFromThen
  enumFromTo :: FiniteEnumeration a -> FiniteEnumeration a -> [FiniteEnumeration a]
enumFromTo = FiniteEnumeration a -> FiniteEnumeration a -> [FiniteEnumeration a]
forall a. (Generic a, GEnum FiniteEnum (Rep a)) => a -> a -> [a]
gfiniteEnumFromTo
  enumFromThenTo :: FiniteEnumeration a
-> FiniteEnumeration a
-> FiniteEnumeration a
-> [FiniteEnumeration a]
enumFromThenTo = FiniteEnumeration a
-> FiniteEnumeration a
-> FiniteEnumeration a
-> [FiniteEnumeration a]
forall a.
(Generic a, GEnum FiniteEnum (Rep a)) =>
a -> a -> a -> [a]
gfiniteEnumFromThenTo

-- | The same instance as 'Generically', for convenience.
instance (Generic a, GBounded (Rep a)) => Bounded (FiniteEnumeration a) where
  minBound :: FiniteEnumeration a
minBound = FiniteEnumeration a
forall a. (Generic a, GBounded (Rep a)) => a
gminBound
  maxBound :: FiniteEnumeration a
maxBound = FiniteEnumeration a
forall a. (Generic a, GBounded (Rep a)) => a
gmaxBound

#if __GLASGOW_HASKELL__ < 904
-- | Type with instances derived via 'Generic1'.
--
-- === Examples
--
-- ==== __Deriving 'Functor', 'Applicative', 'Alternative'__
--
-- 'Applicative' can be derived for types with only one
-- constructor, aka. products.
--
-- >>> :{
-- data F a = F1 a | F2 (Maybe a) | F3 [Either Bool a] (Int, a)
--   deriving Generic1
--   deriving Functor via (Generically1 F)
-- :}
--
-- >>> :{
-- data G a = G a (Maybe a) [a] (IO a)
--   deriving Generic1
--   deriving (Functor, Applicative) via (Generically1 G)
-- :}
--
-- >>> import Control.Applicative (Alternative)
-- >>> :{
-- data G' a = G' (Maybe a) [a]
--   deriving Generic1
--   deriving (Functor, Applicative, Alternative) via (Generically1 G')
-- :}
--
-- ==== __Deriving 'Foldable'__
--
-- >>> import Generic.Data.Orphans ()
-- >>> :{
-- data H a = H1 a | H2 (Maybe a)
--   deriving Generic1
--   deriving (Functor, Foldable) via (Generically1 H)
-- :}
--
-- Note: we can't use @DerivingVia@ for 'Traversable'.
-- One may implement 'Traversable' explicitly using 'gtraverse'.
--
-- ==== __Deriving 'Eq1', 'Ord1'__
--
-- >>> import Data.Functor.Classes (Eq1, Ord1)
-- >>> :{
-- data I a = I [a] (Maybe a)
--   deriving Generic1
--   deriving (Eq1, Ord1) via (Generically1 I)
-- :}
newtype Generically1 f a = Generically1 (f a)

instance (Generic1 f, Eq1 (Rep1 f)) => Eq1 (Generically1 f) where
  liftEq = gliftEq

instance (Generic1 f, Ord1 (Rep1 f)) => Ord1 (Generically1 f) where
  liftCompare = gliftCompare

instance (Generic1 f, Functor (Rep1 f)) => Functor (Generically1 f) where
  fmap = gfmap
  (<$) = gconstmap

instance (Generic1 f, Applicative (Rep1 f)) => Applicative (Generically1 f) where
  pure = gpure
  (<*>) = gap
#if MIN_VERSION_base(4,10,0)
  liftA2 = gliftA2
#endif

instance (Generic1 f, Alternative (Rep1 f)) => Alternative (Generically1 f) where
  empty = gempty
  (<|>) = galt

instance (Generic1 f, Eq1 (Rep1 f), Eq a) => Eq (Generically1 f a) where
  (==) = eq1

instance (Generic1 f, Ord1 (Rep1 f), Ord a) => Ord (Generically1 f a) where
  compare = compare1
#endif

-- | This is a hack to implicitly wrap/unwrap in the instances of 'Generically1'.
instance Generic (f a) => Generic (Generically1 f a) where
  type Rep (Generically1 f a) = Rep (f a)
  to :: forall x. Rep (Generically1 f a) x -> Generically1 f a
to = f a -> Generically1 f a
forall {k} (f :: k -> *) (a :: k). f a -> Generically1 f a
Generically1 (f a -> Generically1 f a)
-> (Rep (f a) x -> f a) -> Rep (f a) x -> Generically1 f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep (f a) x -> f a
forall a x. Generic a => Rep a x -> a
forall x. Rep (f a) x -> f a
to
  from :: forall x. Generically1 f a -> Rep (Generically1 f a) x
from (Generically1 f a
x) = f a -> Rep (f a) x
forall x. f a -> Rep (f a) x
forall a x. Generic a => a -> Rep a x
from f a
x

-- | This is a hack to implicitly wrap/unwrap in the instances of 'Generically1'.
instance Generic1 f => Generic1 (Generically1 f) where
  type Rep1 (Generically1 f) = Rep1 f
  to1 :: forall a. Rep1 (Generically1 f) a -> Generically1 f a
to1 = f a -> Generically1 f a
forall {k} (f :: k -> *) (a :: k). f a -> Generically1 f a
Generically1 (f a -> Generically1 f a)
-> (Rep1 f a -> f a) -> Rep1 f a -> Generically1 f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep1 f a -> f a
forall a. Rep1 f a -> f a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1
  from1 :: forall a. Generically1 f a -> Rep1 (Generically1 f) a
from1 (Generically1 f a
x) = f a -> Rep1 f a
forall a. f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 f a
x

instance (Generic1 f, GRead1 (Rep1 f)) => Read1 (Generically1 f) where
#if MIN_VERSION_base(4,10,0)
  liftReadPrec :: forall a. ReadPrec a -> ReadPrec [a] -> ReadPrec (Generically1 f a)
liftReadPrec = ReadPrec a -> ReadPrec [a] -> ReadPrec (Generically1 f a)
forall (f :: * -> *) a.
(Generic1 f, GRead1 (Rep1 f)) =>
ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
gliftReadPrec
  liftReadListPrec :: forall a. ReadPrec a -> ReadPrec [a] -> ReadPrec [Generically1 f a]
liftReadListPrec = ReadPrec a -> ReadPrec [a] -> ReadPrec [Generically1 f a]
forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec [f a]
liftReadListPrecDefault
#else
  liftReadsPrec rp rl = readPrec_to_S $
    gliftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl))
#endif

instance (Generic1 f, GRead1 (Rep1 f), Read a) => Read (Generically1 f a) where
#if MIN_VERSION_base(4,10,0)
  readPrec :: ReadPrec (Generically1 f a)
readPrec = ReadPrec (Generically1 f a)
forall (f :: * -> *) a. (Read1 f, Read a) => ReadPrec (f a)
readPrec1
  readListPrec :: ReadPrec [Generically1 f a]
readListPrec = ReadPrec [Generically1 f a]
forall a. Read a => ReadPrec [a]
readListPrecDefault
#else
  readsPrec = readsPrec1
#endif

instance (Generic1 f, GShow1 (Rep1 f)) => Show1 (Generically1 f) where
  liftShowsPrec :: forall a.
(Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> Generically1 f a -> ShowS
liftShowsPrec = (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> Generically1 f a -> ShowS
forall (f :: * -> *) a.
(Generic1 f, GShow1 (Rep1 f)) =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
gliftShowsPrec

instance (Generic1 f, GShow1 (Rep1 f), Show a) => Show (Generically1 f a) where
  showsPrec :: Int -> Generically1 f a -> ShowS
showsPrec = Int -> Generically1 f a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1

instance (Generic1 f, GFoldable (Rep1 f)) => Foldable (Generically1 f) where
  foldMap :: forall m a. Monoid m => (a -> m) -> Generically1 f a -> m
foldMap = (a -> m) -> Generically1 f a -> m
forall (f :: * -> *) m a.
(Generic1 f, GFoldable (Rep1 f), Monoid m) =>
(a -> m) -> f a -> m
gfoldMap
  foldr :: forall a b. (a -> b -> b) -> b -> Generically1 f a -> b
foldr = (a -> b -> b) -> b -> Generically1 f a -> b
forall (f :: * -> *) a b.
(Generic1 f, Foldable (Rep1 f)) =>
(a -> b -> b) -> b -> f a -> b
gfoldr

instance (Generic1 f, Functor (Rep1 f), GFoldable (Rep1 f), GTraversable (Rep1 f))
  => Traversable (Generically1 f) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Generically1 f a -> f (Generically1 f b)
traverse = (a -> f b) -> Generically1 f a -> f (Generically1 f b)
forall (f :: * -> *) (m :: * -> *) a b.
(Generic1 f, GTraversable (Rep1 f), Applicative m) =>
(a -> m b) -> f a -> m (f b)
gtraverse
  sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Generically1 f (f a) -> f (Generically1 f a)
sequenceA = Generically1 f (f a) -> f (Generically1 f a)
forall (f :: * -> *) (m :: * -> *) a.
(Generic1 f, GTraversable (Rep1 f), Applicative m) =>
f (m a) -> m (f a)
gsequenceA

-- | Product type with generic instances of 'Semigroup' and 'Monoid'.
--
-- This is similar to 'Generic.Data.Generically' in most cases, but
-- 'GenericProduct' also works for types @T@ with deriving
-- @via 'GenericProduct' U@, where @U@ is a generic product type coercible to,
-- but distinct from @T@. In particular, @U@ may not have an instance of
-- 'Semigroup', which 'Generic.Data.Generically' requires.
--
-- === __Example__
--
-- >>> import Data.Monoid (Sum(..))
-- >>> data Point a = Point a a deriving Generic
-- >>> :{
--   newtype Vector a = Vector (Point a)
--     deriving (Semigroup, Monoid)
--       via GenericProduct (Point (Sum a))
-- :}
--
-- If it were @via 'Generic.Data.Generically' (Point (Sum a))@ instead, then
-- @Vector@'s 'mappend' (the 'Monoid' method) would be defined as @Point@'s
-- @('<>')@ (the 'Semigroup' method), which might not exist, or might not be
-- equivalent to @Vector@'s generic 'Semigroup' instance, which would be
-- unlawful.
newtype GenericProduct a = GenericProduct a

instance Generic a => Generic (GenericProduct a) where
  type Rep (GenericProduct a) = Rep a
  to :: forall x. Rep (GenericProduct a) x -> GenericProduct a
to = a -> GenericProduct a
forall a. a -> GenericProduct a
GenericProduct (a -> GenericProduct a)
-> (Rep a x -> a) -> Rep a x -> GenericProduct a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a x -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to
  from :: forall x. GenericProduct a -> Rep (GenericProduct a) x
from (GenericProduct a
x) = a -> Rep a x
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
x

instance (AssertNoSum Semigroup a, Generic a, Semigroup (Rep a ())) => Semigroup (GenericProduct a) where
  <> :: GenericProduct a -> GenericProduct a -> GenericProduct a
(<>) = GenericProduct a -> GenericProduct a -> GenericProduct a
forall a. (Generic a, Semigroup (Rep a ())) => a -> a -> a
gmappend

instance (AssertNoSum Semigroup a, Generic a, Monoid (Rep a ())) => Monoid (GenericProduct a) where
  mempty :: GenericProduct a
mempty = GenericProduct a
forall a. (Generic a, Monoid (Rep a ())) => a
gmempty
  mappend :: GenericProduct a -> GenericProduct a -> GenericProduct a
mappend = GenericProduct a -> GenericProduct a -> GenericProduct a
forall a. (Generic a, Monoid (Rep a ())) => a -> a -> a
gmappend'