packages feed

harg (empty) → 0.1.0.0

raw patch · 30 files changed

+3969/−0 lines, 30 filesdep +aesondep +barbiesdep +basesetup-changed

Dependencies added: aeson, barbies, base, bytestring, directory, harg, higgledy, optparse-applicative, text, yaml

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# Changelog for harg++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Alex Peitsinis (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Alex Peitsinis nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.lhs view
@@ -0,0 +1,721 @@+# `harg` :nut_and_bolt:++[![Build Status](https://travis-ci.org/alexpeits/harg.svg?branch=master)](https://travis-ci.org/alexpeits/harg)++`harg` is a library for configuring programs by scanning command line arguments, environment+variables and default values. Under the hood, it uses a subset of+[`optparse-applicative`](https://hackage.haskell.org/package/optparse-applicative) to expose regular+arguments, switch arguments and subcommands. The library relies heavily on the use of higher kinded+data (HKD) thanks to the [`barbies`](https://hackage.haskell.org/package/barbies) library. Using+[`higgledy`](https://hackage.haskell.org/package/higgledy) also allows to have significantly less+boilerplate code.++The main goal while developing `harg` was to not have to go through the usual pattern of manually+`mappend`ing the results of command line parsing, env vars and defaults.++# Usage++tl;dr: Take a look at the [example](Example.hs).++(WIP)++Here are some different usage scenarios. Let's first enable some language extensions and add some+imports:++``` haskell+{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE KindSignatures     #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications   #-}+{-# LANGUAGE TypeOperators      #-}++import           Data.Function         ((&))+import           Data.Functor.Identity (Identity (..))+import           Data.Kind             (Type)+import           GHC.Generics          (Generic)++import qualified Data.Barbie           as B+import           Data.Aeson            (FromJSON)+import           Data.Generic.HKD      (HKD, build, construct)++import           Options.Harg++main :: IO ()+main = putStrLn "this is a literate haskell file"+```++## One flat (non-nested) datatype++The easiest scenario is when the target configuration type is one single record with no levels of+nesting:++``` haskell+data FlatConfig+  = FlatConfig+      { _fcDbHost :: String+      , _fcDbPort :: Int+      , _fcDir    :: String+      , _fcLog    :: Bool  -- whether to log or not+      }+  deriving (Show, Generic)+```++(The `Generic` instance is required for section `3` later on)++Let's first create the `Opt`s for each value in `FlatConfig`. `Opt` is the description for each+component of the configuration.++``` haskell+dbHostOpt :: Opt String+dbHostOpt+  = toOpt ( option strParser+          & optLong "host"+          & optShort 'h'+          & optMetavar "DB_HOST"+          & optHelp "The database host"+          )++dbPortOpt :: Opt Int+dbPortOpt+  = toOpt ( option readParser+          & optLong "port"+          & optHelp "The database port"+          & optEnvVar "DB_PORT"+          & optDefault 5432+          )++dirOpt :: Opt String+dirOpt+  = toOpt ( argument strParser+          & optHelp "Some directory"+          & optDefault "/home/user/something"+          )++logOpt :: Opt Bool+logOpt+  = toOpt ( switch+          & optLong "log"+          & optHelp "Whether to log or not"+          )+```++Here, we use `option` to define a command line argument that expects a value after it, `argument` to+define a standalone argument, not prefixed by a long or short indicator, and `switch` to define a+boolean command line flag that, if present, sets the target value to `True`. The `opt*` functions+(here applied using `&` to make things look more declarative) modify the option configuration.+`optHelp` adds help text, `optDefault` adds a default value, `optShort` adds a short command line+option as an alternative to the long one (the string after `option` or `switch`), `optEnvVar` sets+the associated environment variable and `optMetavar` sets the metavariable to be shown in the help+text generated by `optparse-applicative`.++`toOpt` turns any kind of option into the internal `Opt` type. The reason for doing this is that+different types of options can have different capabilities, e.g. `long` and `short` cannot be set+for an `argument`. Another shorthand is to use the `with` variants. For example, `dbHostOpt` could+also be defined like this:++``` haskell+dbHostOpt' :: Opt String+dbHostOpt'+  = optionWith strParser+      ( optLong "host"+      . optShort 'h'+      . optMetavar "DB_HOST"+      . optHelp "The database host"+      )+```++The first argument (`strParser` or `readParser`) is the parser for the argument, be it from the+command line or from an environment variable. The type of this function should be+`String -> Either String a`, which produces an error message or the parsed value. `strParser` is+equivalent to `pure` and always succeeds. `readParser` requires the type to have a `Read` constraint.+In order to use it with newtypes that wrap a type that has a `Read` constraint, using the `Functor`+instance for `Opt` should be sufficient. E.g. for the newtype:++``` haskell+newtype Port = Port Int+```++we can define the following option:++``` haskell+dbPortOpt' :: Opt Port+dbPortOpt'+  = Port <$> dbPortOpt+```++Of course, any user-defined function works as well. In addition, to use a function of type `String+-> Maybe a` use `parseWith`, which runs the parser and in case of failure uses a default error+message. For example, `readParser` is defined as `parseWith readMaybe`.++There are 3 ways to configure this datatype.++### 1. Using a `barbie` type++`barbie` types are types of kind `(Type -> Type) -> Type`. The `barbie` type for `FlatConfig`+looks like this:++``` haskell+data FlatConfigB f+  = FlatConfigB+      { _fcDbHostB :: f String+      , _fcDbPortB :: f Int+      , _fcDirB    :: f String+      , _fcLogB    :: f Bool+      }+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)+```++I also derived some required instances that come from the `barbies` package. These instances allow+us to change the `f` (`bmap` from `FunctorB`) and traverse all types in the record producing side+effects (`btraverse` from `TraversableB`).++Now let's define the value of this datatype, which holds our option configuration. The type+constructor needed for the options is `Opt`:++``` haskell+flatConfigOpt1 :: FlatConfigB Opt+flatConfigOpt1+  = FlatConfigB dbHostOpt dbPortOpt dirOpt logOpt+```++Because `dbHostOpt`, `dbPortOpt` and `logOpt` all have type `Opt <actual type>`, `flatConfigOpt1`+has the correct type according to `FlatConfigB Opt`.++Now to actually run things:++``` haskell+getFlatConfig1 :: IO ()+getFlatConfig1 = do+  FlatConfigB host port dir log <- execOptDef flatConfigOpt1+  print $ runIdentity (FlatConfig <$> host <*> port <*> dir <*> log)+```++`execOpt` returns an `Identity x` where `x` is the type of the options we are configuring, in this+case `FlatConfigB`. Here, we pattern match on the barbie-type, and then use the `Applicative`+instance of `Identity` to get back an `Identity FlatConfig`.++This is still a bit boilerplate-y. Let's look at another way.++### 2. Using a product type++Looking at `FlatConfigB`, it's only used because of it's `barbie`-like capabilities. Other than that+it's just a simple product type with the additional `f` before all its sub-types.++`harg` defines a type almost similar to `Product` (from `Data.Functor.Product`), which works in a+similar fashion as servant's `:<|>` type. This type is defined in `Options.Harg.Het.Prod` and is+called `:*` (the `*` stands for product). This type stores barbie-like types and also keeps the `f`+handy: `data (a :* b) f = a f :* b f`. This is also easily made an instance of `Generic`,+`FunctorB`, `TraversableB` and `ProductB`. With all that, let's rewrite the options value and the+function to get the configuration:++``` haskell+flatConfigOpt2 :: (Single String :* Single Int :* Single String :* Single Bool) Opt+flatConfigOpt2+  = single dbHostOpt :* single dbPortOpt :* single dirOpt :* single logOpt++getFlatConfig2 :: IO ()+getFlatConfig2 = do+  host :* port :* dir :* log <- execOptDef flatConfigOpt2+  print $ runIdentity+    (FlatConfig <$> getSingle host <*> getSingle port <*> getSingle dir <*> getSingle log)+```++This looks aufully similar to the previous version, but without having to write another datatype and+derive all the instances. `:*` is both a type-level constructor and a value-level function that acts+like list's `:`. It is also right-associative, so for example `a :* b :* c` is the same as+`a :* (b :* c)`.++The `Single` type constructor is used when talking about a single value, rather than a nested+datatype. `Single a f` is a simple newtype over `f a`. The reason for using that is simply to switch+the order of application, so that we can later apply the `f` (here `Opt`) to the compound type+(`:*`). This makes type definitions look more similar to datatype definitions:++``` haskell+type FlatConfigOpt2+  =  Single String+  :* Single Int+  :* Single Bool+```++In addition, `single` is used to wrap an `f a` into a `Single a f`, and `getSingle` is used+to unwrap it. Later on we'll see how to construct nested configurations using `Nested`.++However, the real value when having flat datatypes comes from the ability to use `higgledy`.++### 3. Using `HKD` from `higgledy`++``` haskell+flatConfigOpt3 :: HKD FlatConfig Opt+flatConfigOpt3+  = build @FlatConfig dbHostOpt dbPortOpt dirOpt logOpt++getFlatConfig3 :: IO ()+getFlatConfig3 = do+  result <- execOptDef flatConfigOpt3+  print $ runIdentity (construct result)+```++This is the most straightforward way to work with flat configuration types. The `build` function+takes as arguments the options (`Opt a` where `a` is each type in `FlatConfig`) **in the order they+appear in the datatype**, and returns the generic representation of a type that's exactly the same+as `FlatConfigB`. This means that we get all the `barbie` instances for free.++To go back from the `HKD` representation of a datatype to the base one, we use `construct`.+`construct` uses the applicative instance of the `f` which wraps each type in `FlatConfig` to give+back an `f FlatConfig` (in our case an `Identity FlatConfig`).++## Nested datatypes++Let's say now that we have these two datatypes:++``` haskell+data DbConfig+  = DbConfig+      { _dcHost :: String+      , _dcPort :: Int+      }+  deriving (Show, Generic)++data ServiceConfig+  = ServiceConfig+      { _scPort :: Int+      , _scLog  :: Bool+      }+  deriving (Show, Generic)+```++And the datatype to be configured is this:++``` haskell+data Config+  = Config+      { _cDb      :: DbConfig+      , _cService :: ServiceConfig+      , _cDir     :: String+      }+  deriving (Show, Generic)+```++And a new option required for the service port:++``` haskell+portOpt :: Opt Int+portOpt+  = toOpt ( option readParser+          & optLong "port"+          & optHelp "The service port"+          & optDefault 8080+          )+```++Again, there are several ways to configure these options.++### 1. Using `barbie` types++Since we now have 3 types, there's a bit more boilerplate to write:++``` haskell+data ConfigB f+  = ConfigB+      { _cDbB      :: DbConfigB f+      , _cServiceB :: ServiceConfigB f+      , _cDirB     :: f String+      }+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)++data DbConfigB f+  = DbConfigB+      { _dcHostB :: f String+      , _dcPortB :: f Int+      }+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)++data ServiceConfigB f+  = ServiceConfigB+      { _scPortB :: f Int+      , _scLogB  :: f Bool+      }+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)+```++To define the option parser, we need option parsers for every type inside it. This was true for+flat configs too, but we have to manually construct a `DbConfigB Opt` and `ServiceConfigB Opt`:++``` haskell+configOpt1 :: ConfigB Opt+configOpt1+  = ConfigB dbOpt serviceOpt dirOpt++dbOpt :: DbConfigB Opt+dbOpt+  = DbConfigB dbHostOpt dbPortOpt++serviceOpt :: ServiceConfigB Opt+serviceOpt+  = ServiceConfigB portOpt logOpt+```++And to run the parser:++``` haskell+getConfig1 :: IO ()+getConfig1 = do+  ConfigB (DbConfigB dbHost dbPort) (ServiceConfigB port log) dir <- execOptDef configOpt1+  let+    db      = DbConfig <$> dbHost <*> dbPort+    service = ServiceConfig <$> port <*> log+  print $ runIdentity (Config <$> db <*> service <*> dir)+```++### 2. Using `higgledy`++`higgledy` puts an `f` before every type, so doing something like `HKD Config f` doesn't make sense:+looking at `ConfigB` it seems like the `f` needs to go to the right hand side of the nested types.+We can, however, avoid the boilerplate of defining `barbie` types for the nested datatypes:++``` haskell+data ConfigH f+  = ConfigH+      { _cDbH      :: HKD DbConfig f+      , _cServiceH :: HKD ServiceConfig f+      , _cDirH     :: f String+      }+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)++configOpt2 :: ConfigH Opt+configOpt2+  = ConfigH dbOptH serviceOptH dirOpt++dbOptH :: HKD DbConfig Opt+dbOptH+  = build @DbConfig dbHostOpt dbPortOpt++serviceOptH :: HKD ServiceConfig Opt+serviceOptH+  = build @ServiceConfig portOpt logOpt+```++And to run the parser:++``` haskell+getConfig2 :: IO ()+getConfig2 = do+  ConfigH db service dir <- execOptDef configOpt2+  print $ runIdentity (Config <$> construct db <*> construct service <*> dir)+```++### 2. Using products++Recall from previously that there's the `Single` type which in general turns `f b` into `b f`. This+means that, by using `Single` for the directory option, all `f`s are after their types, so we can+just use `:*` instead of having to declare a new datatype:++``` haskell+type ConfigP+  =  HKD DbConfig+  :* HKD ServiceConfig+  :* Single String++configOpt3 :: ConfigP Opt+configOpt3+  = dbOptH :* serviceOptH :* single dirOpt++getConfig3 :: IO ()+getConfig3 = do+  db :* service :* dir <- execOptDef configOpt3+  print $ runIdentity (Config <$> construct db <*> construct service <*> getSingle dir)+```++And, to make things look more orthogonal, `harg` defines a type called `Nested`, which is exactly+the same as `HKD`. There are functions that correspond to `build` and `construct`, too:++```+Nested    <-> HKD+nested    <-> build+getNested <-> construct+```++This means that the previous code block might as well be:++``` haskell+type ConfigP'+  =  Nested DbConfig+  :* Nested ServiceConfig+  :* Single String++configOpt4 :: ConfigP' Opt+configOpt4+  = dbOptN :* serviceOptN :* single dirOpt+  where+    dbOptN+      = nested @DbConfig dbHostOpt dbPortOpt+    serviceOptN+      = nested @ServiceConfig portOpt logOpt++getConfig4 :: IO ()+getConfig4 = do+  db :* service :* dir <- execOptDef configOpt4+  print $ runIdentity (Config <$> getNested db <*> getNested service <*> getSingle dir)+```++Pretty cool.++## Subcommands++`harg` also supports (somewhat limited) subcommands, again by using `optparse-applicative`+underneath.++Because of limitations with higher kinded data when it comes to sum types, `harg` uses a different+way to define subcommands. `optparse-applicative` allows defining subcommands that result to the+same type, which means the user needs to define a sum type, and each subcommand results in a+different constructor. In contrast, `harg` defines subcommands that can return completely different+types. Instead of the result being a sum type, where the user has to pattern match on constructors,+the result is a `Variant`, which is defined (almost) like this:++``` haskell+data Variant (xs :: [Type]) where+  Here :: x -> Variant (x ': xs)+  There :: Variant xs -> Variant (y ': xs)+```++`Variant` is like a sum type which holds all the summands in a type-level list. Instead of pattern+matching in `Left` or `Right` like when using `Either`, we pattern match on `Here x`, `There (Here x)`+etc. For a pretty thorough introduction to `Variant` and more heterogeneous types, check out+[this repo](https://github.com/i-am-tom/learn-me-a-haskell) by [i-am-tom](https://github.com/i-am-tom).++``` haskell+x :: Variant '[Int, Bool, Char]+x = There (Here True)++run :: Variant '[Int, Bool, Char] -> Maybe Bool+run (Here _)                 = Nothing+run (There (Here b))         = Just b+run (There (There (Here _))) = Nothing++-- > run x+-- Just True+```++`harg` defines another kind of variant called `VariantF`:++``` haskell ignore+data VariantF (xs :: [(Type -> Type) -> Type]) (f :: Type -> Type) where+```++to hold a type-level list of `barbie` types and the `f` to wrap every type with.++To define a type to be used in a subcommand parser we need the target type and the subcommand name,+which is encoded as a type-level string `Symbol`. There's a handy way to define this. Suppose that+the the `Config` type above is the configuration type when the command is `app` and another type,+e.g.`TestConfig` is the configuration when the command is `test`:++``` haskell+data TestConfig+  = TestConfig+      { _tcFoo :: String+      , _tcBar :: Int+      }+  deriving Show++fooOpt :: Opt String+fooOpt+  = toOpt ( option strParser+          & optShort 'f'+          & optHelp "Something foo"+          & optDefault "this is the default foo"+          )++barOpt :: Opt Int+barOpt+  = toOpt ( option readParser+          & optShort 'b'+          & optHelp "Something bar"+          & optDefault 42+          )++type TestConfigP+  = Single String :* Single Int++testConfigOpt :: TestConfigP Opt+testConfigOpt+  = single fooOpt :* single barOpt+```++The subcommand type looks like this:++``` haskell+type SubcommandConfig+  =  "app" :-> ConfigP'+  :+ "test" :-> TestConfigP+```++The `+` here stands for sum. The associated option type is:++``` haskell+subcommandOpt :: SubcommandConfig Opt+subcommandOpt+  = configOpt4 :+ testConfigOpt :+ ANil+```++The `ANil` here marks the end of the association list (which is a heterogeneous list that associates+symbols with types).++Here's how to run this parser:++``` haskell+getSubcommand :: IO ()+getSubcommand = do+  result <- execCommandsDef subcommandOpt+  case result of+    HereF (db :* service :* dir)+      -> print $ runIdentity+       $ Config <$> getNested db <*> getNested service <*> getSingle dir+    ThereF (HereF (foo :* bar))+      -> print $ runIdentity+       $ TestConfig <$> getSingle foo <*> getSingle bar+```++Or use `fromVariantF`, which is similar to the `either` function:++``` haskell+getSubcommand' :: IO ()+getSubcommand' = do+  result <- execCommandsDef subcommandOpt+  fromVariantF result+    (\(db :* service :* dir)+       -> print $ runIdentity+       $ Config <$> getNested db <*> getNested service <*> getSingle dir+    )+    (\(foo :* bar)+       -> print $ runIdentity+       $ TestConfig <$> getSingle foo <*> getSingle bar+    )+```++The type of `fromVariantF` can be thought of as being:++``` haskell ignore+fromVariantF+  :: VariantF '[a, b, c, ...] f+  -> (a f -> r)+  -> (b f -> r)+  -> (c f -> r)+  -> ...+  -> r+```++The signature will accept the appropriate number of functions depending on the length of the type+level list.++## More than just environment variables++You may have noticed the use of `execOptDef` and `execCommandsDef` in all of the examples up to now.+There are actually more configurable versions of these, called `execOpt` and `execCommands`+respectively. With these functions the user can select where to get options from. For example,+`execOptDef` is a shorthand for `execOpt EnvSource`, which means that options will be fetched from+environment variables only (along with the command line, which is always required, and defaults,+which can be optionally provided by the user).++The sources currently supported are environment variables, json and yaml files.++### Configuring using a json file++First of all, let's use `FlatConfig` from the first example:++``` haskell ignore+data FlatConfig+  = FlatConfig+      { _fcDbHost :: String+      , _fcDbPort :: Int+      , _fcDir    :: String+      , _fcLog    :: Bool  -- whether to log or not+      }+  deriving (Show, Generic)++dbHostOpt :: Opt String+dbHostOpt+  = toOpt ( option strParser+          & optLong "host"+          & optShort 'h'+          & optMetavar "DB_HOST"+          & optHelp "The database host"+          )++dbPortOpt :: Opt Int+dbPortOpt+  = toOpt ( option readParser+          & optLong "port"+          & optHelp "The database port"+          & optEnvVar "DB_PORT"+          & optDefault 5432+          )++dirOpt :: Opt String+dirOpt+  = toOpt ( argument strParser+          & optHelp "Some directory"+          & optDefault "/home/user/something"+          )++logOpt :: Opt Bool+logOpt+  = toOpt ( switch+          & optLong "log"+          & optHelp "Whether to log or not"+          )++flatConfigOpt3 :: HKD FlatConfig Opt+flatConfigOpt3+  = build @FlatConfig dbHostOpt dbPortOpt dirOpt logOpt+```++To use the JSON source, a `FromJSON` instance is required. Thankfully that's easy, since+`FlatConfig` has `Generic` instance:++``` haskell+instance FromJSON FlatConfig+```++In `harg`, sources are defined as products (using `:*`) of options, which means that the definition+of the sources is not very different than defining options! If we only needed the environment+variable source, the options would be:++``` haskell ignore+envSource :: EnvSource Opt+envSource = EnvSource+```++There's no need to actually define an option for the environment because there's no meaningful+configuration for this. To use the `EnvSource` along with a json config, we use the following+option:++``` haskell+sourceOpt :: (EnvSource :* JSONSource) Opt+sourceOpt+  = EnvSource :* JSONSource jsonOpt+  where+    jsonOpt :: Opt ConfigFile+    jsonOpt+      = toOpt ( option strParser+              & optLong "json"+              & optShort 'j'+              & optHelp "JSON config filepath"+              )+```++# Roadmap++- Better errors using `optparse-applicative`'s internals+- Allow user to pass `optparse-applicative` preferences+- ~~Be able to provide and get back the same type for multiple subcommands~~+- ~~Integrate config files (e.g. JSON using aeson)~~++# Credits++- [jcpetruzza](https://github.com/jcpetruzza)+- [i-am-tom](https://github.com/i-am-tom)+- [jmackie](https://github.com/jmackie)
+ README.md view
@@ -0,0 +1,721 @@+# `harg` :nut_and_bolt:++[![Build Status](https://travis-ci.org/alexpeits/harg.svg?branch=master)](https://travis-ci.org/alexpeits/harg)++`harg` is a library for configuring programs by scanning command line arguments, environment+variables and default values. Under the hood, it uses a subset of+[`optparse-applicative`](https://hackage.haskell.org/package/optparse-applicative) to expose regular+arguments, switch arguments and subcommands. The library relies heavily on the use of higher kinded+data (HKD) thanks to the [`barbies`](https://hackage.haskell.org/package/barbies) library. Using+[`higgledy`](https://hackage.haskell.org/package/higgledy) also allows to have significantly less+boilerplate code.++The main goal while developing `harg` was to not have to go through the usual pattern of manually+`mappend`ing the results of command line parsing, env vars and defaults.++# Usage++tl;dr: Take a look at the [example](Example.hs).++(WIP)++Here are some different usage scenarios. Let's first enable some language extensions and add some+imports:++``` haskell+{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE KindSignatures     #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications   #-}+{-# LANGUAGE TypeOperators      #-}++import           Data.Function         ((&))+import           Data.Functor.Identity (Identity (..))+import           Data.Kind             (Type)+import           GHC.Generics          (Generic)++import qualified Data.Barbie           as B+import           Data.Aeson            (FromJSON)+import           Data.Generic.HKD      (HKD, build, construct)++import           Options.Harg++main :: IO ()+main = putStrLn "this is a literate haskell file"+```++## One flat (non-nested) datatype++The easiest scenario is when the target configuration type is one single record with no levels of+nesting:++``` haskell+data FlatConfig+  = FlatConfig+      { _fcDbHost :: String+      , _fcDbPort :: Int+      , _fcDir    :: String+      , _fcLog    :: Bool  -- whether to log or not+      }+  deriving (Show, Generic)+```++(The `Generic` instance is required for section `3` later on)++Let's first create the `Opt`s for each value in `FlatConfig`. `Opt` is the description for each+component of the configuration.++``` haskell+dbHostOpt :: Opt String+dbHostOpt+  = toOpt ( option strParser+          & optLong "host"+          & optShort 'h'+          & optMetavar "DB_HOST"+          & optHelp "The database host"+          )++dbPortOpt :: Opt Int+dbPortOpt+  = toOpt ( option readParser+          & optLong "port"+          & optHelp "The database port"+          & optEnvVar "DB_PORT"+          & optDefault 5432+          )++dirOpt :: Opt String+dirOpt+  = toOpt ( argument strParser+          & optHelp "Some directory"+          & optDefault "/home/user/something"+          )++logOpt :: Opt Bool+logOpt+  = toOpt ( switch+          & optLong "log"+          & optHelp "Whether to log or not"+          )+```++Here, we use `option` to define a command line argument that expects a value after it, `argument` to+define a standalone argument, not prefixed by a long or short indicator, and `switch` to define a+boolean command line flag that, if present, sets the target value to `True`. The `opt*` functions+(here applied using `&` to make things look more declarative) modify the option configuration.+`optHelp` adds help text, `optDefault` adds a default value, `optShort` adds a short command line+option as an alternative to the long one (the string after `option` or `switch`), `optEnvVar` sets+the associated environment variable and `optMetavar` sets the metavariable to be shown in the help+text generated by `optparse-applicative`.++`toOpt` turns any kind of option into the internal `Opt` type. The reason for doing this is that+different types of options can have different capabilities, e.g. `long` and `short` cannot be set+for an `argument`. Another shorthand is to use the `with` variants. For example, `dbHostOpt` could+also be defined like this:++``` haskell+dbHostOpt' :: Opt String+dbHostOpt'+  = optionWith strParser+      ( optLong "host"+      . optShort 'h'+      . optMetavar "DB_HOST"+      . optHelp "The database host"+      )+```++The first argument (`strParser` or `readParser`) is the parser for the argument, be it from the+command line or from an environment variable. The type of this function should be+`String -> Either String a`, which produces an error message or the parsed value. `strParser` is+equivalent to `pure` and always succeeds. `readParser` requires the type to have a `Read` constraint.+In order to use it with newtypes that wrap a type that has a `Read` constraint, using the `Functor`+instance for `Opt` should be sufficient. E.g. for the newtype:++``` haskell+newtype Port = Port Int+```++we can define the following option:++``` haskell+dbPortOpt' :: Opt Port+dbPortOpt'+  = Port <$> dbPortOpt+```++Of course, any user-defined function works as well. In addition, to use a function of type `String+-> Maybe a` use `parseWith`, which runs the parser and in case of failure uses a default error+message. For example, `readParser` is defined as `parseWith readMaybe`.++There are 3 ways to configure this datatype.++### 1. Using a `barbie` type++`barbie` types are types of kind `(Type -> Type) -> Type`. The `barbie` type for `FlatConfig`+looks like this:++``` haskell+data FlatConfigB f+  = FlatConfigB+      { _fcDbHostB :: f String+      , _fcDbPortB :: f Int+      , _fcDirB    :: f String+      , _fcLogB    :: f Bool+      }+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)+```++I also derived some required instances that come from the `barbies` package. These instances allow+us to change the `f` (`bmap` from `FunctorB`) and traverse all types in the record producing side+effects (`btraverse` from `TraversableB`).++Now let's define the value of this datatype, which holds our option configuration. The type+constructor needed for the options is `Opt`:++``` haskell+flatConfigOpt1 :: FlatConfigB Opt+flatConfigOpt1+  = FlatConfigB dbHostOpt dbPortOpt dirOpt logOpt+```++Because `dbHostOpt`, `dbPortOpt` and `logOpt` all have type `Opt <actual type>`, `flatConfigOpt1`+has the correct type according to `FlatConfigB Opt`.++Now to actually run things:++``` haskell+getFlatConfig1 :: IO ()+getFlatConfig1 = do+  FlatConfigB host port dir log <- execOptDef flatConfigOpt1+  print $ runIdentity (FlatConfig <$> host <*> port <*> dir <*> log)+```++`execOpt` returns an `Identity x` where `x` is the type of the options we are configuring, in this+case `FlatConfigB`. Here, we pattern match on the barbie-type, and then use the `Applicative`+instance of `Identity` to get back an `Identity FlatConfig`.++This is still a bit boilerplate-y. Let's look at another way.++### 2. Using a product type++Looking at `FlatConfigB`, it's only used because of it's `barbie`-like capabilities. Other than that+it's just a simple product type with the additional `f` before all its sub-types.++`harg` defines a type almost similar to `Product` (from `Data.Functor.Product`), which works in a+similar fashion as servant's `:<|>` type. This type is defined in `Options.Harg.Het.Prod` and is+called `:*` (the `*` stands for product). This type stores barbie-like types and also keeps the `f`+handy: `data (a :* b) f = a f :* b f`. This is also easily made an instance of `Generic`,+`FunctorB`, `TraversableB` and `ProductB`. With all that, let's rewrite the options value and the+function to get the configuration:++``` haskell+flatConfigOpt2 :: (Single String :* Single Int :* Single String :* Single Bool) Opt+flatConfigOpt2+  = single dbHostOpt :* single dbPortOpt :* single dirOpt :* single logOpt++getFlatConfig2 :: IO ()+getFlatConfig2 = do+  host :* port :* dir :* log <- execOptDef flatConfigOpt2+  print $ runIdentity+    (FlatConfig <$> getSingle host <*> getSingle port <*> getSingle dir <*> getSingle log)+```++This looks aufully similar to the previous version, but without having to write another datatype and+derive all the instances. `:*` is both a type-level constructor and a value-level function that acts+like list's `:`. It is also right-associative, so for example `a :* b :* c` is the same as+`a :* (b :* c)`.++The `Single` type constructor is used when talking about a single value, rather than a nested+datatype. `Single a f` is a simple newtype over `f a`. The reason for using that is simply to switch+the order of application, so that we can later apply the `f` (here `Opt`) to the compound type+(`:*`). This makes type definitions look more similar to datatype definitions:++``` haskell+type FlatConfigOpt2+  =  Single String+  :* Single Int+  :* Single Bool+```++In addition, `single` is used to wrap an `f a` into a `Single a f`, and `getSingle` is used+to unwrap it. Later on we'll see how to construct nested configurations using `Nested`.++However, the real value when having flat datatypes comes from the ability to use `higgledy`.++### 3. Using `HKD` from `higgledy`++``` haskell+flatConfigOpt3 :: HKD FlatConfig Opt+flatConfigOpt3+  = build @FlatConfig dbHostOpt dbPortOpt dirOpt logOpt++getFlatConfig3 :: IO ()+getFlatConfig3 = do+  result <- execOptDef flatConfigOpt3+  print $ runIdentity (construct result)+```++This is the most straightforward way to work with flat configuration types. The `build` function+takes as arguments the options (`Opt a` where `a` is each type in `FlatConfig`) **in the order they+appear in the datatype**, and returns the generic representation of a type that's exactly the same+as `FlatConfigB`. This means that we get all the `barbie` instances for free.++To go back from the `HKD` representation of a datatype to the base one, we use `construct`.+`construct` uses the applicative instance of the `f` which wraps each type in `FlatConfig` to give+back an `f FlatConfig` (in our case an `Identity FlatConfig`).++## Nested datatypes++Let's say now that we have these two datatypes:++``` haskell+data DbConfig+  = DbConfig+      { _dcHost :: String+      , _dcPort :: Int+      }+  deriving (Show, Generic)++data ServiceConfig+  = ServiceConfig+      { _scPort :: Int+      , _scLog  :: Bool+      }+  deriving (Show, Generic)+```++And the datatype to be configured is this:++``` haskell+data Config+  = Config+      { _cDb      :: DbConfig+      , _cService :: ServiceConfig+      , _cDir     :: String+      }+  deriving (Show, Generic)+```++And a new option required for the service port:++``` haskell+portOpt :: Opt Int+portOpt+  = toOpt ( option readParser+          & optLong "port"+          & optHelp "The service port"+          & optDefault 8080+          )+```++Again, there are several ways to configure these options.++### 1. Using `barbie` types++Since we now have 3 types, there's a bit more boilerplate to write:++``` haskell+data ConfigB f+  = ConfigB+      { _cDbB      :: DbConfigB f+      , _cServiceB :: ServiceConfigB f+      , _cDirB     :: f String+      }+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)++data DbConfigB f+  = DbConfigB+      { _dcHostB :: f String+      , _dcPortB :: f Int+      }+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)++data ServiceConfigB f+  = ServiceConfigB+      { _scPortB :: f Int+      , _scLogB  :: f Bool+      }+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)+```++To define the option parser, we need option parsers for every type inside it. This was true for+flat configs too, but we have to manually construct a `DbConfigB Opt` and `ServiceConfigB Opt`:++``` haskell+configOpt1 :: ConfigB Opt+configOpt1+  = ConfigB dbOpt serviceOpt dirOpt++dbOpt :: DbConfigB Opt+dbOpt+  = DbConfigB dbHostOpt dbPortOpt++serviceOpt :: ServiceConfigB Opt+serviceOpt+  = ServiceConfigB portOpt logOpt+```++And to run the parser:++``` haskell+getConfig1 :: IO ()+getConfig1 = do+  ConfigB (DbConfigB dbHost dbPort) (ServiceConfigB port log) dir <- execOptDef configOpt1+  let+    db      = DbConfig <$> dbHost <*> dbPort+    service = ServiceConfig <$> port <*> log+  print $ runIdentity (Config <$> db <*> service <*> dir)+```++### 2. Using `higgledy`++`higgledy` puts an `f` before every type, so doing something like `HKD Config f` doesn't make sense:+looking at `ConfigB` it seems like the `f` needs to go to the right hand side of the nested types.+We can, however, avoid the boilerplate of defining `barbie` types for the nested datatypes:++``` haskell+data ConfigH f+  = ConfigH+      { _cDbH      :: HKD DbConfig f+      , _cServiceH :: HKD ServiceConfig f+      , _cDirH     :: f String+      }+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)++configOpt2 :: ConfigH Opt+configOpt2+  = ConfigH dbOptH serviceOptH dirOpt++dbOptH :: HKD DbConfig Opt+dbOptH+  = build @DbConfig dbHostOpt dbPortOpt++serviceOptH :: HKD ServiceConfig Opt+serviceOptH+  = build @ServiceConfig portOpt logOpt+```++And to run the parser:++``` haskell+getConfig2 :: IO ()+getConfig2 = do+  ConfigH db service dir <- execOptDef configOpt2+  print $ runIdentity (Config <$> construct db <*> construct service <*> dir)+```++### 2. Using products++Recall from previously that there's the `Single` type which in general turns `f b` into `b f`. This+means that, by using `Single` for the directory option, all `f`s are after their types, so we can+just use `:*` instead of having to declare a new datatype:++``` haskell+type ConfigP+  =  HKD DbConfig+  :* HKD ServiceConfig+  :* Single String++configOpt3 :: ConfigP Opt+configOpt3+  = dbOptH :* serviceOptH :* single dirOpt++getConfig3 :: IO ()+getConfig3 = do+  db :* service :* dir <- execOptDef configOpt3+  print $ runIdentity (Config <$> construct db <*> construct service <*> getSingle dir)+```++And, to make things look more orthogonal, `harg` defines a type called `Nested`, which is exactly+the same as `HKD`. There are functions that correspond to `build` and `construct`, too:++```+Nested    <-> HKD+nested    <-> build+getNested <-> construct+```++This means that the previous code block might as well be:++``` haskell+type ConfigP'+  =  Nested DbConfig+  :* Nested ServiceConfig+  :* Single String++configOpt4 :: ConfigP' Opt+configOpt4+  = dbOptN :* serviceOptN :* single dirOpt+  where+    dbOptN+      = nested @DbConfig dbHostOpt dbPortOpt+    serviceOptN+      = nested @ServiceConfig portOpt logOpt++getConfig4 :: IO ()+getConfig4 = do+  db :* service :* dir <- execOptDef configOpt4+  print $ runIdentity (Config <$> getNested db <*> getNested service <*> getSingle dir)+```++Pretty cool.++## Subcommands++`harg` also supports (somewhat limited) subcommands, again by using `optparse-applicative`+underneath.++Because of limitations with higher kinded data when it comes to sum types, `harg` uses a different+way to define subcommands. `optparse-applicative` allows defining subcommands that result to the+same type, which means the user needs to define a sum type, and each subcommand results in a+different constructor. In contrast, `harg` defines subcommands that can return completely different+types. Instead of the result being a sum type, where the user has to pattern match on constructors,+the result is a `Variant`, which is defined (almost) like this:++``` haskell+data Variant (xs :: [Type]) where+  Here :: x -> Variant (x ': xs)+  There :: Variant xs -> Variant (y ': xs)+```++`Variant` is like a sum type which holds all the summands in a type-level list. Instead of pattern+matching in `Left` or `Right` like when using `Either`, we pattern match on `Here x`, `There (Here x)`+etc. For a pretty thorough introduction to `Variant` and more heterogeneous types, check out+[this repo](https://github.com/i-am-tom/learn-me-a-haskell) by [i-am-tom](https://github.com/i-am-tom).++``` haskell+x :: Variant '[Int, Bool, Char]+x = There (Here True)++run :: Variant '[Int, Bool, Char] -> Maybe Bool+run (Here _)                 = Nothing+run (There (Here b))         = Just b+run (There (There (Here _))) = Nothing++-- > run x+-- Just True+```++`harg` defines another kind of variant called `VariantF`:++``` haskell ignore+data VariantF (xs :: [(Type -> Type) -> Type]) (f :: Type -> Type) where+```++to hold a type-level list of `barbie` types and the `f` to wrap every type with.++To define a type to be used in a subcommand parser we need the target type and the subcommand name,+which is encoded as a type-level string `Symbol`. There's a handy way to define this. Suppose that+the the `Config` type above is the configuration type when the command is `app` and another type,+e.g.`TestConfig` is the configuration when the command is `test`:++``` haskell+data TestConfig+  = TestConfig+      { _tcFoo :: String+      , _tcBar :: Int+      }+  deriving Show++fooOpt :: Opt String+fooOpt+  = toOpt ( option strParser+          & optShort 'f'+          & optHelp "Something foo"+          & optDefault "this is the default foo"+          )++barOpt :: Opt Int+barOpt+  = toOpt ( option readParser+          & optShort 'b'+          & optHelp "Something bar"+          & optDefault 42+          )++type TestConfigP+  = Single String :* Single Int++testConfigOpt :: TestConfigP Opt+testConfigOpt+  = single fooOpt :* single barOpt+```++The subcommand type looks like this:++``` haskell+type SubcommandConfig+  =  "app" :-> ConfigP'+  :+ "test" :-> TestConfigP+```++The `+` here stands for sum. The associated option type is:++``` haskell+subcommandOpt :: SubcommandConfig Opt+subcommandOpt+  = configOpt4 :+ testConfigOpt :+ ANil+```++The `ANil` here marks the end of the association list (which is a heterogeneous list that associates+symbols with types).++Here's how to run this parser:++``` haskell+getSubcommand :: IO ()+getSubcommand = do+  result <- execCommandsDef subcommandOpt+  case result of+    HereF (db :* service :* dir)+      -> print $ runIdentity+       $ Config <$> getNested db <*> getNested service <*> getSingle dir+    ThereF (HereF (foo :* bar))+      -> print $ runIdentity+       $ TestConfig <$> getSingle foo <*> getSingle bar+```++Or use `fromVariantF`, which is similar to the `either` function:++``` haskell+getSubcommand' :: IO ()+getSubcommand' = do+  result <- execCommandsDef subcommandOpt+  fromVariantF result+    (\(db :* service :* dir)+       -> print $ runIdentity+       $ Config <$> getNested db <*> getNested service <*> getSingle dir+    )+    (\(foo :* bar)+       -> print $ runIdentity+       $ TestConfig <$> getSingle foo <*> getSingle bar+    )+```++The type of `fromVariantF` can be thought of as being:++``` haskell ignore+fromVariantF+  :: VariantF '[a, b, c, ...] f+  -> (a f -> r)+  -> (b f -> r)+  -> (c f -> r)+  -> ...+  -> r+```++The signature will accept the appropriate number of functions depending on the length of the type+level list.++## More than just environment variables++You may have noticed the use of `execOptDef` and `execCommandsDef` in all of the examples up to now.+There are actually more configurable versions of these, called `execOpt` and `execCommands`+respectively. With these functions the user can select where to get options from. For example,+`execOptDef` is a shorthand for `execOpt EnvSource`, which means that options will be fetched from+environment variables only (along with the command line, which is always required, and defaults,+which can be optionally provided by the user).++The sources currently supported are environment variables, json and yaml files.++### Configuring using a json file++First of all, let's use `FlatConfig` from the first example:++``` haskell ignore+data FlatConfig+  = FlatConfig+      { _fcDbHost :: String+      , _fcDbPort :: Int+      , _fcDir    :: String+      , _fcLog    :: Bool  -- whether to log or not+      }+  deriving (Show, Generic)++dbHostOpt :: Opt String+dbHostOpt+  = toOpt ( option strParser+          & optLong "host"+          & optShort 'h'+          & optMetavar "DB_HOST"+          & optHelp "The database host"+          )++dbPortOpt :: Opt Int+dbPortOpt+  = toOpt ( option readParser+          & optLong "port"+          & optHelp "The database port"+          & optEnvVar "DB_PORT"+          & optDefault 5432+          )++dirOpt :: Opt String+dirOpt+  = toOpt ( argument strParser+          & optHelp "Some directory"+          & optDefault "/home/user/something"+          )++logOpt :: Opt Bool+logOpt+  = toOpt ( switch+          & optLong "log"+          & optHelp "Whether to log or not"+          )++flatConfigOpt3 :: HKD FlatConfig Opt+flatConfigOpt3+  = build @FlatConfig dbHostOpt dbPortOpt dirOpt logOpt+```++To use the JSON source, a `FromJSON` instance is required. Thankfully that's easy, since+`FlatConfig` has `Generic` instance:++``` haskell+instance FromJSON FlatConfig+```++In `harg`, sources are defined as products (using `:*`) of options, which means that the definition+of the sources is not very different than defining options! If we only needed the environment+variable source, the options would be:++``` haskell ignore+envSource :: EnvSource Opt+envSource = EnvSource+```++There's no need to actually define an option for the environment because there's no meaningful+configuration for this. To use the `EnvSource` along with a json config, we use the following+option:++``` haskell+sourceOpt :: (EnvSource :* JSONSource) Opt+sourceOpt+  = EnvSource :* JSONSource jsonOpt+  where+    jsonOpt :: Opt ConfigFile+    jsonOpt+      = toOpt ( option strParser+              & optLong "json"+              & optShort 'j'+              & optHelp "JSON config filepath"+              )+```++# Roadmap++- Better errors using `optparse-applicative`'s internals+- Allow user to pass `optparse-applicative` preferences+- ~~Be able to provide and get back the same type for multiple subcommands~~+- ~~Integrate config files (e.g. JSON using aeson)~~++# Credits++- [jcpetruzza](https://github.com/jcpetruzza)+- [i-am-tom](https://github.com/i-am-tom)+- [jmackie](https://github.com/jmackie)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ harg.cabal view
@@ -0,0 +1,107 @@+cabal-version: 2.2++name:           harg+version:        0.1.0.0+synopsis:       Haskell program configuration from multiple sources+description:    Please see the README on GitHub at <https://github.com/alexpeits/harg#readme>+homepage:       https://github.com/alexpeits/harg+bug-reports:    https://github.com/alexpeits/harg/issues+author:         Alex Peitsinis+maintainer:     alexpeitsinis@gmail.com+stability:      Experimental+copyright:      Copyright (c) 2019 Alex Peitsinis+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+category:       System, CLI, Options, Parsing+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/alexpeits/harg++library+  exposed-modules:    Options.Harg+  other-modules:      Options.Harg.Cmdline+                      Options.Harg.Config+                      Options.Harg.Construct+                      Options.Harg.Het.All+                      Options.Harg.Het.HList+                      Options.Harg.Het.Nat+                      Options.Harg.Het.Prod+                      Options.Harg.Het.Proofs+                      Options.Harg.Het.Variant+                      Options.Harg.Nested+                      Options.Harg.Operations+                      Options.Harg.Pretty+                      Options.Harg.Single+                      Options.Harg.Sources+                      Options.Harg.Sources.Env+                      Options.Harg.Sources.JSON+                      Options.Harg.Sources.NoSource+                      Options.Harg.Sources.Types+                      Options.Harg.Sources.YAML+                      Options.Harg.Subcommands+                      Options.Harg.Types+                      Options.Harg.Util+  hs-source-dirs:     src+  default-extensions: DataKinds+                      FlexibleContexts+                      FlexibleInstances+                      GADTs+                      KindSignatures+                      LambdaCase+                      MultiParamTypeClasses+                      RecordWildCards+                      ScopedTypeVariables+                      TypeApplications+                      TypeOperators+  ghc-options:        -Wall+                      -Wno-unticked-promoted-constructors+  build-depends:      base >=4.7 && <5+                    , aeson >= 1.4.2 && < 1.5+                    , barbies >= 1.0.0 && < 1.2+                    , bytestring >= 0.10.8 && < 0.11+                    , directory >= 1.3.3 && < 1.4+                    , higgledy >= 0.2.0 && < 0.3+                    , optparse-applicative >= 0.14.3 && < 0.15+                    , text >= 1.2.3 && < 1.3+                    , yaml >= 0.11.0 && < 0.12+  default-language:   Haskell2010++test-suite harg-test+  type:             exitcode-stdio-1.0+  main-is:          Spec.hs+  hs-source-dirs:   test+  ghc-options:      -Wall+                    -Wno-unticked-promoted-constructors+                    -threaded+                    -rtsopts+                    -with-rtsopts=-N+  build-depends:    base+                  , harg+  default-language: Haskell2010++test-suite readme-test+  type:               exitcode-stdio-1.0+  main-is:            README.lhs+  ghc-options:        -Wall+                      -Wno-unticked-promoted-constructors+                      -threaded+                      -Wall+                      -fno-warn-incomplete-patterns+                      -fno-warn-missing-signatures+                      -fno-warn-name-shadowing+                      -fno-warn-type-defaults+                      -fno-warn-unused-top-binds+                      -pgmL markdown-unlit+  build-depends:      base+                    , aeson+                    , barbies+                    , higgledy+                    , optparse-applicative+                    , harg+  build-tool-depends: markdown-unlit:markdown-unlit+  default-language:   Haskell2010
+ src/Options/Harg.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE PatternSynonyms #-}+module Options.Harg+  ( -- * Summary+    -- $summary++    -- ** Option declaration+    option+  , optionWith+  , flag+  , flagWith+  , switch+  , switchWith+  , switch'+  , switchWith'+  , argument+  , argumentWith++  , Single (..)+  , single++  , Nested (..)+  , nested+  , getNested++  , AssocListF (..)+  , (:+)+  , pattern (:+)+  , (:->)++  , (:*) (..)+  , Tagged (..)++  -- ** Option modifiers+  , optLong+  , optShort+  , optHelp+  , optMetavar+  , optEnvVar+  , optDefault+  , optOptional+  , toOpt+  , Opt++  -- ** Option parsers+  , parseWith+  , readParser+  , strParser+  , boolParser++  -- ** Executing options+  , execOpt+  , execOptDef+  , execCommands+  , execCommandsDef++  -- ** Option sources+  , EnvSource (..)+  , JSONSource (..)+  , YAMLSource (..)+  , ConfigFile (..)+  , noSources+  , defaultSources++  -- ** Parser context+  , getCtx+  , ctxFromArgs+  , ctxFromEnv+  , pureCtx++  -- ** Variant+  , VariantF (..)+  , fromVariantF+  , pattern In1+  , pattern In2+  , pattern In3+  , pattern In4+  , pattern In5++  -- ** Re-exports+  , B.FunctorB+  , B.TraversableB+  , B.ProductB++  , HKD.HKD+  , HKD.build+  , HKD.construct+  ) where++import           Options.Harg.Construct+import           Options.Harg.Het.HList+import           Options.Harg.Het.Prod+import           Options.Harg.Het.Variant+import           Options.Harg.Nested+import           Options.Harg.Operations+import           Options.Harg.Single+import           Options.Harg.Sources+import           Options.Harg.Sources.Env+import           Options.Harg.Sources.JSON+import           Options.Harg.Sources.NoSource+import           Options.Harg.Sources.Types+import           Options.Harg.Sources.YAML+import           Options.Harg.Types++import qualified Data.Barbie                   as B+import qualified Data.Generic.HKD              as HKD+++-- $summary+--+-- @harg@ is a wrapper around @optparse-applicative@ that allows blending+-- command-line configuration with environment variables, defaults as well as+-- other sources such as JSON or YAML files. Here are some very simple examples:+--+-- * Flat configuration type+--+-- @+--   data Config+--     = Config+--         { host :: String+--         , port :: Int+--         , log  :: Bool+--         , dir  :: Maybe String+--         }+--+--   -- Using 'HKD' from higgledy+--   configOpt :: HKD Config Opt+--   configOpt+--     = build @Config hostOpt portOpt logOpt dirOpt+--     where+--       hostOpt+--         = optionWith strParser+--             ( optLong \"host\"+--             . optShort \'h\'+--             . optHelp \"Hostname\"+--             . optEnvVar \"HOST_NAME\"+--             )+--       portOpt+--         = optionWith readParser+--             ( optLong \"port\"+--             . optShort \'p\'+--             . optHelp \"Port number\"+--             . optDefault 5432+--             )+--       logOpt+--         = switchWith+--             ( optLong \"log\"+--             . optHelp \"Whether to log or not\"+--             )+--       dirOpt+--         = argumentWith strParser+--             ( optHelp \"Some directory\"+--             . optEnvVar \"SOME_DIR\"+--             . optOptional+--             )+--+--   main :: IO Config+--   main = do+--     result <- execOpt defaultSources configOpt+--     pure $ runIdentity (construct result)+-- @+--+-- The above could also be:+--+-- @+--   type ConfigOpt+--     =  Single String+--     :* Single Int+--     :* Single Bool+--     :* Single String+--+--   configOpt :: ConfigOpt Opt+--   configOpt+--     = hostOpt :* portOpt :* logOpt :* dirOpt+--     where+--       ...+--+--   main :: IO Config+--   main = do+--     host :* port :* log :* dir <- execOpt defaultSources configOpt+--     pure+--       $ runIdentity+--       $ Config+--       \<$\> getSingle host+--       \<*\> getSingle port+--       \<*\> getSingle log+--       \<*\> getSingle dir+-- @+--+-- * Nested configuration type+--+-- @+--   data Config+--     = Config+--         { dbConfig :: DbConfig+--         , serverConfig :: ServerConfig+--         }+--+--   data DbConfig+--     = DbConfig+--         { dbHost :: String+--         , dbPort :: Int+--         }+--+--   data ServerConfig+--     = ServerConfig+--         { srvPort :: Int+--         , srvLog  :: Bool+--         }+--+--   type ConfigOpt+--     =  HKD DbConfig+--     :* HKD ServerConfig+--+--   configOpt :: ConfigOpt Opt+--   configOpt+--     = dbOpt :* srvOpt+--     where+--       dbOpt = build @DbConfig ...+--       srvOpt = build @ServerConfig ...+--+--   main :: IO Config+--   main = do+--     db :* srv <- execOpt defaultSources configOpt+--     pure+--       $ runIdentity+--       $ Config+--       \<$\> construct db+--       \<*\> construct srv+-- @+--+-- * Subparsers+--+-- @+--   data OneConfig = OneConfig ...+--   data OtherConfig = OtherConfig ...+--+--   data Config+--     =  "one" :-> OneConfig+--     :+ "other" :-> OtherConfig+--+--   configOpt :: Config Opt+--   configOpt+--     = oneOpt :+ otherOpt :+ ANil+--     where+--       oneOpt = ...+--       otherOpt = ...+--+--   main :: IO ()+--   main = do+--     result <- execOpt defaultSources configOpt+--     case result of+--       HereF one            -> runWithOne one+--       ThereF (HereF other) -> runWithOther other+--     where+--       runWithOne :: One -> IO ()+--       runWithOne = ...+--       runWithOther :: Other -> IO ()+--       runWithOther = ...+-- @+--+-- TODO: more (and better) examples
+ src/Options/Harg/Cmdline.hs view
@@ -0,0 +1,104 @@+module Options.Harg.Cmdline where++import           Control.Applicative  ((<|>))+import           Data.Functor.Compose (Compose (..))+import           Data.List            (foldl')+import           Data.Maybe           (fromMaybe)++import qualified Data.Barbie          as B+import qualified Options.Applicative  as Optparse++import           Options.Harg.Pretty+import           Options.Harg.Types+++-- | Create a 'Optparse.Parser' from a list of source results and an option+-- parser. The source results are folded using '<|>' and then used as a single+-- result.+mkOptparseParser+  :: forall f a.+     ( Applicative f+     , B.TraversableB a+     , B.ProductB a+     )+  => [a (Compose Maybe f)]  -- ^ Source results+  -> a (Compose Opt f)      -- ^ Target configuration options+  -> Optparse.Parser (a f)+mkOptparseParser sources opts+  = let+      srcOpts+        = foldl'+            (B.bzipWith (<|>))+            (B.bmap (const (Compose Nothing)) opts)+            sources+    in B.bsequence $ B.bzipWith mkParser srcOpts opts++-- | Create a 'Optparse.Parser' for a single option, using the accumulated+-- source results.+mkParser+  :: Compose Maybe f a   -- ^ Accumulated source results+  -> Compose Opt f a     -- ^ Target option+  -> Compose Optparse.Parser f a+mkParser srcs opt@(Compose Opt{..})+  = case _optType of+      OptionOptType      -> toOptionParser srcs opt+      FlagOptType active -> toFlagParser srcs opt active+      ArgumentOptType    -> toArgumentParser srcs opt++-- | Create a 'Optparse.Parser' for an 'OptionOpt', which results in an+-- @optparse-applicative@ 'Optparse.option'.+toOptionParser+  :: Compose Maybe f a+  -> Compose Opt f a+  -> Compose Optparse.Parser f a+toOptionParser sources (Compose opt@Opt{..})+  = Compose $ Optparse.option (Optparse.eitherReader _optReader)+      ( foldMap (fromMaybe mempty)+          [ Optparse.long <$> _optLong+          , Optparse.short <$> _optShort+          , Optparse.help <$> ppHelp opt+          , Optparse.metavar <$> _optMetavar+          , Optparse.value <$> (getCompose sources <|> _optDefault)+          ]+      )++-- | Create a 'Optparse.Parser' for a 'FlagOpt', which results in an+-- @optparse-applicative@ 'Optparse.flag'.+toFlagParser+  :: Compose Maybe f a+  -> Compose Opt f a+  -> f a+  -> Compose Optparse.Parser f a+toFlagParser sources (Compose opt@Opt{..}) active+  =+    let+      mDef+        = case getCompose sources of+            Nothing -> _optDefault+            Just x  -> Just x+      modifiers+        = foldMap (fromMaybe mempty)+            [ Optparse.long <$> _optLong+            , Optparse.short <$> _optShort+            , Optparse.help <$> ppHelp opt+            ]+      in Compose $ case mDef of+           Nothing ->+             Optparse.flag' active modifiers+           Just def ->+             Optparse.flag def active modifiers++-- | Create a 'Optparse.Parser' for a 'ArgumentOpt', which results in an+-- @optparse-applicative@ 'Optparse.argument'.+toArgumentParser+  :: Compose Maybe f a+  -> Compose Opt f a+  -> Compose Optparse.Parser f a+toArgumentParser sources (Compose opt@Opt{..})+  = Compose $ Optparse.argument (Optparse.eitherReader _optReader)+      ( foldMap (fromMaybe mempty)+          [ Optparse.help <$> ppHelp opt+          , Optparse.metavar <$> _optMetavar+          , Optparse.value <$> (getCompose sources <|> _optDefault)+          ]+      )
+ src/Options/Harg/Config.hs view
@@ -0,0 +1,53 @@+module Options.Harg.Config where++import           Data.Functor.Compose       (Compose (..))+import           Data.Kind                  (Type)++import qualified Data.Barbie                as B+import qualified Options.Applicative        as Optparse++import           Options.Harg.Cmdline+import           Options.Harg.Sources+import           Options.Harg.Sources.Env+import           Options.Harg.Sources.Types+import           Options.Harg.Types+++-- | Create a 'Optparse.Parser' for the configuration option parser, using+-- 'EnvSource' as the only source.+mkConfigParser+  :: forall f c.+     ( Applicative f+     , B.TraversableB c+     , B.ProductB c+     )+  => HargCtx+  -> c (Compose Opt f)+  -> Optparse.Parser (c f)+mkConfigParser HargCtx{..} conf+  = let+      (_, envC)+        = accumSourceResults+        $ runSource (EnvSourceVal _hcEnv) conf+    in mkOptparseParser envC conf++-- | Run two option parsers in parallel and return the result of the+-- first one. This is used with the configuration parser being the first+-- argument, and the target option parser that has been converted to+-- the dummy parser using 'Options.Harg.Util.toDummyOpts' as the second+-- one.+getConfig+  :: HargCtx+  -> Optparse.Parser (c (f :: Type -> Type))+  -> Optparse.Parser (a (g :: Type -> Type))+  -> IO (c f)+getConfig HargCtx{..} confParser optParser+  = do+      let+        parser+          = (,) <$> confParser <*> optParser+        parserInfo+          = Optparse.info (Optparse.helper <*> parser) mempty+        res+          = Optparse.execParserPure Optparse.defaultPrefs parserInfo _hcArgs+      fst <$> Optparse.handleParseResult res
+ src/Options/Harg/Construct.hs view
@@ -0,0 +1,417 @@+{-# LANGUAGE PolyKinds               #-}+{-# LANGUAGE TypeFamilies            #-}+{-# LANGUAGE UndecidableInstances    #-}+{-# LANGUAGE UndecidableSuperClasses #-}+module Options.Harg.Construct where++import Data.Char          (toLower)+import Data.Kind          (Constraint)+import Data.String        (IsString(..))+import GHC.TypeLits       (ErrorMessage(..), TypeError, Symbol)+import Text.Read          (readMaybe)++import Options.Harg.Types+++class HasLong o (attr :: [OptAttr]) where+  -- | Add a 'Options.Applicative.long' modifier to an option+  optLong :: String -> o attr a -> o attr a++instance HasLong OptionOpt a where+  optLong s o = o { _oLong = Just s }++instance HasLong FlagOpt a where+  optLong s o = o { _fLong = Just s }++class HasShort o (attr :: [OptAttr]) where+  -- | Add a 'Options.Applicative.short' modifier to an option+  optShort :: Char -> o attr a -> o attr a++instance HasShort OptionOpt a where+  optShort c o = o { _oShort = Just c }++instance HasShort FlagOpt a where+  optShort c o = o { _fShort = Just c }++class HasHelp o (attr :: [OptAttr]) where+  -- | Add 'Options.Applicative.help' to an option+  optHelp :: String -> o attr a -> o attr a++instance HasHelp OptionOpt a where+  optHelp s o = o { _oHelp = Just s }++instance HasHelp FlagOpt a where+  optHelp s o = o { _fHelp = Just s }++instance HasHelp ArgumentOpt a where+  optHelp s o = o { _aHelp = Just s }++class HasMetavar o (attr :: [OptAttr]) where+  -- | Add a 'Options.Applicative.metavar' metavar to an option, to be+  -- displayed as the meta-parameter next to long/short modifiers+  optMetavar :: String -> o attr a -> o attr a++instance HasMetavar OptionOpt a where+  optMetavar s o = o { _oMetavar = Just s }++instance HasMetavar ArgumentOpt a where+  optMetavar s o = o { _aMetavar = Just s }++class HasEnvVar o (attr :: [OptAttr]) where+  -- | Specify an environment variable to lookup for an option+  optEnvVar :: String -> o attr a -> o attr a++instance HasEnvVar OptionOpt a where+  optEnvVar s o = o { _oEnvVar = Just s }++instance HasEnvVar FlagOpt a where+  optEnvVar s o = o { _fEnvVar = Just s }++instance HasEnvVar ArgumentOpt a where+  optEnvVar s o = o { _aEnvVar = Just s }++class HasDefault o (attr :: [OptAttr]) where+  -- | Add a default value to an option. Cannot be used in conjuction with+  -- 'optOptional'.+  optDefault+    :: NotInAttrs OptOptional attr "optDefault" "optOptional"+    => a -> o attr a -> o (OptDefault ': attr) a++instance HasDefault OptionOpt a where+  optDefault a o = o { _oDefault = Just a }++instance HasDefault ArgumentOpt a where+  optDefault a o = o { _aDefault = Just a }++-- optional+-- | Class for options that can be optional. Cannot be used in+-- conjunction with 'HasDefault'. Note that this will turn a parser for @a@+-- into a parser for @Maybe a@, modifying the reader function appropriately.+-- For example:+--+-- @+--   someOpt :: Opt (Maybe Int)+--   someOpt+--     = optionWith readParser+--         ( optLong "someopt"+--         . optOptional+--         )+-- @+class HasOptional o (attr :: [OptAttr]) where+  -- | Specify that an option is optional. This will convert an @Opt a@ to an+  -- @Opt (Maybe a)@+  optOptional+    :: NotInAttrs OptDefault attr "optOptional" "optDefault"+    => o attr a -> o (OptOptional ': attr) (Maybe a)++instance HasOptional OptionOpt a where+  optOptional OptionOpt{..}+    = OptionOpt+        { _oLong    = _oLong+        , _oShort   = _oShort+        , _oHelp    = _oHelp+        , _oMetavar = _oMetavar+        , _oEnvVar  = _oEnvVar+        , _oDefault = Just Nothing+        , _oReader  = fmap Just . _oReader+        }++instance HasOptional ArgumentOpt a where+  optOptional ArgumentOpt{..}+    = ArgumentOpt+        { _aHelp    = _aHelp+        , _aMetavar = _aMetavar+        , _aEnvVar  = _aEnvVar+        , _aDefault = Just Nothing+        , _aReader  = fmap Just . _aReader+        }++-- | Class to convert an intermediate option type into 'Opt'. Instances+-- should set the appropriate '_optType'.+class IsOpt o (attr :: [OptAttr]) where+  -- | Convert an intermediate option to an 'Opt'+  toOpt :: o attr a -> Opt a++instance IsOpt OptionOpt attr where+  toOpt OptionOpt{..}+    = Opt+        { _optLong    = _oLong+        , _optShort   = _oShort+        , _optHelp    = _oHelp+        , _optMetavar = _oMetavar+        , _optEnvVar  = _oEnvVar+        , _optDefault = _oDefault+        , _optReader  = _oReader+        , _optType    = OptionOptType+        }++instance IsOpt FlagOpt attr where+  toOpt FlagOpt{..}+    = Opt+        { _optLong    = _fLong+        , _optShort   = _fShort+        , _optHelp    = _fHelp+        , _optMetavar = Nothing+        , _optEnvVar  = _fEnvVar+        , _optDefault = Just _fDefault+        , _optReader  = _fReader+        , _optType    = FlagOptType _fActive+        }++instance IsOpt ArgumentOpt attr where+  toOpt ArgumentOpt{..}+    = Opt+        { _optLong    = Nothing+        , _optShort   = Nothing+        , _optHelp    = _aHelp+        , _optMetavar = _aMetavar+        , _optEnvVar  = _aEnvVar+        , _optDefault = _aDefault+        , _optReader  = _aReader+        , _optType    = ArgumentOptType+        }++-- | Create an option parser, equivalent to 'Options.Applicative.option'. The+-- result can then be used with 'toOpt' to convert into the global 'Opt' type.+--+-- @+--   someOption :: Opt Int+--   someOption+--     = toOpt ( option readParser+--             & optLong "someopt"+--             & optHelp "Some option"+--             & optDefault 256+--             )+-- @+option+  :: OptReader a+  -> OptionOpt '[] a+option p+  = OptionOpt+      { _oLong    = Nothing+      , _oShort   = Nothing+      , _oHelp    = Nothing+      , _oMetavar = Nothing+      , _oEnvVar  = Nothing+      , _oDefault = Nothing+      , _oReader  = p+      }++-- | Similar to 'option', but accepts a modifier function and returns an 'Opt'+-- directly.+--+-- @+--   someOption :: Opt Int+--   someOption+--     = optionWith readParser+--         ( optLong "someopt"+--         . optHelp "Some option"+--         . optDefault 256+--         )+-- @+optionWith+  :: OptReader a+  -> (OptionOpt '[] a -> OptionOpt attr b)+  -> Opt b+optionWith p f+  = toOpt $ f (option p)++-- | Create a flag parser, equivalent to 'Options.Applicative.option'. The+-- first argument is the default value (returned when the flag modifier is+-- absent), and the second is the active value (returned when the flag+-- modifier is present). The result can then be used with 'toOpt' to convert+-- into the global 'Opt' type.+--+-- @+--   someFlag :: Opt Int+--   someFlag+--     = toOpt ( flag 0 1+--             & optLong "someflag"+--             & optHelp "Some flag"+--             )+-- @+flag+  :: a  -- ^ Default value+  -> a  -- ^ Active value+  -> FlagOpt '[] a+flag d active+  = FlagOpt+      { _fLong    = Nothing+      , _fShort   = Nothing+      , _fHelp    = Nothing+      , _fEnvVar  = Nothing+      , _fDefault = d+      , _fActive  = active+      , _fReader  = const (pure d)  -- TODO+      }++-- | Similar to 'flag', but accepts a modifier function and returns an 'Opt'+-- directly.+--+-- @+--   someFlag :: Opt Int+--   someFlag+--     = flagWith 0 1+--         ( optLong "someflag"+--         . optHelp "Some flag"+--         )+-- @+flagWith+  :: a  -- ^ Default value+  -> a  -- ^ Active value+  -> (FlagOpt '[] a -> FlagOpt attr b)+  -> Opt b+flagWith d active f+  = toOpt $ f (flag d active)++-- | A 'flag' parser, specialized to 'Bool'. The parser (e.g. when parsing+-- an environment variable) will accept @true@ and @false@, but case+-- insensitive, rather than using the 'Read' instance for 'Bool'. The+-- default value is 'False', and the active value is 'True'.+--+-- @+--   someSwitch :: Opt Bool+--   someSwitch+--     = toOpt ( switch+--             & optLong "someswitch"+--             & optHelp "Some switch"+--             )+-- @+switch :: FlagOpt '[] Bool+switch+  = fl { _fReader = boolParser }+  where+    fl = flag False True++-- | Similar to 'switch', but accepts a modifier function and returns an 'Opt'+-- directly.+--+-- @+--   someSwitch :: Opt Bool+--   someSwitch+--     = switchWith+--         ( optLong "someswitch"+--         . optHelp "Some switch"+--         )+-- @+switchWith+  :: (FlagOpt '[] Bool -> FlagOpt attr Bool)+  -> Opt Bool+switchWith f+  = toOpt $ f switch++-- | Similar to 'switch', but the default value is 'True' and the active is+-- 'False'.+switch' :: FlagOpt '[] Bool+switch'+  = fl { _fReader = boolParser }+  where+    fl = flag True False++-- | Similar to 'switch'', but accepts a modifier function and returns an 'Opt'+-- directly.+switchWith'+  :: (FlagOpt '[] Bool -> FlagOpt attr Bool)+  -> Opt Bool+switchWith' f+  = toOpt $ f switch'++-- | Create an argument parser, equivalent to 'Options.Applicative.argument'.+-- The result can then be used with 'toOpt' to convert into the global 'Opt'+-- type.+--+-- @+--   someArgument :: Opt String+--   someArgument+--     = toOpt ( argument strParser+--             & optHelp "Some argument"+--             & optDefault "this is the default"+--             )+-- @+argument+  :: OptReader a+  -> ArgumentOpt '[] a+argument p+  = ArgumentOpt+      { _aHelp    = Nothing+      , _aMetavar = Nothing+      , _aEnvVar  = Nothing+      , _aDefault = Nothing+      , _aReader  = p+      }++-- | Similar to 'argument', but accepts a modifier function and returns an+-- 'Opt' directly.+--+-- @+--   someArgument :: Opt Int+--   someArgument+--     = argumentWith+--         ( optHelp "Some argument"+--         . optDefault "this is the default"+--         )+-- @+argumentWith+  :: OptReader a+  -> (ArgumentOpt '[] a -> ArgumentOpt attr b)+  -> Opt b+argumentWith p f+  = toOpt $ f (argument p)++-- | Convert a parser that returns 'Maybe' to a parser that returns 'Either',+-- with the default 'Left' value @unable to parse: \<input\>@.+parseWith+  :: (String -> Maybe a)  -- ^ Original parser+  -> String  -- ^ Input+  -> Either String a+parseWith parser s+  = maybe (Left err) Right (parser s)+  where+    err+      = "Unable to parse: " <> s++-- | A parser that uses the 'Read' instance to parse into a type.+readParser :: Read a => OptReader a+readParser+  = parseWith readMaybe++-- | A parser that returns a string. Any type that has an instance of+-- 'IsString' will work, and this parser always succeeds.+strParser+  :: IsString s+  => String+  -> Either String s+strParser+  = pure . fromString++-- | A parser that returns a 'Bool'. This will succeed for the strings+-- @true@ and @false@ in a case-insensitive manner.+boolParser :: String -> Either String Bool+boolParser s+  = case map toLower s of+      "true"  -> Right True+      "false" -> Right False+      _       -> Left ("Unable to parse " <> s <> " to Bool")+++-- | Wrap a symbol in quotes, for pretty printing in type errors.+type QuoteSym (s :: Symbol)+  = 'Text "`" :<>: 'Text s :<>: 'Text "`"++-- | Check if `x` is not an element of the type-level list `xs`. If it is+-- print the appropriate error message using `l` and `r` for clarity.+type family NotInAttrs+    (x :: k)+    (xs :: [k])+    (l :: Symbol)+    (r :: Symbol)+    :: Constraint where+  NotInAttrs _ '[]  _ _+    = ()+  NotInAttrs x (x ': _) l r+    = TypeError+    (    QuoteSym l :<>: 'Text " and " :<>: QuoteSym r+    :<>: 'Text " cannot be mixed in an option definition."+    )+  NotInAttrs x (y ': xs) l r+    = NotInAttrs x xs l r
+ src/Options/Harg/Het/All.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}+module Options.Harg.Het.All where++import Data.Kind (Type, Constraint)++-- | @All c xs@ returns a constraint which is constructed by+-- applying @c@ to all the types in @xs@.+type family All+    (c :: k -> Constraint)+    (xs :: [k])+    :: Constraint where+  All _ '[]       = ()+  All c (x ': xs) = (c x, All c xs)++-- | @AllF c xs f@ is similar to 'All', but types in @xs@ have the kind @(Type+-- -> Type) -> Type@ so they require an extra @f :: Type -> Type@ in order to+-- be of fully saturated.+type family AllF+    (c :: k -> Constraint)+    (xs :: [(Type -> Type) -> Type])+    (f :: Type -> Type)+    :: Constraint where+  AllF _ '[] _       = ()+  AllF c (x ': xs) f = (c (x f), AllF c xs f)
+ src/Options/Harg/Het/HList.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE PatternSynonyms      #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+module Options.Harg.Het.HList where++import           Data.Kind    (Type)+import           GHC.TypeLits (ErrorMessage(..), TypeError, Symbol)++import qualified Data.Barbie  as B+++-- | A heterogeneous list that holds higher-kinded types and the associated+-- type constructor, along with a type level list of 'Symbol's that act+-- as tags for each type.+data AssocListF+    (ts :: [Symbol])+    (xs :: [(Type -> Type) -> Type])+    (f :: Type -> Type) where+  ANil  :: AssocListF '[] '[] f+  ACons :: x f -> AssocListF ts xs f -> AssocListF (t ': ts) (x ': xs) f++-- | Helper type-level function to construct an 'AssocList' which is not+-- yet applied to the type constructor that needs to be fully applied.+--+-- @+--   type Config+--     =  "run" :-> RunConfig+--     :+ "test" :-> TestConfig+-- @+--+-- @Config@ above has type @(Type -> Type) -> Type@, and requires a type+-- like 'Opt' to be fully applied.+--+type family l :+ r = (res :: (Type -> Type) -> Type) where+  (tl :-> vl) :+ (tr :-> vr) = AssocListF '[tl, tr] '[vl, vr]+  (tl :-> vl) :+ AssocListF ts vs = AssocListF (tl ': ts) (vl ': vs)+  l :+ r+    = TypeError+    (    'Text "Invalid type for tagged options. Construct like this:"+    :$$: 'Text "type MyConfig"+    :$$: 'Text "  =  \"one\" :-> ConfigForOne"+    :$$: 'Text "  :+ \"two\" :-> ConfigForTwo"+    )++pattern (:+) :: x f -> AssocListF ts xs f -> AssocListF (t ': ts) (x ': xs) f+pattern x :+ xs = ACons x xs++infixr 4 :+++data (t :: Symbol) :-> (v :: (Type -> Type) -> Type) :: (Type -> Type) -> Type++infixr 5 :->++class MapAssocList (as :: [(Type -> Type) -> Type]) where+  -- | Apply a function to all higher-kinded types in an 'AssocList'.+  mapAssocList+    :: (forall a. B.FunctorB a => a f -> a g)+    -> AssocListF ts as f+    -> AssocListF ts as g++instance MapAssocList '[] where+  mapAssocList _ ANil+    = ANil++instance (MapAssocList as, B.FunctorB a) => MapAssocList (a ': as) where+  mapAssocList f (ACons x xs)+    = ACons (f x) (mapAssocList f xs)
+ src/Options/Harg/Het/Nat.hs view
@@ -0,0 +1,11 @@+module Options.Harg.Het.Nat where++-- | Type-level Peano natural number.+data Nat+  = Z+  | S Nat++-- | Singleton type for 'Nat'.+data SNat (n :: Nat) where+  SZ :: SNat Z+  SS :: SNat n -> SNat (S n)
+ src/Options/Harg/Het/Prod.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE DeriveAnyClass             #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE UndecidableInstances       #-}+module Options.Harg.Het.Prod where++import           Data.Functor.Identity (Identity)+import           Data.Kind             (Type)+import           Data.Proxy            (Proxy(..))+import           GHC.Generics          (Generic)+import           GHC.TypeLits          (KnownSymbol, symbolVal)++import           Data.Aeson            ((.:?), (.!=))+import qualified Data.Aeson            as JSON+import qualified Data.Barbie           as B+import qualified Data.Text             as Tx+++-- | Infix version of 'Data.Functor.Product'. Allows to combine+-- higher-kinded types, and keep them partially applied until needed:+--+-- @+--   data User = User { name :: String, age :: Int }+--     deriving Generic+--+--   type Config = Nested User :* Single Int+--+--   configOpt :: Config Opt+--   configOpt = ...+-- @+--+data+    ((a :: (Type -> Type) -> Type) :* (b :: (Type -> Type) -> Type))+    (f :: Type -> Type)+  = a f :* b f+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)++infixr 4 :*++deriving instance+  ( Show (a Identity)+  , Show (b Identity)+  ) => Show ((a :* b) Identity)++-- | This type adds a type-level phantom tag to a higher-kinded type.+-- Its JSON instance allows using ':*' with 'Options.Harg.Sources.JSON.JSONSource'.+newtype Tagged+    (t :: k)+    (a :: (Type -> Type) -> Type)+    (f :: Type -> Type)+  = Tagged+      { unTagged :: a f+      }+  deriving (Generic)++deriving newtype instance JSON.FromJSON (a f) => JSON.FromJSON (Tagged t a f)++instance B.FunctorB a => B.FunctorB (Tagged t a) where+  bmap nat (Tagged x) = Tagged (B.bmap nat x)++instance B.TraversableB a => B.TraversableB (Tagged t a) where+  btraverse nat (Tagged x) = Tagged <$> B.btraverse nat x++instance B.ProductB a => B.ProductB (Tagged t a) where+  bprod (Tagged l) (Tagged r) = Tagged (B.bprod l r)+  buniq f = Tagged (B.buniq f)++-- The following JSON instances need to work if and only if all elements in+-- the product are `Tagged`, hence the weird pattern matches+instance ( JSON.FromJSON (a Maybe)+         , JSON.FromJSON (b' Maybe)+         , B.ProductB a, B.ProductB b'+         , KnownSymbol ta+         , b' ~ (Tagged tb b :* c)+         ) => JSON.FromJSON ((Tagged ta a :* (Tagged tb b :* c)) Maybe) where+  parseJSON+    = JSON.withObject ":*"+    $ \o ->+          (:*)+          <$> o .:? Tx.pack (symbolVal (Proxy :: Proxy ta)) .!= B.buniq Nothing+          <*> JSON.parseJSON (JSON.Object o)++instance+    ( JSON.FromJSON (a Maybe)+    , JSON.FromJSON (b Maybe)+    , B.ProductB a, B.ProductB b+    , KnownSymbol ta+    , KnownSymbol tb+    ) => JSON.FromJSON ((Tagged ta a :* Tagged tb b) Maybe) where+  parseJSON+    = JSON.withObject ":*"+    $ \o ->+          (:*)+          <$> o .:? Tx.pack (symbolVal (Proxy :: Proxy ta)) .!= B.buniq Nothing+          <*> o .:? Tx.pack (symbolVal (Proxy :: Proxy tb)) .!= B.buniq Nothing
+ src/Options/Harg/Het/Proofs.hs view
@@ -0,0 +1,66 @@+-- | This module provides type-level functions that need proofs to work+-- properly.+{-# LANGUAGE AllowAmbiguousTypes  #-}+{-# LANGUAGE InstanceSigs         #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+module Options.Harg.Het.Proofs where++import Data.Kind          (Type)+import Data.Type.Equality+++-- | Same as 'Data.Type.Equality.gcastWith' but for heterogeneous propositional+-- equality+hgcastWith+  :: forall (a :: k) (b :: k') (r :: Type).+     (a :~~: b)+  -> (a ~~ b => r)+  -> r+hgcastWith HRefl x = x++-- * Concatenation of type-level lists++-- | Append two type-level lists+--+-- @+-- > :kind! '[Int, Bool] ++ '[Char, Maybe Int]+-- '[Int, Bool, Char, Maybe Int]+-- @+--+type family (xs :: [k]) ++ (ts :: [k]) = (res :: [k]) where+  '[]       ++ ys = ys+  (x ': xs) ++ ys = x ': (xs ++ ys)++-- | Proof that appending an empty list to any list has no effect on the latter.+class ProofNil xs where+  proofNil :: xs ++ '[] :~~: xs++instance ProofNil '[] where+  proofNil = HRefl++instance ProofNil xs => ProofNil (x ': xs) where+  proofNil = hgcastWith (proofNil @xs) HRefl++-- | Proof that appending two lists is the same as appending the first element+-- of the second list to the first one, and then appending the rest.+class Proof xs y zs where+  proof :: xs ++ (y ': zs) :~~: (xs ++ '[y]) ++ zs++instance ProofNil (xs ++ '[y]) => Proof (x ': xs) y '[] where+  proof = hgcastWith (proofNil @(xs ++ '[y])) HRefl++instance Proof '[] y zs where+  proof = HRefl++-- | Induction on the tail of the list+instance Proof xs y (z ': zs) => Proof (x ': xs) y (z ': zs) where+  proof+    ::   x ': (xs ++ (y ': z ': zs))+    :~~: x ': ((xs ++ '[y]) ++ (z ': zs))+  proof = hgcastWith (proof @xs @y @(z ': zs)) HRefl++instance Proof '[] y '[] where+  proof = HRefl
+ src/Options/Harg/Het/Variant.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE UndecidableInstances   #-}+module Options.Harg.Het.Variant where++import           Data.Kind            (Type)++import qualified Data.Barbie          as B++import           Options.Harg.Het.Nat+++-- | A Variant is similar to nested 'Either's. For example, @Variant '[Int,+-- Bool, Char]@ is isomorphic to @Either Int (Either Bool Char)@. 'VariantF'+-- is a variant for higher-kinded types, which means that the type-level list+-- holds types of kind @(Type -> Type) -> Type@, and the second parameter is+-- the type constructor @f :: Type -> Type@. To pattern match on a variant,+-- @HereF@ and @ThereF@ can be used:+--+-- @+--   getFromVariant :: Variant '[Int, Bool, String] -> Bool+--   getFromVariant (ThereF (HereF b)) = b+-- @+--+data VariantF (xs :: [(Type -> Type) -> Type]) (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 "Impossible: empty variant"++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 "Impossible: empty variant"++-- * Helpers for pattern-matching on variants+pattern In1 :: x1 f -> VariantF (x1 ': xs) f+pattern In1 x = HereF x++pattern In2 :: x2 f -> VariantF (x1 ': x2 ': xs) f+pattern In2 x = ThereF (In1 x)++pattern In3 :: x3 f -> VariantF (x1 ': x2 ': x3 ': xs) f+pattern In3 x = ThereF (In2 x)++pattern In4 :: x4 f -> VariantF (x1 ': x2 ': x3 ': x4 ': xs) f+pattern In4 x = ThereF (In3 x)++pattern In5 :: x5 f -> VariantF (x1 ': x2 ': x3 ': x4 ': x5 ': xs) f+pattern In5 x = ThereF (In4 x)++-- https://github.com/i-am-tom/learn-me-a-haskell/blob/master/src/OneOf/Fold.hs+-- | Create the signature needed for 'FromVariantF' to work. This constructs a+-- function that takes as arguments functions that can act upon each item in+-- the list that the 'VariantF' holds. For example, @VariantF [a, b, c]+-- f@ will result to the signature:+--+-- @+--   VariantF [a, b, c] f -> (a f -> r) -> (b f -> r) -> (c f -> r) -> r+-- @+--+type family FoldSignatureF (xs :: [(Type -> Type) -> Type]) r f where+  FoldSignatureF (x ': xs) r f = (x f -> r) -> FoldSignatureF xs r f+  FoldSignatureF '[] r f = r++class FromVariantF xs result f where+  fromVariantF :: VariantF xs f -> FoldSignatureF xs result f++instance FromVariantF '[x] result f where+  fromVariantF (HereF  x) f = f x+  fromVariantF (ThereF _) _ = error "Impossible: empty variant"++instance+    ( tail ~ (x' ': xs)+    , FromVariantF tail result f+    , IgnoreF tail result f+    ) => FromVariantF (x ': x' ': xs) result f where+  fromVariantF (ThereF x) _ = fromVariantF @_ @result x+  fromVariantF (HereF  x) f = ignoreF @tail (f x)++class IgnoreF (args :: [(Type -> Type) -> Type]) 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++-- | Given a type-level natural that designates a position of injection into+-- a 'VariantF', return a function that performs this injection. For example,+-- @S Z@ which corresponds to 1 or the second position in the type-level list+-- the variant holds, can give the injection @b f -> VariantF [a, b, c] f@.+-- The injection can as well be constructed without providing the position, but+-- it helps in case @x@ is not unique in @xs@.+class InjectPosF+    (n :: Nat)+    (x :: (Type -> Type) -> Type)+    (xs :: [(Type -> Type) -> Type])+    | n xs -> x 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
+ src/Options/Harg/Nested.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE AllowAmbiguousTypes        #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeFamilyDependencies     #-}+{-# LANGUAGE UndecidableInstances       #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+module Options.Harg.Nested where++import           Data.Coerce      (Coercible, coerce)+import           Data.Kind        (Type)+import           GHC.Generics     (Generic)++import qualified Data.Aeson       as JSON+import qualified Data.Barbie      as B+import qualified Data.Generic.HKD as HKD++-- Orphan HKD FromJSON instance+instance JSON.GFromJSON JSON.Zero (HKD.HKD_ f structure)+    => JSON.FromJSON (HKD.HKD structure f) where+  parseJSON+    = fmap HKD.HKD+    . JSON.gParseJSON JSON.defaultOptions JSON.NoFromArgs++-- | Newtype wrapper around 'HKD.HKD'.+newtype Nested (b :: Type) (f :: Type -> Type)+  = Nested (HKD.HKD b f)++type family Nest+    (a :: Type)+    (f :: Type -> Type)+    = (res :: Type) | res -> a where+  Nest (a -> b)      f = a -> Nest b f+  Nest (HKD.HKD a f) f = Nested a f++-- | See documentation for 'HKD.build'+--+-- @+--   data User = User { name :: String, age :: Int }+--     deriving Generic+--+--   someNestedValue :: Nested User Maybe+--   someNestedValue+--     = nested @User (Just "Joe") (Just 30)+-- @+nested+  :: forall b f k.+     ( HKD.Build b f k+     , Coercible (HKD.HKD b f) (Nested b f)+     , Coercible k (Nest k f)+     )+  => Nest k f+nested = coerce @k @(Nest k f) hkd+  where hkd = HKD.build @b @f @k++-- | See documentation for 'HKD.construct'+--+-- @+--   data User = User { name :: String, age :: Int }+--     deriving Generic+--+--   getUserBack :: Maybe User+--   getUserBack+--     = getNested hkdUser+--     where+--       hkdUser :: Nested User Maybe+--       hkdUser+--         = nested @User (Just "Joe") (Just 30)+-- @+getNested+  :: HKD.Construct f b+  => Nested b f+  -> f b+getNested (Nested hkd) = HKD.construct hkd++deriving newtype instance Generic (HKD.HKD b f) => Generic (Nested b f)+deriving newtype instance JSON.FromJSON (HKD.HKD b f) => JSON.FromJSON (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)++instance (B.TraversableB (HKD.HKD b)) => B.TraversableB (Nested b) where+  btraverse nat (Nested hkd) = Nested <$> B.btraverse nat hkd
+ src/Options/Harg/Operations.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE InstanceSigs         #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+module Options.Harg.Operations where++import           Data.Functor.Identity      (Identity(..))++import qualified Data.Barbie                as B+import qualified Options.Applicative        as Optparse++import           Options.Harg.Cmdline       (mkOptparseParser)+import           Options.Harg.Config        (mkConfigParser, getConfig)+import           Options.Harg.Het.All       (All)+import           Options.Harg.Het.HList     (AssocListF, MapAssocList(..))+import           Options.Harg.Het.Variant   (VariantF)+import           Options.Harg.Pretty        (ppWarning, ppError)+import           Options.Harg.Sources       (accumSourceResults, defaultSources)+import           Options.Harg.Sources.Env   (EnvSourceVal)+import           Options.Harg.Sources.Types (GetSource(..), RunSource(..))+import           Options.Harg.Subcommands   (Subcommands(..))+import           Options.Harg.Types         (HargCtx(..), getCtx, Opt, OptError)+import           Options.Harg.Util          (toDummyOpts, allToDummyOpts, compose)+++-- | Run the option parser and combine with values from the specified sources,+-- passing the context explicitly.+execOptWithCtx+  :: forall c a.+     ( B.TraversableB a+     , B.ProductB a+     , B.TraversableB c+     , B.ProductB c+     , GetSource c Identity+     , RunSource (SourceVal c) a+     )+  => HargCtx  -- ^ Context containing the environment and the cmdline args+  -> c Opt    -- ^ Source options+  -> a Opt    -- ^ Target configuration options+  -> IO (a Identity)+execOptWithCtx ctx conf opts+  = do+      let+        configParser = mkConfigParser ctx (compose Identity conf)+        dummyParser = mkOptparseParser [] (toDummyOpts @String opts)+      config <- getConfig ctx configParser dummyParser+      sourceVals <- getSource ctx config+      let+        (errs, sources)+          = accumSourceResults+          $ runSource sourceVals (compose Identity opts)+        parser+          = mkOptparseParser sources (compose Identity opts)+      (res, _) <- execParser ctx ((,) <$> parser <*> configParser) errs+      pure res++-- | Run the option parser and combine with values from the specified sources+execOpt+  :: forall c a.+     ( B.TraversableB a+     , B.ProductB a+     , B.TraversableB c+     , B.ProductB c+     , GetSource c Identity+     , RunSource (SourceVal c) a+     )+  => c Opt  -- ^ Source options+  -> a Opt  -- ^ Target configuration options+  -> IO (a Identity)+execOpt conf opts+  = do+      ctx <- getCtx+      execOptWithCtx ctx conf opts++-- | Run the option parser only with default sources (environment variables),+-- passing the context explicitly.+execOptWithCtxDef+  :: forall a.+     ( B.TraversableB a+     , B.ProductB a+     )+  => HargCtx  -- ^ Context containing the environment and the cmdline args+  -> a Opt    -- ^ Target configuration options+  -> IO (a Identity)+execOptWithCtxDef ctx+  = execOptWithCtx ctx defaultSources++-- | Run the option parser only with default sources (environment variables)+execOptDef+  :: forall a.+     ( B.TraversableB a+     , B.ProductB a+     )+  => a Opt -- ^ Target configuration options+  -> IO (a Identity)+execOptDef+  = execOpt defaultSources++-- | Run the subcommand parser and combine with values from the specified+-- sources, passing the context explicitly.+execCommandsWithCtx+  :: forall c ts xs.+     ( B.TraversableB (VariantF xs)+     , B.TraversableB c+     , B.ProductB c+     , Subcommands ts xs+     , GetSource c Identity+     , All (RunSource (SourceVal c)) xs+     , All (RunSource ()) xs+     , MapAssocList xs+     )+  => HargCtx  -- ^ Context containing the environment and the cmdline args+  -> c Opt    -- ^ Source options+  -> AssocListF ts xs Opt  -- ^ Target options associated with subcommands+  -> IO (VariantF xs Identity)+execCommandsWithCtx ctx conf opts+  = do+      let+        configParser = mkConfigParser ctx (compose Identity conf)+        (_, dummyCommands)+          = mapSubcommand () (allToDummyOpts @String opts)+        dummyParser+          = Optparse.subparser (mconcat dummyCommands)++      config <- getConfig ctx configParser dummyParser+      sourceVals <- getSource ctx config++      let+        (errs, commands)+          = mapSubcommand sourceVals (mapAssocList (compose Identity) opts)+        parser+          = Optparse.subparser (mconcat commands)+      (res, _) <- execParser ctx ((,) <$> parser <*> configParser) errs+      pure res++-- | Run the subcommand parser and combine with values from the specified+-- sources+execCommands+  :: forall c ts xs.+     ( B.TraversableB (VariantF xs)+     , B.TraversableB c+     , B.ProductB c+     , Subcommands ts xs+     , GetSource c Identity+     , All (RunSource (SourceVal c)) xs+     , All (RunSource ()) xs+     , MapAssocList xs+     )+  => c Opt  -- ^ Source options+  -> AssocListF ts xs Opt  -- ^ Target options associated with subcommands+  -> IO (VariantF xs Identity)+execCommands conf opts+  = do+      ctx <- getCtx+      execCommandsWithCtx ctx conf opts++-- | Run the subcommand parser only with default sources (environment+-- variables), passing the context explicitly.+execCommandsWithCtxDef+  :: forall ts xs.+     ( B.TraversableB (VariantF xs)+     , Subcommands ts xs+     , All (RunSource EnvSourceVal) xs+     , All (RunSource ()) xs+     , MapAssocList xs+     )+  => HargCtx  -- ^ Context containing the environment and the cmdline args+  -> AssocListF ts xs Opt  -- ^ Target options associated with subcommands+  -> IO (VariantF xs Identity)+execCommandsWithCtxDef ctx+  = execCommandsWithCtx ctx defaultSources++-- | Run the subcommand parser only with default sources (environment+-- variables)+execCommandsDef+  :: forall ts xs.+     ( B.TraversableB (VariantF xs)+     , Subcommands ts xs+     , All (RunSource EnvSourceVal) xs+     , All (RunSource ()) xs+     , MapAssocList xs+     )+  => AssocListF ts xs Opt  -- ^ Target options associated with subcommands+  -> IO (VariantF xs Identity)+execCommandsDef+  = execCommands defaultSources++-- | Run the optparse-applicative parser, printing accumulated errors. Errors+-- are printed as warnings if the parser succeeds.+execParser+  :: HargCtx+  -> Optparse.Parser a+  -> [OptError]+  -> IO a+execParser HargCtx{..} parser errs+  = do+      let+        res = execParserPure _hcArgs parser+      case res of+        Optparse.Success a+          -> ppWarning errs >> pure a+        _+          -> ppError errs >> Optparse.handleParseResult res++-- | Run the optparse-applicative parser and return the+-- 'Optparse.ParserResult'+execParserPure+  :: [String]+  -> Optparse.Parser a+  -> Optparse.ParserResult a+execParserPure args parser+  = let+      parserInfo+        = Optparse.info (Optparse.helper <*> parser) Optparse.forwardOptions+    in Optparse.execParserPure Optparse.defaultPrefs parserInfo args
+ src/Options/Harg/Pretty.hs view
@@ -0,0 +1,65 @@+module Options.Harg.Pretty where++import Data.List          (intercalate, nubBy)+import Data.Maybe         (fromMaybe)++import Options.Harg.Types+++ppHelp+  :: Opt a+  -> Maybe String+ppHelp Opt{..}+  = (<> ppEnvVar _optEnvVar) <$> _optHelp++ppWarning+  :: [OptError]+  -> IO ()+ppWarning []+  = pure ()+ppWarning err+  =  putStrLn "Parser succeeded with warnings:"+  >> ppOptErrors err+  >> putStrLn ""++ppError+  :: [OptError]+  -> IO ()+ppError []+  = pure ()+ppError err+  =  putStrLn "Parser errors:"+  >> ppOptErrors err+  >> putStrLn ""++ppOptErrors+  :: [OptError]+  -> IO ()+ppOptErrors+  = putStrLn+  . intercalate "\n"+  . map ppOptError+  . nubBy cmpOptErr+  where+    cmpOptErr (OptError (SomeOpt l) sl dl) (OptError (SomeOpt r) sr dr)+      =  _optLong l == _optLong r && sl == sr && dl == dr+    ppOptError :: OptError -> String+    ppOptError (OptError (SomeOpt opt) src desc)+      =  "\t"+      <> fromMaybe "<no opt name>" (_optLong opt)+      <> "\t\t"+      <> desc+      <> ppSource src+      <> ppEnvVar (_optEnvVar opt)++ppSource+  :: Maybe String+  -> String+ppSource+  = maybe "" $ \s -> " (source: " <> s <> ")"++ppEnvVar+  :: Maybe String+  -> String+ppEnvVar+  = maybe "" $ \s -> " (env var: " <> s <> ")"
+ src/Options/Harg/Single.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE UndecidableInstances       #-}+module Options.Harg.Single where++import qualified Data.Functor.Product as P+import           Data.Kind            (Type)+import           GHC.Generics         (Generic)++import qualified Data.Aeson           as JSON++import qualified Data.Barbie          as B+++-- | @Single a f@ is a newtype around @f a@, which allows mixing non-nested+-- with nested values when creating configuration parsers, using+-- 'Options.Harg.Het.Prod.:*'.+--+-- @+--   data User = User { name :: String, age :: Int }+--     deriving Generic+--+--   myConfig :: (Nested User :* Single Int) Opt+--   myConfig+--     =  nested @User nameOpt ageOpt+--     :* single intOpt+--     where+--       ...+-- @+newtype Single (a :: Type) (f :: Type -> Type)+  = Single+      { getSingle :: f a+      }++-- | Wrap a value into a 'Single'.+single :: f a -> Single a f+single = Single++deriving instance (Show a, Show (f a)) => Show (Single a f)+deriving newtype instance Generic (f a) => Generic (Single a f)+deriving newtype instance JSON.FromJSON (f a) => JSON.FromJSON (Single a f)++instance B.FunctorB (Single a) where+  bmap nat (Single p) = Single (nat p)++instance B.TraversableB (Single a) where+  btraverse nat (Single p) = Single <$> nat p++instance B.ProductB (Single a) where+  bprod (Single l) (Single r) = Single (P.Pair l r)+  buniq = Single
+ src/Options/Harg/Sources.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE AllowAmbiguousTypes  #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+module Options.Harg.Sources where++import           Data.Foldable              (foldr')+import           Data.Functor.Compose       (Compose (..))++import qualified Data.Barbie                as B++import           Options.Harg.Sources.Env+import           Options.Harg.Sources.Types+import           Options.Harg.Types+++-- | Accumulate all the successful source results and return them,+-- along with a list of errors.+accumSourceResults+  :: forall a f.+     B.TraversableB a+  => [a (Compose SourceRunResult f)]+  -> ([OptError], [a (Compose Maybe f)])+accumSourceResults+  = foldr' accumResult ([], [])+  where+    accumResult+      :: a (Compose SourceRunResult f)+      -> ([OptError], [a (Compose Maybe f)])+      -> ([OptError], [a (Compose Maybe f)])+    accumResult res (e, a)+      = case B.btraverse go res of+          (e', a') -> (e' <> e, a' : a)+    go+      :: Compose SourceRunResult f x+      -> ([OptError], Compose Maybe f x)+    go x+      = case getCompose x of+          OptFoundNoParse e -> ([e], Compose Nothing)+          OptParsed a       -> ([], Compose (Just a))+          _                 -> ([], Compose Nothing)++-- | Default sources, equivalent to 'EnvSource'+defaultSources :: EnvSource f+defaultSources+  = EnvSource
+ src/Options/Harg/Sources/Env.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+{-# LANGUAGE TypeFamilies   #-}+module Options.Harg.Sources.Env where++import           Data.Functor.Compose       (Compose (..))+import           Data.Kind                  (Type)+import           Data.List                  (find)+import           GHC.Generics               (Generic)++import qualified Data.Barbie                as B++import           Options.Harg.Sources.Types+import           Options.Harg.Types+++-- | Source that enables a parser to read options from environment variables.+data EnvSource (f :: Type -> Type) = EnvSource+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)++-- | Value of 'EnvSource', which is an association list between environment+-- variable names and values (strings).+newtype EnvSourceVal = EnvSourceVal Environment++instance GetSource EnvSource f where+  type SourceVal EnvSource = EnvSourceVal+  getSource HargCtx{..} _+    = pure (EnvSourceVal _hcEnv)++instance+    B.FunctorB a => RunSource EnvSourceVal a where+  runSource (EnvSourceVal e) opt+    = [runEnvVarSource e opt]++-- | Try to get a value from the environment variable association list.+lookupEnv+  :: Environment+  -> String+  -> Maybe String+lookupEnv env x+  = snd <$> find ((== x) . fst) env++runEnvVarSource+  :: forall a f.+     ( B.FunctorB a+     , Applicative f+     )+  => Environment+  -> a (Compose Opt f)+  -> a (Compose SourceRunResult f)+runEnvVarSource env+  = B.bmap go+  where+    go :: Compose Opt f x -> Compose SourceRunResult f x+    go (Compose opt@Opt{..})+      = case _optEnvVar of+          Nothing+            -> Compose $ pure <$> OptNotFound+          Just envVar+            -> Compose $ maybe OptNotFound tryParse (lookupEnv env envVar)+      where+        tryParse+          = either+              (OptFoundNoParse . toOptError opt (Just "EnvSource"))+              OptParsed+          . _optReader
+ src/Options/Harg/Sources/JSON.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveAnyClass       #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+module Options.Harg.Sources.JSON where++import           Data.Functor.Compose       (Compose (..))+import           Data.Functor.Identity      (Identity(..))+import           GHC.Generics               (Generic)++import qualified Data.Aeson                 as JSON+import qualified Data.Barbie                as B++import           Options.Harg.Sources.Types+import           Options.Harg.Types+import           Options.Harg.Util++-- | Source that enables a parser to read options from a JSON file.+newtype JSONSource f = JSONSource (f ConfigFile)+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)++-- | The result of reading a JSON file. @JSONSourceNotRequired@ is used when+-- the user has specified @optDefault NoConfigFile@. It holds the contents of+-- the JSON file as a 'JSON.Value'.+data JSONSourceVal+  = JSONSourceVal JSON.Value+  | JSONSourceNotRequired++instance GetSource JSONSource Identity where+  type SourceVal JSONSource = JSONSourceVal+  getSource _ctx (JSONSource (Identity (ConfigFile path)))+    = do+        contents <- readFileLBS path+        case JSON.eitherDecode contents of+          Right json+            -> pure $ JSONSourceVal json+          Left err+            -> printErrAndExit+               $ "Error decoding " <> path <> " to JSON: " <> err+  getSource _ctx (JSONSource (Identity NoConfigFile))+    = pure JSONSourceNotRequired++instance+    ( JSON.FromJSON (a Maybe)+    , B.FunctorB a+    ) => RunSource JSONSourceVal a where+  runSource (JSONSourceVal j) opt+    = [runJSONSource j opt]+  runSource JSONSourceNotRequired _+    = []++runJSONSource+  :: forall a f.+     ( B.FunctorB a+     , JSON.FromJSON (a Maybe)+     , Applicative f+     )+  => JSON.Value+  -> a (Compose Opt f)+  -> a (Compose SourceRunResult f)+runJSONSource json opt+  = let+      res :: JSON.Result (a Maybe)+      res+        = JSON.fromJSON json+      toSuccess :: Maybe x -> Compose SourceRunResult f x+      toSuccess mx+        = Compose $ pure <$> maybe OptNotFound OptParsed mx+      toFailure :: Compose Opt f x -> Compose SourceRunResult f x+      toFailure _+        = Compose $ pure <$> OptNotFound+    in case res of+         JSON.Success v -> B.bmap toSuccess v+         JSON.Error _e  -> B.bmap toFailure opt
+ src/Options/Harg/Sources/NoSource.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+{-# LANGUAGE TypeFamilies   #-}+module Options.Harg.Sources.NoSource where++import           Data.Kind                  (Type)+import           GHC.Generics               (Generic)++import qualified Data.Barbie                as B++import           Options.Harg.Sources.Types+++-- | Throwaway type whose 'GetSource' instance returns no value.+data NoSource (f :: Type -> Type) = NoSource+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)++instance GetSource NoSource f where+  type SourceVal NoSource = ()+  getSource _ctx _ = pure ()++-- | Shorthand for writing 'NoSource'.+noSources :: NoSource f+noSources+  = NoSource
+ src/Options/Harg/Sources/Types.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveFunctor        #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+module Options.Harg.Sources.Types where++import Data.Functor.Compose  (Compose (..))+import Data.Kind             (Type)+import           Data.String (IsString(..))++import Options.Harg.Het.Prod+import Options.Harg.Types+++-- | Holds errors that occur when running a source.+data SourceRunResult a+  = OptNotFound  -- ^ Source doesn't include the option+  | OptFoundNoParse OptError  -- ^ Option cannot be parsed from source+  | OptParsed a  -- ^ Successful parsing+  deriving Functor++-- | This class enables a type that describes a source to fetch+-- the source contents, potentially producing side effects (e.g. reading+-- a file).+class GetSource+    (c :: (Type -> Type) -> Type)+    (f :: (Type -> Type)) where+  -- | The type that will be returned when the source is read.+  type SourceVal c :: Type+  getSource :: HargCtx -> c f -> IO (SourceVal c)++instance+    ( GetSource l f+    , GetSource r f+    ) => GetSource (l :* r) f where+  type SourceVal (l :* r) = (SourceVal l, SourceVal r)+  getSource ctx (l :* r)+    = (,) <$> getSource ctx l <*> getSource ctx r++-- | This class is used to run the result of running 'getSource' on the+-- configuration options. In order for it to work, all types used in the+-- source configuration need to have a 'GetSource' instance, and their+-- associated 'SourceVal' types need to have a 'RunSource' instance.+class RunSource s a where+  runSource+    :: Applicative f+    => s+    -> a (Compose Opt f)+    -> [a (Compose SourceRunResult f)]++instance+    ( RunSource l a+    , RunSource r a+    ) => RunSource (l, r) a where+  runSource (l, r) opt+    = runSource l opt ++ runSource r opt++instance RunSource () a where+  runSource () _+    = []++-- | This type describes configuration files, for use with e.g. the JSON+-- source. The reason to not use 'FilePath' directly is that the user might+-- prefer to do nothing if the option for the config file has not been not+-- provided, and there's no default. Because this type has an 'IsString'+-- instance, it's very easy to define an option. For example, to define a json+-- source with a default value:+--+-- @+--   srcOpt :: JSONSource Opt+--   srcOpt = JSONSource jsonOpt+--     where+--       jsonOpt+--         = optionWith strParser+--             ( optLong "json-config"+--             . optDefault (ConfigFile "~/config.json")+--             )+-- @+--+-- And an optional JSON source:+--+-- @+--   srcOpt :: JSONSource Opt+--   srcOpt = JSONSource jsonOpt+--     where+--       jsonOpt+--         = optionWith strParser+--             ( optLong "json-config"+--             . optDefault NoConfigFile+--             )+-- @+--+data ConfigFile+  = ConfigFile FilePath+  | NoConfigFile++instance IsString ConfigFile where+  fromString = ConfigFile
+ src/Options/Harg/Sources/YAML.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveAnyClass       #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+module Options.Harg.Sources.YAML where++import           Control.Exception          (displayException)+import qualified Data.ByteString            as BS+import           Data.Functor.Compose       (Compose (..))+import           Data.Functor.Identity      (Identity(..))+import           GHC.Generics               (Generic)++import qualified Data.Barbie                as B+import qualified Data.Yaml                  as YAML++import           Options.Harg.Sources.Types+import           Options.Harg.Types+import           Options.Harg.Util+++-- | Source that enables a parser to read options from a YAML file.+newtype YAMLSource f = YAMLSource (f ConfigFile)+  deriving (Generic, B.FunctorB, B.TraversableB, B.ProductB)++-- | The result of reading a YAML file. @YAMLSourceNotRequired@ is used when+-- the user has specified @optDefault NoConfigFile@. It holds the contents of+-- the YAML file as a 'BS.ByteString'.+data YAMLSourceVal+  = YAMLSourceVal BS.ByteString+  | YAMLSourceNotRequired++instance GetSource YAMLSource Identity where+  type SourceVal YAMLSource = YAMLSourceVal+  getSource _ctx (YAMLSource (Identity (ConfigFile path)))+    = YAMLSourceVal <$> readFileBS path+  getSource _ctx (YAMLSource (Identity NoConfigFile))+    = pure YAMLSourceNotRequired++instance+    ( YAML.FromJSON (a Maybe)+    , B.FunctorB a+    ) => RunSource YAMLSourceVal a where+  runSource (YAMLSourceVal j) opt+    = [runYAMLSource j opt]+  runSource YAMLSourceNotRequired _+    = []++runYAMLSource+  :: forall a f.+     ( B.FunctorB a+     , YAML.FromJSON (a Maybe)+     , Applicative f+     )+  => BS.ByteString+  -> a (Compose Opt f)+  -> a (Compose SourceRunResult f)+runYAMLSource yaml opt+  = let+      res :: Either YAML.ParseException (a Maybe)+      res+        = YAML.decodeEither' yaml+      toSuccess :: Maybe x -> Compose SourceRunResult f x+      toSuccess mx+        = Compose $ pure <$> maybe OptNotFound OptParsed mx+      toFailure+        :: YAML.ParseException+        -> Compose Opt f x+        -> Compose SourceRunResult f x+      toFailure exc (Compose o)+        = Compose+        $ OptFoundNoParse (toOptError o (Just "YAMLSource") (displayException exc))+    in case res of+         Right v  -> B.bmap toSuccess v+         Left exc -> B.bmap (toFailure exc) opt
+ src/Options/Harg/Subcommands.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE AllowAmbiguousTypes  #-}+{-# LANGUAGE UndecidableInstances #-}+module Options.Harg.Subcommands where++import           Data.Functor.Compose       (Compose (..))+import           Data.Kind                  (Type)+import           Data.Proxy                 (Proxy (..))+import           GHC.TypeLits               (KnownSymbol, Symbol, symbolVal)++import qualified Data.Barbie                as B+import qualified Options.Applicative        as Optparse++import           Options.Harg.Cmdline+import           Options.Harg.Het.All+import           Options.Harg.Het.HList+import           Options.Harg.Het.Nat+import           Options.Harg.Het.Proofs+import           Options.Harg.Het.Variant+import           Options.Harg.Sources+import           Options.Harg.Sources.Types+import           Options.Harg.Types++-- | This class can be used with an 'AssocList'. It returns the appropriate+-- list of 'Optparse.CommandFields' in order to create a subcommand parser.+-- Given the sources to use and the association list between the command string+-- and the command type, it returns the list of command field modifiers and a+-- list of errors.+--+-- The result can be used as follows:+--+-- @+--   ...+--   (errs, commands) = 'mapSubcommand' sources opts+--   parser = 'Optparse.subparser' ('mconcat' commands)+--   ...+-- @+--+-- In order to be able to create a subcommand parser for a heterogeneous list+-- of options (rather than a sum with different constructors), the return type+-- should also be heterogeneous. Here, we return a Variant, which is a more+-- generic version of 'Either'. In order to do that, 'mapSubcommand' traverses+-- the association list and creates an injection into the Variant, according to+-- the current position. So an 'AssocList' like this:+--+-- @+--   opts :: AssocList '["run", "test"] '[RunConfig, TestConfig] Opt+--   opts = ...+-- @+--+-- Should return @VariantF '[RunConfig, TestConfig] Identity@. In order to do+-- that, it will inject @RunConfig@ based on its position (0) using @HereF@,+-- and @TestConfig@ using @ThereF . HereF@ because its position is 1.+--+class Subcommands+    (ts :: [Symbol])+    (xs :: [(Type -> Type) -> Type]) where+  mapSubcommand+    :: ( All (RunSource s) xs+       , Applicative f+       )+    => s+    -> AssocListF ts xs (Compose Opt f)+    -> ([OptError], [Optparse.Mod Optparse.CommandFields (VariantF xs f)])++instance ExplSubcommands Z ts xs '[] => Subcommands ts xs where+  mapSubcommand = explMapSubcommand @Z @ts @xs @'[] SZ+++-- | More general version of 'Subcommands'.+class ExplSubcommands+    (n :: Nat)+    (ts :: [Symbol])+    (xs :: [(Type -> Type) -> Type])+    (acc :: [(Type -> Type) -> Type]) where+  explMapSubcommand+    :: ( All (RunSource s) xs+       , Applicative f+       )+    => SNat n+    -> s+    -> AssocListF ts xs (Compose Opt f)+    -> ([OptError], [Optparse.Mod Optparse.CommandFields (VariantF (acc ++ xs) f)])++instance ExplSubcommands n '[] '[] acc where+  explMapSubcommand _ _ _ = ([], [])++-- ok wait+-- hear me out:+instance+    ( ExplSubcommands (S n) ts xs (as ++ '[x])+      -- get the correct injection into the variant by position+    , InjectPosF n x (as ++ (x ': xs))+    , B.TraversableB x+    , B.ProductB x+    , KnownSymbol t+      -- prove that xs ++ (y : ys) ~ (xs ++ [y]) ++ ys+    , Proof as x xs+    ) => ExplSubcommands n (t ': ts) (x ': xs) as where++  explMapSubcommand n srcs (ACons opt opts)+    = let+        (errs, sc)+          = subcommand+        (errs', rest)+          = hgcastWith (proof @as @x @xs)+          $ explMapSubcommand+              @(S n) @ts @xs @(as ++ '[x])+              (SS n) srcs opts++      in (errs ++ errs', sc : rest)++    where+      subcommand+        = let+            -- TODO: accumulate errors+            (errs, src)+              = accumSourceResults $ runSource srcs opt+            parser+              = mkOptparseParser src opt+            tag+              = symbolVal (Proxy :: Proxy t)+            cmd+              = Optparse.command tag+              $ injectPosF n+              <$> Optparse.info (Optparse.helper <*> parser) mempty+          in (errs, cmd)
+ src/Options/Harg/Types.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveFunctor #-}+module Options.Harg.Types where++import System.Environment (getArgs, getEnvironment)++type OptReader a = String -> Either String a++-- | The basic option type+data Opt a+  = Opt+      { _optLong    :: Maybe String -- ^ Modifier for long options (e.g. @--user@)+      , _optShort   :: Maybe Char   -- ^ Modifier for short options (e.g. @-u@)+      , _optHelp    :: Maybe String -- ^ Option help to be shown when invoked+                                    --   with @--help/-h@ or in case of error+      , _optMetavar :: Maybe String -- ^ Metavar to be shown in the help description+      , _optEnvVar  :: Maybe String -- ^ Environment variable for use with 'EnvSource'+      , _optDefault :: Maybe a      -- ^ Default value+      , _optReader  :: OptReader a  -- ^ Option parser+      , _optType    :: OptType a    -- ^ Option type+      }+  deriving Functor++-- | Option types+data OptType a+  = OptionOptType+  | FlagOptType a  -- ^ @a@ is the active value for the flag parser+  | ArgumentOptType+  deriving Functor++data OptAttr+  = OptDefault+  | OptOptional++-- * Intermediate option types++-- | Option for flags with arguments. Corresponds to 'Options.Applicative.option'.+data OptionOpt (attr :: [OptAttr]) a+  = OptionOpt+      { _oLong    :: Maybe String+      , _oShort   :: Maybe Char+      , _oHelp    :: Maybe String+      , _oMetavar :: Maybe String+      , _oEnvVar  :: Maybe String+      , _oDefault :: Maybe a+      , _oReader  :: OptReader a+      }++-- | Option for flags that act like switches between a default and an active+-- value. Corresponds to 'Options.Applicative.flag'.+data FlagOpt (attr :: [OptAttr]) a+  = FlagOpt+      { _fLong    :: Maybe String+      , _fShort   :: Maybe Char+      , _fHelp    :: Maybe String+      , _fEnvVar  :: Maybe String+      , _fDefault :: a+      , _fReader  :: OptReader a+      , _fActive  :: a+      }++-- | Option for arguments (no long/short specifiers). Corresponds to+-- 'Options.Applicative.argument'.+data ArgumentOpt (attr :: [OptAttr]) a+  = ArgumentOpt+      { _aHelp    :: Maybe String+      , _aMetavar :: Maybe String+      , _aEnvVar  :: Maybe String+      , _aDefault :: Maybe a+      , _aReader  :: OptReader a+      }++-- | Datatype that holds errors that arise when running the sources.+-- The reason why this is the only place where errors occur is that,+-- if something goes wrong when running the parser, it will be handled+-- by @optparse-applicative@.+data OptError+  = OptError+      { _oeOpt    :: SomeOpt       -- ^ Existentially quantified 'Opt'+      , _oeSource :: Maybe String  -- ^ Source name+      , _oeDesc   :: String        -- ^ Error description+      }++-- | Existential wrapper for 'Opt', so that many options can be carried in+-- a list.+data SomeOpt where+  SomeOpt :: Opt a -> SomeOpt++-- | Environment variable pairs, can be retrieved with 'getEnvironment'.+type Environment+  = [(String, String)]++-- | Command line arguments, can be retrieved with 'getArgs'.+type Args+  = [String]++-- | Context to carry around, that contains environment variables and+-- command line arguments.+data HargCtx+  = HargCtx+      { _hcEnv  :: Environment+      , _hcArgs :: Args+      }++getCtx :: IO HargCtx+getCtx+  = HargCtx <$> getEnvironment <*> getArgs++ctxFromArgs :: Args -> IO HargCtx+ctxFromArgs args+  = HargCtx <$> getEnvironment <*> pure args++ctxFromEnv :: Environment -> IO HargCtx+ctxFromEnv env+  = HargCtx <$> pure env <*> getArgs++pureCtx :: Environment -> Args -> HargCtx+pureCtx+  = HargCtx++toOptError+  :: Opt a+  -> Maybe String+  -> String+  -> OptError+toOptError+  = OptError . SomeOpt
+ src/Options/Harg/Util.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE RankNTypes #-}+module Options.Harg.Util where++import qualified Control.Exception          as Exc+import qualified Data.ByteString            as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import           Data.Functor.Compose       (Compose (..))+import           Data.Functor.Const         (Const(..))+import           System.Directory           (doesFileExist)+import           System.Exit                (exitFailure)++import qualified Data.Barbie                as B++import           Options.Harg.Het.HList+import           Options.Harg.Types+++compose+  :: forall f g a.+      ( Functor f+      , B.FunctorB a+      )+  => (forall x. x -> g x)+  -> a f+  -> a (Compose f g)+compose to+  = B.bmap (Compose . fmap to)++-- | Convert an option parser into a dummy parser. A dummy option parser always+-- succeeds because options always have a default value (a monoid is used+-- here). This is useful because we want to run the parser together with the+-- configuration parser once in order to gather JSON file paths etc., which+-- means that we still need @--help@ to work.+toDummyOpts+  :: forall m a.+     ( B.FunctorB a+     , Monoid m+     )+  => a Opt+  -> a (Compose Opt (Const m))+toDummyOpts+  = B.bmap toDummy+  where+    toDummy opt+      = Compose+      $ Const+      <$> opt+            { _optDefault = Just mempty+            , _optReader  = pure . const mempty+            , _optType+                = case _optType opt of+                    OptionOptType   -> OptionOptType+                    FlagOptType _   -> FlagOptType mempty+                    ArgumentOptType -> ArgumentOptType+            }++-- | Convert an association list of options in to dummy ones.+allToDummyOpts+  :: forall m ts xs.+     ( Monoid m+     , MapAssocList xs+     )+  => AssocListF ts xs Opt+  -> AssocListF ts xs (Compose Opt (Const m))+allToDummyOpts+  = mapAssocList toDummyOpts++printErrAndExit+  :: forall a.+     String+  -> IO a+printErrAndExit+  = (>> exitFailure) . putStrLn++readFileWith+  :: (FilePath -> IO a)+  -> FilePath+  -> IO a+readFileWith f path+  = do+      exists <- doesFileExist path+      if exists+        then readFile_+        else printErrAndExit ("File not found: " <> path)+  where+    readFile_+      = f path+          `Exc.catch` (printErrAndExit . showExc)++    showExc :: Exc.IOException -> String+    showExc exc+      = "Could not read file " <> path <> ": " <> Exc.displayException exc++readFileLBS+  :: FilePath+  -> IO LBS.ByteString+readFileLBS+  = readFileWith LBS.readFile++readFileBS+  :: FilePath+  -> IO BS.ByteString+readFileBS+  = readFileWith BS.readFile
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"