{-# LANGUAGE BlockArguments   #-}
{-# LANGUAGE DeriveFunctor    #-}
{-# LANGUAGE DeriveGeneric    #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds   #-}
{-# LANGUAGE RecordWildCards  #-}
{-# LANGUAGE TypeApplications #-}
module Main where

import Control.Applicative (Alternative (..))
import qualified Data.Barbie as B
import Data.Generic.HKD as HKD
import GHC.Generics (Generic)
import qualified Options.Applicative as Opt
import Options.Applicative ((<**>))
import System.Environment (lookupEnv)
import Text.Read (readMaybe)

main :: IO ()
main = do
  parser <- hkdToParser setup

  let opts = Opt.info (parser <**> Opt.helper) mempty
  result <- Opt.execParser opts
  
  print result

data Config
  = Config
      { configFoo :: Int
      , configBar :: String
      }
  deriving (Generic, Show)

setup :: HKD Config Option
setup
  = build @Config
      do Option
           { _default = Just 42
           , _env     = Just "FOO"
           , _flag    = "foo"
           , _parse   = readMaybe
           , _help    = Just "help"
           }

      do Option
          { _default = Nothing
          , _env     = Just "BAR"
          , _flag    = "bar"
          , _parse   = pure
          , _help    = Nothing
          }

-------------------------------------------

data Option a
  = Option
      { _default :: Maybe a
      , _env     :: Maybe String
      , _flag    :: String
      , _parse   :: String -> Maybe a
      , _help    :: Maybe String
      }
  deriving Functor

hkdToParser
  :: (B.TraversableB (HKD b), Generic b, HKD.Construct Opt.Parser b)
  => HKD b Option -> IO (Opt.Parser b)

hkdToParser = fmap construct . B.btraverse \Option{..} -> do
  fallback <- case _env of
    Just name -> lookupEnv name
    Nothing   -> pure Nothing

  let parsed = fallback >>= _parse
  
  pure $ Opt.option (Opt.maybeReader _parse)
     (              Opt.long   _flag
    <> maybe mempty Opt.help   _help
    <> maybe mempty Opt.value (parsed <|> _default)
     )