No, I'm not crazy

Configuration.hs

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE AllowAmbiguousTypes        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE RoleAnnotations            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}
module Configuration where

import           Data.Char                     (toUpper)
import           Data.Functor.Compose          (Compose (..))
import qualified Data.Functor.Identity         as Id
import qualified Data.Functor.Product          as P
import           Data.Kind                     (Constraint, Type)
import           Data.Proxy                    (Proxy(..))
import           Data.Type.Equality            ((:~~:)(..))
import           GHC.Generics                  (Generic, Rep)
import           GHC.TypeLits                  (ErrorMessage(..), TypeError, Symbol, KnownSymbol, symbolVal)
import qualified System.Environment            as Env
import           Text.Read                     (readMaybe)

import qualified Data.Barbie                   as B
import           Data.Barbie.Constraints       (Dict (..))
import qualified Data.Generic.HKD              as HKD
import qualified Data.Generic.HKD.Build        as HKD.B
import qualified Data.Generic.HKD.Construction as HKD.C
import qualified Options.Applicative           as Args

main :: IO ()
main = do
  -- basic
  -- c <- getAppConfig

  -- sum type
  -- c <- getOpt' appOptions testAppOptions
  -- case c of
  --   TheAppConfig (AppConfigB db srv) ->
  --     print $ AppConfig <$> HKD.construct db <*> HKD.construct srv
  --   TheTestAppConfig (TestAppConfigB db tst) ->
  --     print $ TestAppConfig <$> HKD.construct db <*> HKD.construct tst

  -- hlist/variant
  -- c <- getOptH $ HCons appOptions (HCons testAppOptions HNil)
  -- case c of
    -- HereF (AppConfigB db srv) ->
      -- print $ AppConfig <$> HKD.construct db <*> HKD.construct srv
    -- ThereF (HereF (TestAppConfigB db tst)) ->
      -- print $ TestAppConfig <$> HKD.construct db <*> HKD.construct tst

  -- tagged
  -- c <- getOptHGenTag optTagged
  -- foldF c
    -- (\(AppConfigB db srv) ->
        -- print $ AppConfig <$> HKD.construct db <*> HKD.construct srv)
    -- (\(TestAppConfigB db tst) ->
        -- print $ TestAppConfig <$> HKD.construct db <*> HKD.construct tst)

  -- product
  -- d :* s :* x :* _ <- getOptions optProd
  -- print $ B.bsequence' d
  -- print $ HKD.construct d
  -- print $ HKD.construct s
  -- print $ B.bsequence' x

  -- sumproduct
  c <- getOptHGenTag optSumProd
  -- c <- getOptions optSumProd
  case c of
    HereF a -> print $ B.bsequence' a
    ThereF (HereF t) -> print $ B.bsequence' t

-- Types
data Opt a
  = Opt
      { _oName    :: String
      , _oHelp    :: String
      , _oMetavar :: String
      , _oDefault :: Maybe a
      , _oEnvVar  :: String
      , _oParser  :: String -> Maybe a
      }
  deriving Functor

data OptValue a
  = OptPresent a
  | OptNotPresent [String]
  | OptInvalid [String]
  deriving (Functor, Foldable, Traversable)

deriving instance Show a => Show (OptValue a)

instance Applicative OptValue where
  pure = OptPresent

  OptPresent f    <*> OptPresent a    = OptPresent (f a)
  OptInvalid x    <*> OptInvalid y    = OptInvalid (x <> y)
  OptInvalid x    <*> _               = OptInvalid x
  _               <*> OptInvalid x    = OptInvalid x
  OptNotPresent x <*> OptNotPresent y = OptNotPresent (x <> y)
  OptNotPresent x <*> _               = OptNotPresent x
  _               <*> OptNotPresent x = OptNotPresent x

instance Monad OptValue where
  return = pure

  OptPresent x    >>= f = f x
  OptNotPresent x >>= _ = OptNotPresent x
  OptInvalid x    >>= _ = OptInvalid x

instance Semigroup (OptValue a) where
  l <> r
    = case l of
        OptNotPresent _ -> r
        _               -> l

newtype Barbie (barbie :: (Type -> Type) -> Type) (f :: Type -> Type)
  = Barbie (barbie f)
  deriving newtype (Generic, B.ProductB, B.FunctorB)

instance (B.FunctorB b, B.ProductB b) => Semigroup (Barbie b OptValue) where
  l <> r = B.bmap (\(P.Pair x y) -> x <> y) (l `B.bprod` r)

-- Operations
parseOpt :: Opt a -> Maybe String -> OptValue a
parseOpt Opt{..}
  = maybe (OptNotPresent [_oName]) $
      maybe (OptInvalid [_oName]) OptPresent
        . _oParser

fromArg :: Opt a -> Args.Parser (OptValue a)
fromArg opt@Opt{..}
  =   parseOpt opt
  <$> Args.optional
        ( Args.strOption
        $    Args.long _oName
          <> Args.metavar _oMetavar
          <> Args.help _oHelp
        )

fromEnv :: Opt a -> IO (OptValue a)
fromEnv opt
  = parseOpt opt <$> Env.lookupEnv (_oEnvVar opt)

fromDef :: Opt a -> OptValue a
fromDef Opt{..}
  = maybe (OptNotPresent [_oName]) OptPresent _oDefault

getOpt
  :: ( B.FunctorB a
     , B.TraversableB a
     , Semigroup (a OptValue)
     )
  => a Opt
  -> IO (a OptValue)
getOpt opts = do
  aOpt <- Args.execParser $
    Args.info (Args.helper <*> B.btraverse fromArg opts) mempty

  eOpt <- B.btraverse fromEnv opts

  let
    dOpt = B.bmap fromDef opts

  pure (aOpt <> eOpt <> dOpt)

-- configuration
data DBConfig
  = DBConfig
      { _dbUser :: String
      , _dbPort :: Int
      }
  deriving (Show, Generic)

data ServiceConfig
  = ServiceConfig
      { _srvPort :: Int
      , _srvLog  :: Bool
      }
  deriving (Show, Generic)

data TestConfig
  = TestConfig
      { _tDir  :: String
      , _tMock :: Bool
      }
  deriving (Show, Generic)

data AppConfig
  = AppConfig
      { _acDbConfig      :: DBConfig
      , _scServiceConfig :: ServiceConfig
      }
  deriving Show

data AppConfigB f
  = AppConfigB
      { _acDbConfigB      :: HKD.HKD DBConfig f
      , _scServiceConfigB :: HKD.HKD ServiceConfig f
      }
  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)

deriving via (Barbie AppConfigB OptValue) instance Semigroup (AppConfigB OptValue)

deriving instance Show (AppConfigB OptValue)

data TestAppConfig
  = TestAppConfig
      { _tacDbConfig   :: DBConfig
      , _tacTestConfig :: TestConfig
      }
  deriving Show

data TestAppConfigB f
  = TestAppConfigB
      { _tacDbConfigB   :: HKD.HKD DBConfig f
      , _tacTestConfigB :: HKD.HKD TestConfig f
      }
  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)

deriving via (Barbie TestAppConfigB OptValue) instance Semigroup (TestAppConfigB OptValue)

deriving instance Show (TestAppConfigB OptValue)
deriving instance Show (TestAppConfigB Id.Identity)

mkStringOpt :: String -> Maybe String -> Opt String
mkStringOpt n d
  = Opt
      { _oName    = n
      , _oHelp    = "Help for " <> n
      , _oMetavar = map toUpper n
      , _oDefault = d
      , _oEnvVar  = map toUpper n
      , _oParser  = pure
      }

mkReadOpt :: Read a => String -> Maybe a -> Opt a
mkReadOpt n d
  = Opt
      { _oName    = n
      , _oHelp    = "Help for " <> n
      , _oMetavar = map toUpper n
      , _oDefault = d
      , _oEnvVar  = map toUpper n
      , _oParser  = readMaybe
      }

dbConf :: HKD.HKD DBConfig Opt
dbConf
  = HKD.build @DBConfig
      (mkStringOpt "db_user" Nothing)
      (mkReadOpt "db_port" (Just 5432))

appOptions :: AppConfigB Opt
appOptions
  = AppConfigB dbConf srvConf
  where
    srvConf
      = HKD.build @ServiceConfig
          (mkReadOpt "port" Nothing)
          (mkReadOpt "log" (Just True))

testAppOptions :: TestAppConfigB Opt
testAppOptions
  = TestAppConfigB dbConf testConf
  where
    testConf
      = HKD.build @TestConfig
          (mkStringOpt "dir" Nothing)
          (mkReadOpt "mock" (Just False))

getAppConfig :: IO (OptValue AppConfig)
getAppConfig
  = do
      (AppConfigB db srv) <- getOpt appOptions
      pure $ AppConfig <$> HKD.construct db <*> HKD.construct srv

data ConfigB f
  = TheAppConfig (AppConfigB f)
  | TheTestAppConfig (TestAppConfigB f)
  deriving (Generic, B.FunctorB, B.TraversableB)

deriving instance Show (ConfigB OptValue)

instance Semigroup (ConfigB OptValue) where
  TheAppConfig x <> TheAppConfig y = TheAppConfig (x <> y)
  TheTestAppConfig x <> TheTestAppConfig y = TheTestAppConfig (x <> y)

getOpt'
  :: AppConfigB Opt
  -> TestAppConfigB Opt
  -> IO (ConfigB OptValue)
getOpt' ao to = do
  let
    commands
      = [ Args.command "app" $ TheAppConfig <$> Args.info (Args.helper <*> B.btraverse fromArg ao) mempty
        , Args.command "test" $ TheTestAppConfig <$> Args.info (Args.helper <*> B.btraverse fromArg to) mempty
        ]

  aOpt <- Args.execParser $
    Args.info (Args.helper <*> Args.subparser (mconcat commands)) mempty

  let
    opts
      = case aOpt of
          TheAppConfig     a -> TheAppConfig ao
          TheTestAppConfig t -> TheTestAppConfig to

  eOpt <- B.btraverse fromEnv opts

  let
    dOpt = B.bmap fromDef opts

  pure $ aOpt <> eOpt <> dOpt


type family All (c :: k -> Constraint) (xs :: [kk]) :: Constraint where
  All _ '[]       = ()
  All c (x ': xs) = (c x, All c xs)

type HKType = (Type -> Type) -> Type

data VariantF (xs :: [HKType]) (f :: Type -> Type) where
  HereF  :: x f           -> VariantF (x ': xs) f
  ThereF :: VariantF xs f -> VariantF (y ': xs) f

instance ( B.FunctorB x
         , B.FunctorB (VariantF xs)
         ) => B.FunctorB (VariantF (x ': xs)) where
  bmap nat (HereF x) = HereF $ B.bmap nat x
  bmap nat (ThereF xs) = ThereF $ B.bmap nat xs

instance B.FunctorB (VariantF '[]) where
  bmap _ _ = error "not possible"

instance ( B.TraversableB x
         , B.TraversableB (VariantF xs)
         ) => B.TraversableB (VariantF (x ': xs)) where
  btraverse nat (HereF x) = HereF <$> B.btraverse nat x
  btraverse nat (ThereF xs) = ThereF <$> B.btraverse nat xs

instance B.TraversableB (VariantF '[]) where
  btraverse _ _ = error "not possible"

type family AllShow (xs :: [HKType]) (f :: Type -> Type) :: Constraint where
  AllShow '[]       f = ()
  AllShow (x ': xs) f = (Show (x f), AllShow xs f)

deriving instance AllShow xs OptValue => Show (VariantF xs OptValue)

class InjectF (x :: HKType) (xs :: [HKType]) where
  injectF :: x f -> VariantF xs f

class InjectFLoop x xs (initial :: [HKType]) where
  injectF' :: x f -> VariantF xs f

instance InjectFLoop x xs xs => InjectF x xs where
  injectF = injectF' @_ @_ @xs

instance InjectFLoop x (x ': xs) initial where
  injectF' = HereF

instance {-# OVERLAPPABLE #-} InjectFLoop x xs initial
    => InjectFLoop x (y ': xs) initial where
  injectF' = ThereF . injectF' @_ @_ @initial

type family FoldSignatureF (xs :: [HKType]) r f where
  FoldSignatureF (x ': xs) r f = (x f -> r) -> FoldSignatureF xs r f
  FoldSignatureF '[] r f = r

class BuildFoldF xs result f where
  foldF :: VariantF xs f -> FoldSignatureF xs result f

instance BuildFoldF '[x] result f where
  foldF (HereF  x) f = f x
  foldF (ThereF _) _ = error "impossibru"

instance ( tail ~ (x' ': xs)
         , BuildFoldF tail result f
         , IgnoreF tail result f
         ) => BuildFoldF (x ': x' ': xs) result f where
  foldF (ThereF x) _ = foldF @_ @result x
  foldF (HereF  x) f = ignoreF @tail (f x)

class IgnoreF (args :: [HKType]) result f where
  ignoreF :: result -> FoldSignatureF args result f

instance IgnoreF '[] result f where
  ignoreF result = result

instance IgnoreF xs result f => IgnoreF (x ': xs) result f where
  ignoreF result _ = ignoreF @xs @_ @f result

type family AllSemigroup (xs :: [HKType]) (f :: Type -> Type) :: Constraint where
  AllSemigroup '[]       f = ()
  AllSemigroup (x ': xs) f = (Semigroup (x f), AllSemigroup xs f)

instance AllSemigroup xs OptValue => Semigroup (VariantF xs OptValue) where
  HereF  x <> HereF  y = HereF  (x <> y)
  ThereF x <> ThereF y = ThereF (x <> y)

data HList (xs :: [Type]) where
  HNil  :: HList '[]
  HCons :: x -> HList xs -> HList (x ': xs)

deriving instance All Show xs => Show (HList xs)

data Nat = Z | S Nat

data SNat (n :: Nat) where
  SZ :: SNat Z
  SS :: SNat n -> SNat (S n)

class               IsNat (n :: Nat) where nat :: SNat n
instance            IsNat Z          where nat =  SZ
instance IsNat n => IsNat (S n)      where nat =  SS nat

getOptH
  :: HList '[AppConfigB Opt, TestAppConfigB Opt]
  -> IO (VariantF '[AppConfigB, TestAppConfigB] OptValue)
getOptH (HCons ao (HCons to HNil)) = do
  let
    commands
      = [ Args.command "app"
            $ injectF <$> Args.info (Args.helper <*> B.btraverse fromArg ao) mempty
        , Args.command "test"
            $ injectF <$> Args.info (Args.helper <*> B.btraverse fromArg to) mempty
        ]

  aOpt <- Args.execParser $
    Args.info (Args.helper <*> Args.subparser (mconcat commands)) mempty

  let
    opts = foldF aOpt (const $ injectF ao) (const $ injectF to)

  eOpt <- B.btraverse fromEnv opts

  let
    dOpt = B.bmap fromDef opts

  pure $ aOpt <> eOpt <> dOpt

data HListF (xs :: [HKType]) (f :: Type -> Type) where
  HNilF  :: HListF '[] f
  HConsF :: x f -> HListF xs f -> HListF (x ': xs) f

deriving instance AllShow xs OptValue => Show (HListF xs OptValue)
deriving instance AllShow xs Id.Identity => Show (HListF xs Id.Identity)

instance ( B.FunctorB x
         , B.FunctorB (HListF xs)
         ) => B.FunctorB (HListF (x ': xs)) where
  bmap nat (HConsF x xs)
    = HConsF (B.bmap nat x) (B.bmap nat xs)

instance B.FunctorB (HListF '[]) where
  bmap _ HNilF = HNilF

instance ( B.TraversableB x
         , B.TraversableB (HListF xs)
         ) => B.TraversableB (HListF (x ': xs)) where
  btraverse nat (HConsF x xs)
    = HConsF <$> B.btraverse nat x <*> B.btraverse nat xs

instance B.TraversableB (HListF '[]) where
  btraverse _ HNilF = pure HNilF

instance AllSemigroup xs OptValue => Semigroup (HListF xs OptValue) where
  HConsF x xs <> HConsF y ys = HConsF (x <> y) (xs <> ys)
  x           <> HNilF       = x

class MapVariantF (xs :: [HKType]) where
  mapVariantF :: VariantF xs g -> HListF xs f -> VariantF xs f

instance MapVariantF xs => MapVariantF (x ': xs) where
  mapVariantF (HereF _) (HConsF x _) = HereF x
  mapVariantF (ThereF v) (HConsF _ l) = ThereF $ mapVariantF v l

instance MapVariantF '[] where
  mapVariantF _ _ = error "not possible"

class InjectPosF (n :: Nat) (x :: HKType) (xs :: [HKType]) where
  injectPosF :: SNat n -> (x f -> VariantF xs f)

instance InjectPosF Z x (x ': xs) where
  injectPosF SZ = HereF

instance InjectPosF n x xs => InjectPosF (S n) x (y ': xs) where
  injectPosF (SS n) = ThereF . injectPosF n

type family (xs :: [k]) ++ (ts :: [k]) = (res :: [k]) where
  '[]       ++ ys = ys
  (x ': xs) ++ ys = x ': (xs ++ ys)

-- same as `gcastWith` but for heterogeneous propositional equality
hgcastWith :: (a :~~: b) -> (a ~ b => r) -> r
hgcastWith HRefl x = x

class ProofNil xs where
  proofNil :: xs ++ '[] :~~: xs

instance ProofNil '[] where
  proofNil = HRefl

instance ProofNil xs => ProofNil (x ': xs) where
  proofNil = hgcastWith (proofNil @xs) HRefl

instance ProofNil (xs ++ '[y]) => Proof (x ': xs) y '[] where
  proof = hgcastWith (proofNil @(xs ++ '[y])) HRefl

class Proof (xs :: [HKType]) (y :: HKType) (ys :: [HKType]) where
  proof :: xs ++ (y ': ys) :~~: (xs ++ '[y]) ++ ys

instance Proof '[] y ys where
  proof = HRefl

class Subcommands (n :: Nat) (ts :: [Symbol]) (xs :: [HKType]) (acc :: [HKType]) where
  mapSubcommand
    :: SNat n
    -> AssocList ts xs Opt
    -> [Args.Mod Args.CommandFields (VariantF (acc ++ xs) OptValue)]

instance Subcommands n '[] '[] acc where
  mapSubcommand _ _ = []

instance ( Subcommands (S n) ts xs (as ++ '[x])
         , InjectPosF n x (as ++ (x ': xs))
         , B.TraversableB x
         , KnownSymbol t
         , Proof as x xs
         ) => Subcommands n (t ': ts) (x ': xs) as where
  mapSubcommand n (ACons x xs)
    = subcommand
    : hgcastWith
        (proof @as @x @xs)
        (mapSubcommand @(S n) @ts @xs @(as ++ '[x]) (SS n) xs)
    where
      subcommand :: Args.Mod Args.CommandFields (VariantF (as ++ (x ': xs)) OptValue)
        = Args.command tag
            $ injectPosF n <$> Args.info (Args.helper <*> B.btraverse fromArg x) mempty
      tag
        = symbolVal (Proxy :: Proxy t)

data AssocList (ts :: [Symbol]) (xs :: [HKType]) (f :: Type -> Type) where
  ANil  :: AssocList '[] '[] f
  ACons :: x f -> AssocList ts xs f -> AssocList (t ': ts) (x ': xs) f

type family l :+: r = (res :: (Type -> Type) -> Type) where
  (tl :-> vl) :+: (tr :-> vr) = AssocList '[tl, tr] '[vl, vr]
  (tl :-> vl) :+: AssocList ts vs = AssocList (tl ': ts) (vl ': vs)
  l :+: r = TypeError ('Text "TODO")

infixr 4 :+:

data (t :: Symbol) :-> (v :: HKType) :: (Type -> Type) -> Type

infixr 5 :->

type SomeConfigB
  =   "app" :-> AppConfigB
  :+: "test" :-> TestAppConfigB

pattern (:+) :: x f -> AssocList ts xs f -> AssocList (t ': ts) (x ': xs) f
pattern x :+ xs = ACons x xs

infixr 4 :+

optTagged :: SomeConfigB Opt
optTagged = appOptions :+ testAppOptions :+ ANil

assocToHListF :: AssocList ts xs f -> HListF xs f
assocToHListF ANil = HNilF
assocToHListF (ACons x xs) = HConsF x $ assocToHListF xs

getOptHGenTag
  :: forall a xs ts n.
     ( B.TraversableB (VariantF xs)
     , AllSemigroup xs OptValue
     , MapVariantF xs
     , Subcommands Z ts xs '[]
     )
  => AssocList ts xs Opt
  -> IO (VariantF xs OptValue)
getOptHGenTag alist = do
  let
    commands
      = mapSubcommand @Z @ts @xs @'[] SZ alist

  aOpt <- Args.execParser $
    Args.info (Args.helper <*> Args.subparser (mconcat commands)) mempty

  let
    hlist
      = assocToHListF alist
    opts
      = mapVariantF aOpt hlist

  eOpt <- B.btraverse fromEnv opts

  let
    dOpt = B.bmap fromDef opts

  pure $ aOpt <> eOpt <> dOpt

class GetOpt a where
  type OptOut a :: Type
  getOptions :: a -> IO (OptOut a)

type family OptOut' a where
  OptOut' (AssocList ts xs) = VariantF xs OptValue
  OptOut' a = a OptValue

instance {-# OVERLAPPING #-}
         ( B.TraversableB (VariantF xs)
         , AllSemigroup xs OptValue
         , MapVariantF xs
         , Subcommands Z ts xs '[]
         ) => GetOpt (AssocList ts xs Opt) where
  type OptOut (AssocList ts xs Opt) = OptOut' (AssocList ts xs)
  getOptions = getOptHGenTag

instance ( B.FunctorB a
         , B.TraversableB a
         , Semigroup (a OptValue)
         , OptOut' a ~ a OptValue
         ) => GetOpt (a Opt) where
  type OptOut (a Opt) = OptOut' a
  getOptions = getOpt

newtype Nested (b :: Type) (f :: Type -> Type)
  = Nested
      { _getNested :: HKD.HKD b f
      }

-- TODO
nest
  :: forall b f k.
     ( HKD.Build b f k
     )
  => k
nest = hkd
  where hkd = HKD.build @b @f @k

unNest
  :: ( Applicative f
     , Generic b
     , HKD.C.Construct f b
     )
  => Nested b f
  -> f b
unNest (Nested hkd) = HKD.construct hkd

deriving newtype instance Generic (HKD.HKD b f) => Generic (Nested b f)
deriving newtype instance B.FunctorB (HKD.HKD b) => B.FunctorB (Nested b)
deriving newtype instance B.ProductB (HKD.HKD b) => B.ProductB (Nested b)
deriving via (Barbie (Nested b) OptValue)
  instance ( B.FunctorB (Nested b)
           , B.ProductB (Nested b)
           ) => Semigroup (Nested b OptValue)

instance (B.TraversableB (HKD.HKD b)) => B.TraversableB (Nested b) where
  btraverse nat (Nested hkd) = Nested <$> B.btraverse nat hkd

newtype Param (b :: Type) (f :: Type -> Type)
  = Param
      { _getParam :: f b
      }

mkParam :: f b -> Param b f
mkParam = Param

deriving instance (Show b, Show (f b)) => Show (Param b f)

deriving newtype instance Generic (f b) => Generic (Param b f)

deriving via (Barbie (Param b) OptValue)
  instance ( B.FunctorB (Param b)
           , B.ProductB (Param b)
           ) => Semigroup (Param b OptValue)

instance B.FunctorB (Param b) where
  bmap nat (Param p) = Param (nat p)

instance B.ProductB (Param b) where
  bprod (Param l) (Param r) = Param (P.Pair l r)
  buniq = Param

instance B.TraversableB (Param b) where
  btraverse nat (Param p) = Param <$> nat p

type family (l :: HKType) :*: (r :: HKType) = (res :: (Type -> Type) -> Type) where
  l :*: HListF rs = HListF (l ': rs)
  l :*: r = HListF '[l, r]

infixr 4 :*:

pattern (:*) :: x f -> HListF xs f -> HListF (x ': xs) f
pattern x :* xs = HConsF x xs

infixr 4 :*

-- type AppConfigH f
--   = HListF '[HKD.HKD DBConfig, HKD.HKD ServiceConfig, Param String] f

type AppConfigH
  =   HKD.HKD DBConfig
  :*: HKD.HKD ServiceConfig
  :*: Param String

optProd :: AppConfigH Opt
optProd
  = dbConf :* srvConf :* mkParam (mkStringOpt "hehe" Nothing) :* HNilF
  where
    srvConf
      = HKD.build @ServiceConfig
          (mkReadOpt "port" Nothing)
          (mkReadOpt "log" (Just True))

type SumConfig
  =   "app" :-> AppConfigH
  :+: "test" :-> TestAppConfigB

optSumProd
  :: SumConfig Opt
optSumProd
  =  optProd :+ testAppOptions :+ ANil