{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Options.Harg.Nested
  ( Nested (..),
    nested,
    getNested,
    fromNested,
  )
where

import qualified Barbies as B
import qualified Data.Aeson as JSON
import Data.Coerce (Coercible, coerce)
import Data.Functor.Identity (Identity (..))
import qualified Data.Generic.HKD as HKD
import Data.Kind (Type)
import GHC.Generics (Generic)

-- Orphan HKD FromJSON instance
instance
  JSON.GFromJSON JSON.Zero (HKD.HKD_ f structure) =>
  JSON.FromJSON (HKD.HKD structure f)
  where
  parseJSON :: Value -> Parser (HKD structure f)
parseJSON =
    (GHKD_ f (Rep structure) Void -> HKD structure f)
-> Parser (GHKD_ f (Rep structure) Void)
-> Parser (HKD structure f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GHKD_ f (Rep structure) Void -> HKD structure f
forall structure (f :: * -> *).
HKD_ f structure Void -> HKD structure f
HKD.HKD
      (Parser (GHKD_ f (Rep structure) Void) -> Parser (HKD structure f))
-> (Value -> Parser (GHKD_ f (Rep structure) Void))
-> Value
-> Parser (HKD structure f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options
-> FromArgs Zero Void
-> Value
-> Parser (GHKD_ f (Rep structure) Void)
forall arity (f :: * -> *) a.
GFromJSON arity f =>
Options -> FromArgs arity a -> Value -> Parser (f a)
JSON.gParseJSON Options
JSON.defaultOptions FromArgs Zero Void
forall a. FromArgs Zero a
JSON.NoFromArgs

-- | Newtype wrapper around 'HKD.HKD'.
newtype Nested (b :: Type) (f :: Type -> Type)
  = Nested (HKD.HKD b f)

type family
  Nest
    (a :: Type)
    (f :: Type -> Type) =
    (res :: Type) | res -> a
  where
  Nest (a -> b) f = a -> Nest b f
  Nest (HKD.HKD a f) f = Nested a f

-- | See documentation for 'HKD.build'
--
-- @
--   data User = User { name :: String, age :: Int }
--     deriving Generic
--
--   someNestedValue :: Nested User Maybe
--   someNestedValue
--     = nested @User (Just "Joe") (Just 30)
-- @
nested ::
  forall b f k.
  ( HKD.Build b f k,
    Coercible (HKD.HKD b f) (Nested b f),
    Coercible k (Nest k f)
  ) =>
  Nest k f
nested :: Nest k f
nested = k -> Nest k f
forall a b. Coercible a b => a -> b
coerce @k @(Nest k f) k
hkd
  where
    hkd :: k
hkd = Build b f k => k
forall structure (f :: * -> *) k. Build structure f k => k
HKD.build @b @f @k

-- | See documentation for 'HKD.construct'
--
-- @
--   data User = User { name :: String, age :: Int }
--     deriving Generic
--
--   getUserBack :: Maybe User
--   getUserBack
--     = getNested hkdUser
--     where
--       hkdUser :: Nested User Maybe
--       hkdUser
--         = nested @User (Just "Joe") (Just 30)
-- @
getNested ::
  HKD.Construct f b =>
  Nested b f ->
  f b
getNested :: Nested b f -> f b
getNested (Nested hkd :: HKD b f
hkd) = HKD b f -> f b
forall (f :: * -> *) structure.
Construct f structure =>
HKD structure f -> f structure
HKD.construct HKD b f
hkd

-- | Helper for when f ~ Identity
fromNested ::
  HKD.Construct Identity b =>
  Nested b Identity ->
  b
fromNested :: Nested b Identity -> b
fromNested =
  Identity b -> b
forall a. Identity a -> a
runIdentity (Identity b -> b)
-> (Nested b Identity -> Identity b) -> Nested b Identity -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nested b Identity -> Identity b
forall (f :: * -> *) b. Construct f b => Nested b f -> f b
getNested

deriving newtype instance Generic (HKD.HKD b f) => Generic (Nested b f)

deriving newtype instance JSON.FromJSON (HKD.HKD b f) => JSON.FromJSON (Nested b f)

deriving newtype instance B.FunctorB (HKD.HKD b) => B.FunctorB (Nested b)

deriving newtype instance B.ApplicativeB (HKD.HKD b) => B.ApplicativeB (Nested b)

instance (B.TraversableB (HKD.HKD b)) => B.TraversableB (Nested b) where
  btraverse :: (forall a. f a -> e (g a)) -> Nested b f -> e (Nested b g)
btraverse nat :: forall a. f a -> e (g a)
nat (Nested hkd :: HKD b f
hkd) = HKD b g -> Nested b g
forall b (f :: * -> *). HKD b f -> Nested b f
Nested (HKD b g -> Nested b g) -> e (HKD b g) -> e (Nested b g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. f a -> e (g a)) -> HKD b f -> e (HKD b 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 HKD b f
hkd