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

module Options.Harg.Single
  ( Single (..),
    single,
    fromSingle,
  )
where

import qualified Barbies as B
import qualified Data.Aeson as JSON
import Data.Functor.Identity (Identity (..))
import qualified Data.Functor.Product as P
import Data.Kind (Type)
import GHC.Generics (Generic)

-- | @Single a f@ is a newtype around @f a@, which allows mixing non-nested
-- with nested values when creating configuration parsers, using
-- 'Options.Harg.Het.Prod.:*'.
--
-- @
--   data User = User { name :: String, age :: Int }
--     deriving Generic
--
--   myConfig :: (Nested User :* Single Int) Opt
--   myConfig
--     =  nested @User nameOpt ageOpt
--     :* single intOpt
--     where
--       ...
-- @
newtype Single (a :: Type) (f :: Type -> Type) = Single
  { Single a f -> f a
getSingle :: f a
  }

-- | Wrap a value into a 'Single'.
single :: f a -> Single a f
single :: f a -> Single a f
single = f a -> Single a f
forall a (f :: * -> *). f a -> Single a f
Single

-- | Helper for when f ~ Identity
fromSingle :: Single a Identity -> a
fromSingle :: Single a Identity -> a
fromSingle = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a)
-> (Single a Identity -> Identity a) -> Single a Identity -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Single a Identity -> Identity a
forall a (f :: * -> *). Single a f -> f a
getSingle

deriving instance (Show a, Show (f a)) => Show (Single a f)

deriving newtype instance Generic (f a) => Generic (Single a f)

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

instance B.FunctorB (Single a) where
  bmap :: (forall a. f a -> g a) -> Single a f -> Single a g
bmap nat :: forall a. f a -> g a
nat (Single p :: f a
p) = g a -> Single a g
forall a (f :: * -> *). f a -> Single a f
Single (f a -> g a
forall a. f a -> g a
nat f a
p)

instance B.TraversableB (Single a) where
  btraverse :: (forall a. f a -> e (g a)) -> Single a f -> e (Single a g)
btraverse nat :: forall a. f a -> e (g a)
nat (Single p :: f a
p) = g a -> Single a g
forall a (f :: * -> *). f a -> Single a f
Single (g a -> Single a g) -> e (g a) -> e (Single a g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> e (g a)
forall a. f a -> e (g a)
nat f a
p

instance B.ApplicativeB (Single a) where
  bprod :: Single a f -> Single a g -> Single a (Product f g)
bprod (Single l :: f a
l) (Single r :: g a
r) = Product f g a -> Single a (Product f g)
forall a (f :: * -> *). f a -> Single a f
Single (f a -> g a -> Product f g a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
P.Pair f a
l g a
r)
  bpure :: (forall a. f a) -> Single a f
bpure = (forall a. f a) -> Single a f
forall a (f :: * -> *). f a -> Single a f
Single