diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# Changelog for harg + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -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 `, `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) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 `, `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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/harg.cabal b/harg.cabal new file mode 100644 --- /dev/null +++ b/harg.cabal @@ -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 +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 diff --git a/src/Options/Harg.hs b/src/Options/Harg.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg.hs @@ -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 diff --git a/src/Options/Harg/Cmdline.hs b/src/Options/Harg/Cmdline.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Cmdline.hs @@ -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) + ] + ) diff --git a/src/Options/Harg/Config.hs b/src/Options/Harg/Config.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Config.hs @@ -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 diff --git a/src/Options/Harg/Construct.hs b/src/Options/Harg/Construct.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Construct.hs @@ -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: \@. +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 diff --git a/src/Options/Harg/Het/All.hs b/src/Options/Harg/Het/All.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Het/All.hs @@ -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) diff --git a/src/Options/Harg/Het/HList.hs b/src/Options/Harg/Het/HList.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Het/HList.hs @@ -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) diff --git a/src/Options/Harg/Het/Nat.hs b/src/Options/Harg/Het/Nat.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Het/Nat.hs @@ -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) diff --git a/src/Options/Harg/Het/Prod.hs b/src/Options/Harg/Het/Prod.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Het/Prod.hs @@ -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 diff --git a/src/Options/Harg/Het/Proofs.hs b/src/Options/Harg/Het/Proofs.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Het/Proofs.hs @@ -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 diff --git a/src/Options/Harg/Het/Variant.hs b/src/Options/Harg/Het/Variant.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Het/Variant.hs @@ -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 diff --git a/src/Options/Harg/Nested.hs b/src/Options/Harg/Nested.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Nested.hs @@ -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 diff --git a/src/Options/Harg/Operations.hs b/src/Options/Harg/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Operations.hs @@ -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 diff --git a/src/Options/Harg/Pretty.hs b/src/Options/Harg/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Pretty.hs @@ -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 "" (_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 <> ")" diff --git a/src/Options/Harg/Single.hs b/src/Options/Harg/Single.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Single.hs @@ -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 diff --git a/src/Options/Harg/Sources.hs b/src/Options/Harg/Sources.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Sources.hs @@ -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 diff --git a/src/Options/Harg/Sources/Env.hs b/src/Options/Harg/Sources/Env.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Sources/Env.hs @@ -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 diff --git a/src/Options/Harg/Sources/JSON.hs b/src/Options/Harg/Sources/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Sources/JSON.hs @@ -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 diff --git a/src/Options/Harg/Sources/NoSource.hs b/src/Options/Harg/Sources/NoSource.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Sources/NoSource.hs @@ -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 diff --git a/src/Options/Harg/Sources/Types.hs b/src/Options/Harg/Sources/Types.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Sources/Types.hs @@ -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 diff --git a/src/Options/Harg/Sources/YAML.hs b/src/Options/Harg/Sources/YAML.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Sources/YAML.hs @@ -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 diff --git a/src/Options/Harg/Subcommands.hs b/src/Options/Harg/Subcommands.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Subcommands.hs @@ -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) diff --git a/src/Options/Harg/Types.hs b/src/Options/Harg/Types.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Types.hs @@ -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 diff --git a/src/Options/Harg/Util.hs b/src/Options/Harg/Util.hs new file mode 100644 --- /dev/null +++ b/src/Options/Harg/Util.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"