Dope.hs

{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
module Dope (main) where

import Prelude
import Data.Proxy
import Data.Generic.HKD as HKD
import GHC.Generics
import GHC.TypeLits
import Data.Semigroup (Last(..))
import Control.Monad (foldM)
import System.Environment
import Text.Read
import qualified Options.Applicative as Optparse
import Data.Functor.Const
import qualified Data.List as List
import Data.Functor.Compose
import Data.Barbie
import Data.Function ((&))

main :: IO ()
main = do
  cfg <- config
  case unPartial (HKD.construct cfg) of
    Nothing   -> putStrLn "shit"
    Just cfg' -> print cfg'

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

data Option a
  = Default a
  | Env (String -> Maybe a) String
  | Flag (String -> Maybe a) String String

newtype Partial a = Partial { unPartial :: Maybe (Last a) }
  deriving stock (Functor)
  deriving newtype (Semigroup)
  deriving (Applicative) via (Compose Maybe Last)

options :: HKD Config (Compose [] Option)
options
  = build @Config
      (Compose [ Default 42
               , Env readMaybe "FOO"
               , Flag readMaybe "foo" "help"
               ])

      (Compose [ Default "default"
               , Env pure "BAR"])

config :: IO (HKD Config Partial)
config = do
  env <- envVars
  let info = Optparse.info flags mempty
  flags <- Optparse.execParser info
  pure $
    bmap (Partial . fmap Last) defaults <>
    bmap (Partial . fmap Last) env <>
    bmap (Partial . fmap Last) flags

defaults :: HKD Config Maybe
defaults
  = options & bmap (go . getCompose)
  where
  go [] = Nothing
  go (Default a : _ ) = Just a
  go (_ : rest) = go rest

envVars :: IO (HKD Config Maybe)
envVars
  = options & btraverse (go . getCompose)
  where
  go [] = pure Nothing
  go (Env parse var : _ ) = do
      x <- lookupEnv var
      case x >>= parse of
        Nothing -> pure Nothing
        Just x' -> pure (Just x')
  go (_ : rest) = go rest

flags :: Optparse.Parser (HKD Config Maybe)
flags
  = options & btraverse (go . getCompose)
  where
  go [] = pure Nothing
  go (Flag parse flag help : _ ) =
      Just <$> Optparse.option
               (Optparse.maybeReader parse)
               (Optparse.long flag <> Optparse.help help)
  go (_ : rest) = go rest