Created
June 21, 2019 15:57
-
-
Save jmackie/f47e2314144cb4f069c0b63c778f6c23 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment