{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

module Options.Harg.Het.Prod
  ( (:*) (..),
    Tagged (..),
  )
where

import qualified Barbies as B
import Data.Aeson ((.!=), (.:?))
import qualified Data.Aeson as JSON
import Data.Functor.Identity (Identity)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import qualified Data.Text as Tx
import GHC.Generics (Generic)
import GHC.TypeLits (KnownSymbol, symbolVal)

-- | Infix version of 'Data.Functor.Product'. Allows to combine
-- higher-kinded types, and keep them partially applied until needed:
--
-- @
--   data User = User { name :: String, age :: Int }
--     deriving Generic
--
--   type Config = Nested User :* Single Int
--
--   configOpt :: Config Opt
--   configOpt = ...
-- @
data
  ( (a :: (Type -> Type) -> Type)
      :* (b :: (Type -> Type) -> Type)
  )
    (f :: Type -> Type)
  = a f :* b f
  deriving ((forall x. (:*) a b f -> Rep ((:*) a b f) x)
-> (forall x. Rep ((:*) a b f) x -> (:*) a b f)
-> Generic ((:*) a b f)
forall x. Rep ((:*) a b f) x -> (:*) a b f
forall x. (:*) a b f -> Rep ((:*) a b f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (f :: * -> *) x.
Rep ((:*) a b f) x -> (:*) a b f
forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (f :: * -> *) x.
(:*) a b f -> Rep ((:*) a b f) x
$cto :: forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (f :: * -> *) x.
Rep ((:*) a b f) x -> (:*) a b f
$cfrom :: forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (f :: * -> *) x.
(:*) a b f -> Rep ((:*) a b f) x
Generic, (forall (f :: * -> *) (g :: * -> *).
 (forall a. f a -> g a) -> (:*) a b f -> (:*) a b g)
-> FunctorB (a :* b)
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> (:*) a b f -> (:*) a b g
forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (f :: * -> *)
       (g :: * -> *).
(FunctorB a, FunctorB b) =>
(forall a. f a -> g a) -> (:*) a b f -> (:*) a b g
bmap :: (forall a. f a -> g a) -> (:*) a b f -> (:*) a b g
$cbmap :: forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (f :: * -> *)
       (g :: * -> *).
(FunctorB a, FunctorB b) =>
(forall a. f a -> g a) -> (:*) a b f -> (:*) a b g
B.FunctorB, FunctorB (a :* b)
FunctorB (a :* b) =>
(forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
 Applicative e =>
 (forall a. f a -> e (g a)) -> (:*) a b f -> e ((:*) a b g))
-> TraversableB (a :* b)
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
 Applicative e =>
 (forall (a :: k). f a -> e (g a)) -> b f -> e (b g))
-> TraversableB b
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> (:*) a b f -> e ((:*) a b g)
forall (a :: (* -> *) -> *) (b :: (* -> *) -> *).
(TraversableB a, TraversableB b) =>
FunctorB (a :* b)
forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (e :: * -> *)
       (f :: * -> *) (g :: * -> *).
(TraversableB a, TraversableB b, Applicative e) =>
(forall a. f a -> e (g a)) -> (:*) a b f -> e ((:*) a b g)
btraverse :: (forall a. f a -> e (g a)) -> (:*) a b f -> e ((:*) a b g)
$cbtraverse :: forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (e :: * -> *)
       (f :: * -> *) (g :: * -> *).
(TraversableB a, TraversableB b, Applicative e) =>
(forall a. f a -> e (g a)) -> (:*) a b f -> e ((:*) a b g)
$cp1TraversableB :: forall (a :: (* -> *) -> *) (b :: (* -> *) -> *).
(TraversableB a, TraversableB b) =>
FunctorB (a :* b)
B.TraversableB, FunctorB (a :* b)
FunctorB (a :* b) =>
(forall (f :: * -> *). (forall a. f a) -> (:*) a b f)
-> (forall (f :: * -> *) (g :: * -> *).
    (:*) a b f -> (:*) a b g -> (:*) a b (Product f g))
-> ApplicativeB (a :* b)
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (f :: k -> *). (forall (a :: k). f a) -> b f)
-> (forall (f :: k -> *) (g :: k -> *).
    b f -> b g -> b (Product f g))
-> ApplicativeB b
forall (f :: * -> *). (forall a. f a) -> (:*) a b f
forall (f :: * -> *) (g :: * -> *).
(:*) a b f -> (:*) a b g -> (:*) a b (Product f g)
forall (a :: (* -> *) -> *) (b :: (* -> *) -> *).
(ApplicativeB a, ApplicativeB b) =>
FunctorB (a :* b)
forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (f :: * -> *).
(ApplicativeB a, ApplicativeB b) =>
(forall a. f a) -> (:*) a b f
forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (f :: * -> *)
       (g :: * -> *).
(ApplicativeB a, ApplicativeB b) =>
(:*) a b f -> (:*) a b g -> (:*) a b (Product f g)
bprod :: (:*) a b f -> (:*) a b g -> (:*) a b (Product f g)
$cbprod :: forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (f :: * -> *)
       (g :: * -> *).
(ApplicativeB a, ApplicativeB b) =>
(:*) a b f -> (:*) a b g -> (:*) a b (Product f g)
bpure :: (forall a. f a) -> (:*) a b f
$cbpure :: forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (f :: * -> *).
(ApplicativeB a, ApplicativeB b) =>
(forall a. f a) -> (:*) a b f
$cp1ApplicativeB :: forall (a :: (* -> *) -> *) (b :: (* -> *) -> *).
(ApplicativeB a, ApplicativeB b) =>
FunctorB (a :* b)
B.ApplicativeB)

infixr 4 :*

deriving instance
  ( Show (a Identity),
    Show (b Identity)
  ) =>
  Show ((a :* b) Identity)

-- | This type adds a type-level phantom tag to a higher-kinded type.
-- Its JSON instance allows using ':*' with 'Options.Harg.Sources.JSON.JSONSource'.
newtype
  Tagged
    (t :: k)
    (a :: (Type -> Type) -> Type)
    (f :: Type -> Type) = Tagged
  { Tagged t a f -> a f
unTagged :: a f
  }
  deriving ((forall x. Tagged t a f -> Rep (Tagged t a f) x)
-> (forall x. Rep (Tagged t a f) x -> Tagged t a f)
-> Generic (Tagged t a f)
forall x. Rep (Tagged t a f) x -> Tagged t a f
forall x. Tagged t a f -> Rep (Tagged t a f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (t :: k) (a :: (* -> *) -> *) (f :: * -> *) x.
Rep (Tagged t a f) x -> Tagged t a f
forall k (t :: k) (a :: (* -> *) -> *) (f :: * -> *) x.
Tagged t a f -> Rep (Tagged t a f) x
$cto :: forall k (t :: k) (a :: (* -> *) -> *) (f :: * -> *) x.
Rep (Tagged t a f) x -> Tagged t a f
$cfrom :: forall k (t :: k) (a :: (* -> *) -> *) (f :: * -> *) x.
Tagged t a f -> Rep (Tagged t a f) x
Generic)

deriving newtype instance JSON.FromJSON (a f) => JSON.FromJSON (Tagged t a f)

instance B.FunctorB a => B.FunctorB (Tagged t a) where
  bmap :: (forall a. f a -> g a) -> Tagged t a f -> Tagged t a g
bmap nat :: forall a. f a -> g a
nat (Tagged x :: a f
x) = a g -> Tagged t a g
forall k (t :: k) (a :: (* -> *) -> *) (f :: * -> *).
a f -> Tagged t a f
Tagged ((forall a. f a -> g a) -> a f -> a g
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
B.bmap forall a. f a -> g a
nat a f
x)

instance B.TraversableB a => B.TraversableB (Tagged t a) where
  btraverse :: (forall a. f a -> e (g a)) -> Tagged t a f -> e (Tagged t a g)
btraverse nat :: forall a. f a -> e (g a)
nat (Tagged x :: a f
x) = a g -> Tagged t a g
forall k (t :: k) (a :: (* -> *) -> *) (f :: * -> *).
a f -> Tagged t a f
Tagged (a g -> Tagged t a g) -> e (a g) -> e (Tagged t a g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. f a -> e (g a)) -> a f -> e (a g)
forall k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
B.btraverse forall a. f a -> e (g a)
nat a f
x

instance B.ApplicativeB a => B.ApplicativeB (Tagged t a) where
  bprod :: Tagged t a f -> Tagged t a g -> Tagged t a (Product f g)
bprod (Tagged l :: a f
l) (Tagged r :: a g
r) = a (Product f g) -> Tagged t a (Product f g)
forall k (t :: k) (a :: (* -> *) -> *) (f :: * -> *).
a f -> Tagged t a f
Tagged (a f -> a g -> a (Product f g)
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
ApplicativeB b =>
b f -> b g -> b (Product f g)
B.bprod a f
l a g
r)
  bpure :: (forall a. f a) -> Tagged t a f
bpure f :: forall a. f a
f = a f -> Tagged t a f
forall k (t :: k) (a :: (* -> *) -> *) (f :: * -> *).
a f -> Tagged t a f
Tagged ((forall a. f a) -> a f
forall k (b :: (k -> *) -> *) (f :: k -> *).
ApplicativeB b =>
(forall (a :: k). f a) -> b f
B.bpure forall a. f a
f)

-- The following JSON instances need to work if and only if all elements in
-- the product are `Tagged`, hence the weird pattern matches
instance
  ( JSON.FromJSON (a Maybe),
    JSON.FromJSON (b' Maybe),
    B.ApplicativeB a,
    B.ApplicativeB b',
    KnownSymbol ta,
    b' ~ (Tagged tb b :* c)
  ) =>
  JSON.FromJSON ((Tagged ta a :* (Tagged tb b :* c)) Maybe)
  where
  parseJSON :: Value -> Parser ((:*) (Tagged ta a) (Tagged tb b :* c) Maybe)
parseJSON =
    String
-> (Object -> Parser ((:*) (Tagged ta a) (Tagged tb b :* c) Maybe))
-> Value
-> Parser ((:*) (Tagged ta a) (Tagged tb b :* c) Maybe)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject ":*" ((Object -> Parser ((:*) (Tagged ta a) (Tagged tb b :* c) Maybe))
 -> Value -> Parser ((:*) (Tagged ta a) (Tagged tb b :* c) Maybe))
-> (Object -> Parser ((:*) (Tagged ta a) (Tagged tb b :* c) Maybe))
-> Value
-> Parser ((:*) (Tagged ta a) (Tagged tb b :* c) Maybe)
forall a b. (a -> b) -> a -> b
$
      \o :: Object
o ->
        Tagged ta a Maybe
-> (:*) (Tagged tb b) c Maybe
-> (:*) (Tagged ta a) (Tagged tb b :* c) Maybe
forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (f :: * -> *).
a f -> b f -> (:*) a b f
(:*)
          (Tagged ta a Maybe
 -> (:*) (Tagged tb b) c Maybe
 -> (:*) (Tagged ta a) (Tagged tb b :* c) Maybe)
-> Parser (Tagged ta a Maybe)
-> Parser
     ((:*) (Tagged tb b) c Maybe
      -> (:*) (Tagged ta a) (Tagged tb b :* c) Maybe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser (Maybe (Tagged ta a Maybe))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? String -> Text
Tx.pack (Proxy ta -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy ta
forall k (t :: k). Proxy t
Proxy :: Proxy ta)) Parser (Maybe (Tagged ta a Maybe))
-> Tagged ta a Maybe -> Parser (Tagged ta a Maybe)
forall a. Parser (Maybe a) -> a -> Parser a
.!= (forall a. Maybe a) -> Tagged ta a Maybe
forall k (b :: (k -> *) -> *) (f :: k -> *).
ApplicativeB b =>
(forall (a :: k). f a) -> b f
B.bpure forall a. Maybe a
Nothing
          Parser
  ((:*) (Tagged tb b) c Maybe
   -> (:*) (Tagged ta a) (Tagged tb b :* c) Maybe)
-> Parser ((:*) (Tagged tb b) c Maybe)
-> Parser ((:*) (Tagged ta a) (Tagged tb b :* c) Maybe)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser ((:*) (Tagged tb b) c Maybe)
forall a. FromJSON a => Value -> Parser a
JSON.parseJSON (Object -> Value
JSON.Object Object
o)

instance
  ( JSON.FromJSON (a Maybe),
    JSON.FromJSON (b Maybe),
    B.ApplicativeB a,
    B.ApplicativeB b,
    KnownSymbol ta,
    KnownSymbol tb
  ) =>
  JSON.FromJSON ((Tagged ta a :* Tagged tb b) Maybe)
  where
  parseJSON :: Value -> Parser ((:*) (Tagged ta a) (Tagged tb b) Maybe)
parseJSON =
    String
-> (Object -> Parser ((:*) (Tagged ta a) (Tagged tb b) Maybe))
-> Value
-> Parser ((:*) (Tagged ta a) (Tagged tb b) Maybe)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject ":*" ((Object -> Parser ((:*) (Tagged ta a) (Tagged tb b) Maybe))
 -> Value -> Parser ((:*) (Tagged ta a) (Tagged tb b) Maybe))
-> (Object -> Parser ((:*) (Tagged ta a) (Tagged tb b) Maybe))
-> Value
-> Parser ((:*) (Tagged ta a) (Tagged tb b) Maybe)
forall a b. (a -> b) -> a -> b
$
      \o :: Object
o ->
        Tagged ta a Maybe
-> Tagged tb b Maybe -> (:*) (Tagged ta a) (Tagged tb b) Maybe
forall (a :: (* -> *) -> *) (b :: (* -> *) -> *) (f :: * -> *).
a f -> b f -> (:*) a b f
(:*)
          (Tagged ta a Maybe
 -> Tagged tb b Maybe -> (:*) (Tagged ta a) (Tagged tb b) Maybe)
-> Parser (Tagged ta a Maybe)
-> Parser
     (Tagged tb b Maybe -> (:*) (Tagged ta a) (Tagged tb b) Maybe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser (Maybe (Tagged ta a Maybe))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? String -> Text
Tx.pack (Proxy ta -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy ta
forall k (t :: k). Proxy t
Proxy :: Proxy ta)) Parser (Maybe (Tagged ta a Maybe))
-> Tagged ta a Maybe -> Parser (Tagged ta a Maybe)
forall a. Parser (Maybe a) -> a -> Parser a
.!= (forall a. Maybe a) -> Tagged ta a Maybe
forall k (b :: (k -> *) -> *) (f :: k -> *).
ApplicativeB b =>
(forall (a :: k). f a) -> b f
B.bpure forall a. Maybe a
Nothing
          Parser
  (Tagged tb b Maybe -> (:*) (Tagged ta a) (Tagged tb b) Maybe)
-> Parser (Tagged tb b Maybe)
-> Parser ((:*) (Tagged ta a) (Tagged tb b) Maybe)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe (Tagged tb b Maybe))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? String -> Text
Tx.pack (Proxy tb -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy tb
forall k (t :: k). Proxy t
Proxy :: Proxy tb)) Parser (Maybe (Tagged tb b Maybe))
-> Tagged tb b Maybe -> Parser (Tagged tb b Maybe)
forall a. Parser (Maybe a) -> a -> Parser a
.!= (forall a. Maybe a) -> Tagged tb b Maybe
forall k (b :: (k -> *) -> *) (f :: k -> *).
ApplicativeB b =>
(forall (a :: k). f a) -> b f
B.bpure forall a. Maybe a
Nothing