-- | For a datatype where /every/ subterm is interesting, it is
-- possible to leverage 'Generic' to automatically produce the
-- 'GTraversable' instance.
--
-- This module defines a default 'GTraversable' instance for most
-- 'Generic' types, though you can override it with a custom instance
-- if you so wish. The 'gtraverse' implementation for this instance
-- traverses every subterm, and traverses left-to-right on products
-- ':*:'.
--
-- Example usage:
--
-- >{-# LANGUAGE FlexibleInstances, DeriveGeneric #-}
-- >import Data.Maybe (isJust)
-- >
-- >data MyConfig = MyConfig
-- >  { firstKey  :: Maybe Int
-- >  , secondKey :: Maybe String
-- >  , thirdKey  :: Maybe Bool
-- >  }
-- >  deriving (Generic)
-- >
-- >class SettableConfigKey a where
-- >  isSet :: a -> Bool
-- >
-- >instance SettableConfigKey (Maybe a) where
-- >  isSet = isJust
-- >
-- >isAnyConfigKeySet :: MyConfig -> Bool
-- >isAnyConfigKeySet = gfoldr @SettableConfigKey ((||) . isSet)
--
-- For 'Generic' types that have 'Rec1' in their representation, this
-- module will not work for GHC versions below 8.6.1, as the instance
-- makes use of @QuantifiedConstraints@. Instead, the instance for
-- 'Rec1' will cause a type error.
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}

# if MIN_VERSION_GLASGOW_HASKELL(8, 6, 1, 0)
{-# LANGUAGE QuantifiedConstraints #-}
# else
{-# LANGUAGE DataKinds #-}
# endif

{-# OPTIONS_GHC -Wno-orphans #-}
module Data.Generics.Traversable.Generic where

import Data.Generics.Traversable
import GHC.Generics

# if MIN_VERSION_GLASGOW_HASKELL(8, 6, 1, 0)
# else
import GHC.TypeLits (TypeError, ErrorMessage (..))
# endif

-- | Special version of 'GTraversable' for the representation types
-- from 'Generic'.
class GTraversable' c (f :: * -> *) where
  gtraverse' :: Applicative g => (forall d. c d => d -> g d) -> (forall p. f p -> g (f p))

instance GTraversable' c U1 where
  gtraverse' :: (forall d. c d => d -> g d) -> forall p. U1 p -> g (U1 p)
gtraverse' forall d. c d => d -> g d
_f U1 p
U1 = U1 p -> g (U1 p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 p
forall k (p :: k). U1 p
U1

instance GTraversable' c V1 where
  gtraverse' :: (forall d. c d => d -> g d) -> forall p. V1 p -> g (V1 p)
gtraverse' forall d. c d => d -> g d
_f = [Char] -> V1 p -> g (V1 p)
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible"

instance GTraversable' c Par1 where
  gtraverse' :: (forall d. c d => d -> g d) -> forall p. Par1 p -> g (Par1 p)
gtraverse' forall d. c d => d -> g d
_f Par1 p
par1 = Par1 p -> g (Par1 p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Par1 p
par1

# if MIN_VERSION_GLASGOW_HASKELL(8, 6, 1, 0)
instance (forall p. GTraversable c (f p)) => GTraversable' c (Rec1 f) where
  gtraverse' :: (forall d. c d => d -> g d) -> forall p. Rec1 f p -> g (Rec1 f p)
gtraverse' forall d. c d => d -> g d
f (Rec1 f p
recur) = f p -> Rec1 f p
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (f p -> Rec1 f p) -> g (f p) -> g (Rec1 f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall d. c d => d -> g d) -> f p -> g (f p)
forall (c :: * -> Constraint) a (f :: * -> *).
(GTraversable c a, Applicative f) =>
(forall d. c d => d -> f d) -> a -> f a
gtraverse @c forall d. c d => d -> g d
f f p
recur
# else
instance
    ( TypeError
      ( 'Text "No generic instance can be derived for " ':$$: 'ShowType f ':$$:
        'Text " for this GHC version - upgrade to at least 8.6.1 to be" ':$$:
        'Text " able to use `GTraversable` from `Generic` here"
      )
    )
  => GTraversable' c (Rec1 f) where
  gtraverse' _ _ = error "Cannot implement `gtraverse'` for this type"
# endif

instance (c con) => GTraversable' c (K1 i con) where
  gtraverse' :: (forall d. c d => d -> g d)
-> forall p. K1 i con p -> g (K1 i con p)
gtraverse' forall d. c d => d -> g d
f (K1 con
con) = con -> K1 i con p
forall k i c (p :: k). c -> K1 i c p
K1 (con -> K1 i con p) -> g con -> g (K1 i con p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> con -> g con
forall d. c d => d -> g d
f con
con

instance (GTraversable' c f) => GTraversable' c (M1 i meta f) where
  gtraverse' :: (forall d. c d => d -> g d)
-> forall p. M1 i meta f p -> g (M1 i meta f p)
gtraverse' forall d. c d => d -> g d
f (M1 f p
inner) = f p -> M1 i meta f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 i meta f p) -> g (f p) -> g (M1 i meta f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall d. c d => d -> g d) -> f p -> g (f p)
forall (c :: * -> Constraint) (f :: * -> *) (g :: * -> *).
(GTraversable' c f, Applicative g) =>
(forall d. c d => d -> g d) -> forall p. f p -> g (f p)
gtraverse' @c forall d. c d => d -> g d
f f p
inner

instance (GTraversable' c f, GTraversable' c g) => GTraversable' c (f :+: g) where
  gtraverse' :: (forall d. c d => d -> g d)
-> forall p. (:+:) f g p -> g ((:+:) f g p)
gtraverse' forall d. c d => d -> g d
f (L1 f p
val) = f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f p -> (:+:) f g p) -> g (f p) -> g ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall d. c d => d -> g d) -> f p -> g (f p)
forall (c :: * -> Constraint) (f :: * -> *) (g :: * -> *).
(GTraversable' c f, Applicative g) =>
(forall d. c d => d -> g d) -> forall p. f p -> g (f p)
gtraverse' @c forall d. c d => d -> g d
f f p
val
  gtraverse' forall d. c d => d -> g d
f (R1 g p
val) = g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g p -> (:+:) f g p) -> g (g p) -> g ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall d. c d => d -> g d) -> g p -> g (g p)
forall (c :: * -> Constraint) (f :: * -> *) (g :: * -> *).
(GTraversable' c f, Applicative g) =>
(forall d. c d => d -> g d) -> forall p. f p -> g (f p)
gtraverse' @c forall d. c d => d -> g d
f g p
val

instance (GTraversable' c f, GTraversable' c g) => GTraversable' c (f :*: g) where
  gtraverse' :: (forall d. c d => d -> g d)
-> forall p. (:*:) f g p -> g ((:*:) f g p)
gtraverse' forall d. c d => d -> g d
f (f p
left :*: g p
right)
    = f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f p -> g p -> (:*:) f g p) -> g (f p) -> g (g p -> (:*:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall d. c d => d -> g d) -> f p -> g (f p)
forall (c :: * -> Constraint) (f :: * -> *) (g :: * -> *).
(GTraversable' c f, Applicative g) =>
(forall d. c d => d -> g d) -> forall p. f p -> g (f p)
gtraverse' @c forall d. c d => d -> g d
f f p
left g (g p -> (:*:) f g p) -> g (g p) -> g ((:*:) f g p)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall d. c d => d -> g d) -> g p -> g (g p)
forall (c :: * -> Constraint) (f :: * -> *) (g :: * -> *).
(GTraversable' c f, Applicative g) =>
(forall d. c d => d -> g d) -> forall p. f p -> g (f p)
gtraverse' @c forall d. c d => d -> g d
f g p
right

instance (Traversable f, GTraversable' c g) => GTraversable' c (f :.: g) where
  gtraverse' :: (forall d. c d => d -> g d)
-> forall p. (:.:) f g p -> g ((:.:) f g p)
gtraverse' forall d. c d => d -> g d
f (Comp1 f (g p)
comp) = f (g p) -> (:.:) f g p
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (f (g p) -> (:.:) f g p) -> g (f (g p)) -> g ((:.:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (g p -> g (g p)) -> f (g p) -> g (f (g p))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((forall d. c d => d -> g d) -> forall p. g p -> g (g p)
forall (c :: * -> Constraint) (f :: * -> *) (g :: * -> *).
(GTraversable' c f, Applicative g) =>
(forall d. c d => d -> g d) -> forall p. f p -> g (f p)
gtraverse' @c forall d. c d => d -> g d
f) f (g p)
comp

instance
    {-# OVERLAPPABLE #-}
    (Generic a, GTraversable' c (Rep a))
  => GTraversable c a
  where
  gtraverse :: (forall d. c d => d -> f d) -> a -> f a
gtraverse forall d. c d => d -> f d
f a
val
    = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> f (Rep a Any) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall d. c d => d -> f d) -> Rep a Any -> f (Rep a Any)
forall (c :: * -> Constraint) (f :: * -> *) (g :: * -> *).
(GTraversable' c f, Applicative g) =>
(forall d. c d => d -> g d) -> forall p. f p -> g (f p)
gtraverse' @c forall d. c d => d -> f d
f (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
val)