Skip to content

Instantly share code, notes, and snippets.

@i-am-tom

i-am-tom/Main.hs

Last active June 27, 2019 14:07
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save i-am-tom/01008cdad8fe03370c50dd2927facfa1 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save i-am-tom/01008cdad8fe03370c50dd2927facfa1 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. Tom Harding revised this gist Jun 26, 2019. 1 changed file with 24 additions and 41 deletions.
    65 changes: 24 additions & 41 deletions Main.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -9,17 +9,21 @@ module Main where

    import Control.Applicative (Alternative (..))
    import qualified Data.Barbie as B
    import Data.Barbie.Constraints (Dict (..))
    import Data.Function ((&))
    import Data.Functor.Product (Product (..))
    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 = config setup >>= print . HKD.construct
    main = do
    parser <- hkdToParser setup

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

    print result

    data Config
    = Config
    @@ -59,40 +63,19 @@ data Option a
    }
    deriving Functor


    config
    :: (B.AllB Read (HKD b), B.ProductBC (HKD b), B.TraversableB (HKD b))
    => HKD b Option -> IO (HKD b Maybe)

    config options = do
    let alt this that = this `B.bprod` that & B.bmap \(Pair a b) -> a <|> b
    defaults = B.bmap _default options
    parser = Opt.info (flags options) mempty

    arguments <- Opt.execParser parser
    env <- environment options

    pure (arguments `alt` env `alt` defaults)


    environment
    :: (B.AllB Read (HKD b), B.ConstraintsB (HKD b), B.TraversableB (HKD b))
    => HKD b Option -> IO (HKD b Maybe)

    environment options
    = B.baddDicts @_ @_ @Read options & B.btraverse \(Pair Dict opt) -> do
    result <- lookupEnv (_flag opt)
    pure (result >>= readMaybe)


    flags
    :: B.TraversableB (HKD b)
    => HKD b Option -> Opt.Parser (HKD b Maybe)

    flags = B.btraverse (fmap Just . go)
    where
    go Option{..} = do
    -- If there's _help, make a `help` modifier.
    let description = maybe mempty Opt.help _help

    Opt.option (Opt.maybeReader _parse) (Opt.long _flag <> description)
    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)
    )
  2. Tom Harding revised this gist Jun 26, 2019. 1 changed file with 7 additions and 7 deletions.
    14 changes: 7 additions & 7 deletions Main.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -1,10 +1,10 @@
    {-# LANGUAGE BlockArguments #-}
    {-# LANGUAGE DeriveFunctor #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE MonoLocalBinds #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE TypeApplications #-}
    {-# LANGUAGE BlockArguments #-}
    {-# LANGUAGE DeriveFunctor #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE MonoLocalBinds #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE TypeApplications #-}
    module Main where

    import Control.Applicative (Alternative (..))
  3. Tom Harding revised this gist Jun 26, 2019. 1 changed file with 41 additions and 31 deletions.
    72 changes: 41 additions & 31 deletions Main.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -1,15 +1,14 @@
    {-# LANGUAGE BlockArguments #-}
    {-# LANGUAGE DeriveFunctor #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE DerivingVia #-}
    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE MonoLocalBinds #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TypeApplications #-}
    module Main where

    import Control.Applicative (Alternative (..))
    import Data.Barbie (AllB, baddDicts, bmap, bprod, btraverse)
    import qualified Data.Barbie as B
    import Data.Barbie.Constraints (Dict (..))
    import Data.Function ((&))
    import Data.Functor.Product (Product (..))
    @@ -20,7 +19,7 @@ import System.Environment (lookupEnv)
    import Text.Read (readMaybe)

    main :: IO ()
    main = config >>= print . HKD.construct
    main = config setup >>= print . HKD.construct

    data Config
    = Config
    @@ -29,18 +28,8 @@ data Config
    }
    deriving (Generic, Show)

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

    options :: HKD Config Option
    options
    setup :: HKD Config Option
    setup
    = build @Config
    do Option
    { _default = Just 42
    @@ -58,31 +47,52 @@ options
    , _help = Nothing
    }

    config :: AllB Read (HKD Config) => IO (HKD Config Maybe)
    config = do
    let alt :: HKD Config Maybe -> HKD Config Maybe -> HKD Config Maybe
    alt this that = this `bprod` that & bmap \(Pair a b) -> a <|> b
    -------------------------------------------

    defaults :: HKD Config Maybe
    defaults = bmap _default options
    data Option a
    = Option
    { _default :: Maybe a
    , _env :: Maybe String
    , _flag :: String
    , _parse :: String -> Maybe a
    , _help :: Maybe String
    }
    deriving Functor

    parser :: Opt.ParserInfo (HKD Config Maybe)
    parser = Opt.info flags mempty

    config
    :: (B.AllB Read (HKD b), B.ProductBC (HKD b), B.TraversableB (HKD b))
    => HKD b Option -> IO (HKD b Maybe)

    config options = do
    let alt this that = this `B.bprod` that & B.bmap \(Pair a b) -> a <|> b
    defaults = B.bmap _default options
    parser = Opt.info (flags options) mempty

    arguments <- Opt.execParser parser
    env <- environment options

    pure (arguments `alt` env `alt` defaults)

    environment <-
    baddDicts @_ @_ @Read options & btraverse \(Pair Dict opt) -> do

    environment
    :: (B.AllB Read (HKD b), B.ConstraintsB (HKD b), B.TraversableB (HKD b))
    => HKD b Option -> IO (HKD b Maybe)

    environment options
    = B.baddDicts @_ @_ @Read options & B.btraverse \(Pair Dict opt) -> do
    result <- lookupEnv (_flag opt)
    pure (result >>= readMaybe)

    pure (arguments `alt` environment `alt` defaults)

    flags :: Opt.Parser (HKD Config Maybe)
    flags = btraverse (fmap Just . go) options
    flags
    :: B.TraversableB (HKD b)
    => HKD b Option -> Opt.Parser (HKD b Maybe)

    flags = B.btraverse (fmap Just . go)
    where
    go Option{..} = do
    -- If there's _help, make a `help` modifier.
    let description = maybe mempty Opt.help _help

    Opt.option (Opt.maybeReader _parse) (Opt.long _flag <> description)
    Opt.option (Opt.maybeReader _parse) (Opt.long _flag <> description)
  4. Tom Harding created this gist Jun 26, 2019.
    88 changes: 88 additions & 0 deletions Main.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,88 @@
    {-# LANGUAGE BlockArguments #-}
    {-# LANGUAGE DeriveFunctor #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE DerivingVia #-}
    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TypeApplications #-}
    module Main where

    import Control.Applicative (Alternative (..))
    import Data.Barbie (AllB, baddDicts, bmap, bprod, btraverse)
    import Data.Barbie.Constraints (Dict (..))
    import Data.Function ((&))
    import Data.Functor.Product (Product (..))
    import Data.Generic.HKD as HKD
    import GHC.Generics (Generic)
    import qualified Options.Applicative as Opt
    import System.Environment (lookupEnv)
    import Text.Read (readMaybe)

    main :: IO ()
    main = config >>= print . HKD.construct

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

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

    options :: HKD Config Option
    options
    = 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
    }

    config :: AllB Read (HKD Config) => IO (HKD Config Maybe)
    config = do
    let alt :: HKD Config Maybe -> HKD Config Maybe -> HKD Config Maybe
    alt this that = this `bprod` that & bmap \(Pair a b) -> a <|> b

    defaults :: HKD Config Maybe
    defaults = bmap _default options

    parser :: Opt.ParserInfo (HKD Config Maybe)
    parser = Opt.info flags mempty

    arguments <- Opt.execParser parser

    environment <-
    baddDicts @_ @_ @Read options & btraverse \(Pair Dict opt) -> do
    result <- lookupEnv (_flag opt)
    pure (result >>= readMaybe)

    pure (arguments `alt` environment `alt` defaults)

    flags :: Opt.Parser (HKD Config Maybe)
    flags = btraverse (fmap Just . go) options
    where
    go Option{..} = do
    -- If there's _help, make a `help` modifier.
    let description = maybe mempty Opt.help _help

    Opt.option (Opt.maybeReader _parse) (Opt.long _flag <> description)