hsoptions (empty) → 1.0.0.0
raw patch · 15 files changed
+4191/−0 lines, 15 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, containers, directory, hsoptions, parsec, regex-compat, regex-posix, test-framework, test-framework-hunit, test-framework-quickcheck2
Files
- LICENSE +202/−0
- README.md +816/−0
- Setup.hs +2/−0
- examples/ComplexFlag.hs +64/−0
- examples/DependentDefaultsDemo.hs +32/−0
- examples/SimpleFlag.hs +30/−0
- hsoptions.cabal +156/−0
- src/System/Console/HsOptions.hs +177/−0
- src/System/Console/HsOptions/Core.hs +2093/−0
- src/System/Console/HsOptions/Parser.hs +23/−0
- src/System/Console/HsOptions/ParserCore.hs +204/−0
- src/System/Console/HsOptions/Types.hs +268/−0
- tests/unit/MainTestSuite.hs +17/−0
- tests/unit/System/Console/HsOptionsTestHelpers.hs +81/−0
- tests/unit/UnitTestHelper.hs +26/−0
+ LICENSE view
@@ -0,0 +1,202 @@+Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "{}"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright {yyyy} {name of copyright owner}++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+
+ README.md view
@@ -0,0 +1,816 @@+HsOptions+========++HsOptions is a Haskell library that supports command-line flag processing.++It is equivalent to `getOpt()`, but for `Haskell`, and with a lot of neat extra+features. Typically, an application specifies what flags it is expecting from+the user -- like `--user_id` or `-file <filepath>` -- somehow in the code,+`HsOptions` provides a declarative way to define the flags in the code by using+the `make` function.++Most flag processing libraries requires all the flags to be defined in a single+point, such as the main file, but `HsOptions` allows the flags to be scattered+around the code, promoting code reuse and scalability. A module defines the+flags it needs and when this module is used in other modules it's flags are+handled by `HsOptions`.++`HsOptions` is completely functional, specially because no global state is+modified. The only `IO` actions performed are to get the command-line arguments+and to expand the configuration files.++Another important feature of `HsOptions` is that it can process flags from text+files as well as from command-line. This feature is available with the use of+the special `--usingFile <filename>` flag.++For example:+++ # inside 'file1.conf'+ --user_name batman+ --pretty++... when running the `Program.hs` haskell program:++ $ runhaskell Program.hs --debug --usingFile file1.conf -f++ === is evaluates the same as ==== >++ $ runhaskell Program.hs --debug --user_name batman --pretty -f+++Each configuration file is expanded after it is processed, so it can include+more configuration files and create a tree. This is useful to create different+environments, like production.conf, dev.conf and qa.conf just to name a few.++[](https://travis-ci.org/josercruz01/hsoptions)++Table of contents+=================++- [HsOptions](#hsoptions)+- [Table of contents](#table-of-contents)+- [Install](#install)+- [Examples](#examples)+- [API](#api)+ - [Defining flags](#defining-flags)+ - [Process flags](#process-flags)+ - [Get flag value](#get-flag-value)+ - [Optional and Required flags](#optional-and-required-flags)+ - [Configuration files](#configuration-files)+ - [Default value](#default-value)+ - [Common configurations](#common-configurations)+ - [Flag alias](#flag-alias)+ - [Dependent defaults](#dependent-defaults)+ - [Optionally required](#optionally-required)+ - [Global validation](#global-validation)+ - [Flag parsers](#flag-parsers)+ - [Parsers](#parsers)+ - [Parser wrappers](#parser-wrappers)+ - [Flag operations](#flag-operations)+ - [Assign](#assign)+ - [Inherit keyword](#inherit-keyword)+ - [Append](#append)+ - [Prepend](#prepend)+ - [Change flag default operation](#change-flag-default-operation)+- [Build](#build)++Install+=======++The library depends on cabal+([Install Cabal](http://www.haskell.org/cabal/download.html)).++To install using cabal:++ cabal install hsoptions++Examples+========++See [Examples](https://github.com/josercruz01/hsoptions/tree/master/examples)+for more examples.++This program defines two flags (`user_name` of type `String` and `age` of type+`Int`) and in the `main` function prints the name and the age plus 5. It also+adds the alias `u` to the flag `user_name`.++```haskell+-- Program.hs+import System.Console.HsOptions++userName = make ( "user_name"+ , "the user name of the app"+ , [ parser stringParser+ , aliasIs ["u"]+ ]+ )+userAge = make ("age", "the age of the user", [parser intParser])++flagData = combine [flagToData userName, flagToData userAge]++main :: IO ()+main = processMain "Simple example for HsOptions."+ flagData+ success+ failure+ defaultDisplayHelp++success :: ProcessResults -> IO ()+success (flags, args) = do let nextAge = (flags `get` userAge) + 5+ putStrLn ("Hello " ++ flags `get` userName)+ putStrLn ("In 5 years you will be " +++ show nextAge +++ " years old!")++failure :: [FlagError] -> IO ()+failure errs = do putStrLn "Some errors occurred:"+ mapM_ print errs+```++You can run this program in several ways:++ $ runhaskell Program.hs --user_name batman --age 23+ Hello batman+ In 5 years you will be 28 years old!++... or:++ $ runhaskell Program.hs --user_name batman --age ten+ Some errors occurred:+ Error with flag '--age': Value 'ten' is not valid++... or:++ $ runhaskell Program.hs --help+ Simple example for HsOptions.+ --age the age of the user+ -u --user_name the user name of the app+ --usingFile read flags from configuration file+ -h --help show this help++API+===++Defining flags+----------------+A flag is defined using the `make` function. It takes the name of the flag, the+help text and the parser. The parser specified how to parse the string value of+the flag to the correct type. A set of default parsers are provided in the+library for common types.++To define a flag of type `Int`:++```haskell+age :: Flag Int+age = make ("age", "age of the user", [parser intParser])+```++To define the same flag of type `Maybe Int`:++```haskell+age :: Flag (Maybe Int)+age = make ("age", "age of the user", [maybeParser intParser])+```++The function `maybeParser` is a wrapper for a parser of any type that converts+that parser to a `Maybe` data type, allowing the value to be `Nothing`. This is+used mostly for optional flags.++Instead of `intParser` the user can specify his custom function to parse the+string value to the corresponding flag type. This is useful to allow the user to+create flags of any custom type.++Process flags+-----------------------------------++To process the flags the `processMain` function is used. This function serves as+a middle man between the real `main` and the flag processing. Takes 5 arguments:++* The description of the program: used when printing the help text.+* A collection of all the defined flags+* Three callback functions:+ * Success callback: called with the process results if no errors occurred+ * Failure callback: called if any error while processing flags occurred+ * Display help callback: called if the user sent the `--help` flag++This is an example on how to call the `processMain` function:++```haskell+import System.Console.HsOptions++-- flags definitions+name = make ("name", "the name of the user", [parser stringParser])+age = make ("age", "the age of the user", [parser intParser])++-- collection of all flags+all_flags = combine [flagToData age, flagToData name]++-- real main+main = processMain "Example program for processMain"+ all_flags+ successMain+ defaultDisplayErrors+ defaultDisplayHelp++-- new main function+successMain (flags, args) = putStrLn $ flags `get` name+```++In this example, the provided implementations for the failure and the display+help callback were used (`defaultDisplayErrors` and `defaultDisplayHelp`), so+that we do not need to define how to print errors or how to print help.++As mentioned before, if no errors were found then `successMain` function is+called. The argument sent is a tuple (`FlagResults`, `ArgsResults`).+`FlagResults` is a data structure that can be used to get the flag's value with+the `get` function. `ArgResults` is just a list of the non-flag positional+arguments.++If there was any kind of errors while processing the flags the `display errors`+callback argument is called with the list of `FlagError` as argument. The user+can specify a custom function so he handles the argument as he wishes.++The third callback, `display help`, is called when the user sent the special help+flag (`--help` or `-h`). It takes the program description and all the+information of the flags as a list of (`flag_name`, `[flag_alias]`,+`flag_helptext`). The `defaultDisplayHelp` is a default implementation that+prints the helptext in a standard format, usually this is the way to go unless+the user wants to print the help text in a custom format.++Get flag value+-----------------------------------++A flag value is obtained by using the `get` function. It takes the `FlagResults`+and a defined flag as a parameter, and it will look for the value of the flag+inside the `FlagResults`. In a way you can think of `FlagResults` as a data+structure that can be queried with flags to retrieve flag values.++The `FlagResults` are obtained by processing the flags with the+[`processMain`](#process-flags) function.++The return type of `get` is the type of the flag, so if the flag is `Flag Int`+then `get` returns an `Int` (so the flag value is typed).++For a given flag:++```haskell+repeat = make ("repeat", "how many times to repeat", [parser intParser])+```++... we can grab it's value after processing like this:++```haskell+success :: (FlagResults, ArgsResults) -> IO ()+success (flags, args) = do let r = flags `get` repeat+ putStrLn $ "The value of repeat is " ++ show r+```++Optional and Required flags+-----------------------------------+By default all flags are marked as required. If you want to make an optional+flag then two things are required:++ * First, the type of the flag must be `Flag (Maybe a)`, so that the flag can+ be `Nothing` if it was not provided and `Just value` if it was.++ * Second, the flag must be configured using the `isOptional` flag+ configuration.++Example:++```haskell+-- optional flag+database :: Flag (Maybe String)+database = make ("db", "the database", [maybeParser stringParser, isOptional])++-- required flag+app_id :: Flag Int+app_id = make ("app_id", "application to run", [parser intParser])++-- combine all flags+all_flags = combine [flagToData database, flagToData app_id]++-- main+main = processMain "Sample" all_flags success+ defaultDisplayErrors defaultDisplayHelp++-- success main+success (flags, _) = do putStrLn $ "database: " ++ show (flags `get` database)+ putStrLn $ "app_id: " ++ show (flags `get` app_id)+```++This is the expected behavior when getting the flag value:++ $ runhaskell Program.hs+ Errors occurred while parsing flags:+ Error with flag '--app_id': Flag is required++... as you can see only `app_id` is required, but not `database`.++ $ runhaskell Program.hs --app_id = 123+ database: Nothing+ app_id: 123++... value for `database` is `Nothing`.++ $ runhaskell Program.hs --app_id = 123 --db = local+ database: Just "local"+ app_id: 123++Configuration files+=====++Flags can be processed not only from command-line input, but also from configuration text+files. These text files are included at any point in the command-line stream by using the+special flag `--usingFile <filename>`.++When the flag processor encounters a `usingFile` it reads the content of the file and+runs the processor again with this content, consuming the `usingFile` flag and replacing+it with all the new flags found inside the configuration file.++A configuration file can itself include other configuration files as well, by using the+`usingFile` flag inside the file, so a tree of files can be created (a file can have a+parent file, and a grandparent file, or a file can include multiple files to combine+them together).++If there is any kind of error while reading the file, or there is a syntax error inside+the file then that error is reported to the user.++This is an example of a configuration file that has comments, and that includes two more+files.+++```+# combined.conf+--database = localdb+--usingFile = file1.conf+--usingFile = file2.conf+jack+jill+batman+```++```+# file1.conf+--flagA = 3+```+++```+# file2.conf+--flagB = 42+```++So if we have a `Program.hs` that is configured with the flags `database`, `flagA` and `flagB`,+and that prints the remaining positional arguments, then this is the output of the program+for the following scenarios:++```+$ runhaskell Program.hs --usingFile combined.conf+database: localdb+flagA: 3+flagB: 42+args: ["jack","jill","batman"]+```++We can send more arguments, or modify flags, after or before including the file:++```+$ runhaskell Program.hs superman --usingFile combined.conf robin+database: localdb+flagA: 3+flagB: 42+args: ["superman", "jack","jill","batman", "robin"]+```++... as you can observe `superman` and `robin` are respectively at the start and end+of the positional arguments, that is because first `superman` is found in the input stream,+then the `usingFile combined.conf` which gets evaluated and parsed, and when this is+complete then the processor moves to `robin` which is captured as the last positional+argument.++Here is another example on how we can override and extend the flags. We will change the+`flagA` to 1024 and will append the value `.local` to the `database` flag.++```+$ runhaskell Program.hs --usingFile combined.conf --database +=! ".local" --flagA = 1024+database: localdb.local+flagA: 1024+flagB: 42+args: ["jack","jill","batman"]+```++Default value+=====++There is two types of default flag values, a default value when the flag was not provided+by the user, and another default value for when the user provided the flag but not the+flag value. The flag configurations are `defaultIs` and `emptyValueIs`.++A default value can be configured for a flag by using the `defaultIs` flag configuration. It takes the value that the flag will have in case the flag is not provided by the user.++Example:++```haskell+database = make ("database", "the db connection", [ parser stringParser+ , defaultIs "local.sqlite"])+```++So for example:++ $ runhaskell Program.hs+ database: local.sqlite++... if you set the value then the default is ignored:++ $ runhaskell Program.hs --database production.sqlite+ database: production.sqlite++... but, it should be noted that if you send the flag, but not it's value, then an error will+occur, as the system assumes you meant to set a value to the flag:++ $ runhaskell Program.hs --database+ Some errors occurred:+ Error with flag '--database': Flag value was not provided++... if you want to add a default value for the flag value is empty use the `emptyValueIs` flag+configuration:++```haskell+database = make ("database", "the db connection", [ parser stringParser+ , defaultIs "local.sqlite",+ , emptyValueIs "prod.sqlite"])+```++ $ runhaskell Program.hs --database+ database: prod.sqlite++The combination of `defaultIs` and `emptyValueIs` makes it possible to define flags such as+booleans. So we could set up a flag such as `--debug` (`Bool`) that will take the value+`False` if missing and will take the value `True` if the user sent `--debug` without him+having to say `--debug = True`.++Common configurations+=====+There are some common patterns that occurs while configuring flags. These patterns+can be put into a function for code reuse.++### Boolean flag++A default behavior for boolean flag is that if the flag is missing then it's value is+`False` and if the flag is present, even with a missing flag value, then it's value is+`True`.++For this the `boolFlag` flag configuration was created.++```haskell+debug = make ("debug", "debug flag", boolFlag])+```++This is equivalent to:++```haskell+debug = make ("debug", "debug flag", [ parser boolParser+ , defaultIs False+ , emptyValueIs True+ ])+```++This is because `boolFlag` is defined as such:++```haskell+boolFlag :: [FlagConf Bool]+boolFlag = [ parser boolParser+ , defaultIs False+ , emptyValueIs True+ ]+]+```+++Flag alias+=====+Creates a flag configuration for the aliases of the flag.++Sets multiple alias for a single flag. `(--user_id alias: ["u", "uid")`. These+aliases can be used to set the flag value, so `--user_id = 8` is equivalent to+`-u = 8`.++They are set using the `aliasIs` flag configuration:++```haskell+user_id = make ("user_id", "the id", [parser intParser, aliasIs ["u", "uid"]])+```++Dependent defaults+=====++Creates a flag configuration that will define a default value for a flag based+on a condition. This condition is a function that takes in the current+`FlagResults` and returns `Nothing` if the there is no default value or the+default value (`Just`) if there is one.++If the function returns a value, and the user did not send the flag in the+input stream, then the default value associated with this function is used+as the default value for the flag.++The dependent default value is configured by using the `defaultIf` function.+It takes as arguments the `default value getter function` that given the+`FlagResults` tries to return a default value.++Example:++```haskell+userName = make ("user_name", "the user", [parser stringParser])++movie = make ( "movie"+ , "the movie of the user"+ , [ parser stringParser+ , defaultIf (\ flags ->+ if flags `get` userName == "neo"+ then Just "matrix"+ else if flags `get` userName == "bruce"+ then Just "batman"+ else Nothing)+ ]+ )+```++This is the output for different scenarios:++ $ runhaskell Program.hs --user_name other+ Some errors occurred:+ Error with flag '--movie': Flag is required++... since non of the predicate matched then the flag is required to the user.++ $ runhaskell Program.hs --user_name batman+ user_name: bruce+ movie: batman-begins++... as you can see the first dependent default matched, so it's value is used.++ $ runhaskell Program.hs --user_name neo+ user_name: neo+ movie: batman-matrix++This configuration is useful in scenarios where a flag's default value depends on+the value of on or more flags.++Optionally required+=====+You can mark a flag optionally required by using the `requiredIf` flag configuration.++This flag configuration needs a `predicate` function that given the current `FlagResults`+returns `True` or `False` depending if the flag should or should not be required.++For example it is useful to make a flag required if another flag was set to a particular+value:++```haskell+log_memory = make ( "log_memory"+ , "if set to true the memory usage will be logged"+ , boolFlag)+++log_output = make ( "log_output"+ , "where to save the log. required if 'log_memory' is true"+ , [ maybeParser stringParser+ , requiredIf (\ flags -> flags `get` log_memory == True)+ ]+ )+```++... after the flags are processed then the optionally required condition is checked. If+the configured predicate returns true an error is reported to the user:++ $ runhaskell Program.hs+ log_memory: False+ log_output: Nothing++... if you send the `log_memory` the conditional predicate will return `True` and the flag+will be required:++ $ runhaskell Program.hs --log_memory+ Some errors occurred:+ Error with flag '--log_output': Flag is required++... if you send the value for `log_output` then an error should not occur:++ $ runhaskell Program.hs --log_memory --log_output /tmp/memorylog.tmp+ log_memory: True+ log_output: Just "/tmp/memorylog.tmp"+++Global validation+=====++A global validation rule is a function that will be evaluated with the `FlagResults`+after the processing stage and will determine if the current state is valid.++It is the last stage of flag processing. If there is a validation error then this error+is reported to the user. This validation is done by using the `validate` function that+takes a function that returns a `Maybe String`, `Nothing` being a passing result and `Just+err` being failing result with an `err` error message.++For example:++```haskell+flagData = combine [ flagToData user_id+ , validate (\fr -> if get fr user_id < 0+ then Just "user id negative error"+ else Nothing)+ ]+```++An error will be produces if the application is run with a negative `user_id`.+++Flag parsers+=====++Flag parser configurations.++### Parsers++#### `intParser`+Parses a flag value to an integer.++#### `floatParser`+Parses a flag value to a float.++#### `doubleParser`+Parses a flag value to a double.++#### `charParser`+Parses a flag value to a char.++#### `stringParser`+Parses a flag value to a string.++#### `boolParser`+Parses a flag value to a boolean.++#### `arrayParser`+Parses a flag value to an array.+++### Parser wrappers++### `toMaybeParser`++Takes a `parser` as argument and wraps it so it becomes a `Maybe a` parser.++Used to convert an existent parser to an optional parser.++ intPaser :: FlagArgument -> Int+ toMaybeParser intParser :: FlagArgument -> Maybe Int++If the flag was missing or the flag value was missing then the new parser will+return `Nothing`, otherwise the wrapped parser is called.++It comes handy when you create a flag of type `Maybe a` and you want to use one of the+existent parsers:++```haskell+user_id :: Flag (Maybe Int)+user_id = make ("user_id", "help", [parser (toMaybeParser intParser)])+```++Since this seems to be a common pattern the `maybeParser` method was created that+combines the `parser` function with the `toMaybeParser`. The previous example is+equivalent to:++```haskell+user_id :: Flag (Maybe Int)+user_id = make ("user_id", "help", [maybeParser intParser])+```+++Flag operations+=====++Flag operations allows the user to set the value of a flag based on the previous value set.+This is useful in situations where configuration files are used, so that a child configuration+file can extend the value of a flag set in a parent configuration file.++Operations are specified when setting a value for a flag. This is the syntax to set a flag:+`--flag_name [operation] flag_value`. If the `[operation]` is not set then the `assign (=)`+operation is implied.+++### Assign++This is the default operation. Sets the value of the flag, overwriting any previous value if+there was any. This is the default operation unless the user+[changed it](#change-flag-default-operation) in the flag configuration.++Example:++ $ runhaskell Program.hs --file = "/home/user/" --file = "/tmp"+ file: "/tmp"++### Inherit keyword++The `$(inherit)` keyword can be used in the flag value and will be expanded to the previous+value of the flag (or to empty string if no previous value).++Example:++ $ runhaskell Program.hs --file = "/home/user" --file = "$(inherit)/local/tmp"+ file: "/home/user/local/tmp"++... and with no previous value:++ $ runhaskell Program.hs --file = "$(inherit)/local/tmp"+ file: "/local/tmp"+++### Append+It's an specification of the `$(inherit)` keyword to append the current value of the flag to+the previous. There are two ways to append, using the `+=` symbol or the `+=!` symbol.++They are the same except that `+=` puts a space between previous value and current value (if+there is a previous value for the flag).++They are equivalent to:++ --file += /local/tmp <=> --file = "$(inherit) /local/tmp" -- space in between+ --file +=! /local/tmp <=> --file = "$(inherit)/local/tmp" -- no space in between++Example `(+=)`:++ $ runhaskell Program.hs --warning = "1 2" --warning += "3"+ warning: "1 2 3"++Example `(+=!)`:++ $ runhaskell Program.hs --warning = "warn-1,2" --warning +=! ",3"+ warning: "warn-1,2,3"+++### Prepend+It's an specification of the `$(inherit)` keyword to prepend the current value of the flag to+the previous. There are two ways to prepend, using the `=+` symbol or the `=+!` symbol.++They are the same except that `=+` puts a space between previous value and current value (if+there is a previous value for the flag).++They are equivalent to:++ --file =+ /local/tmp <=> --file = "/local/tmp $(inherit)" -- space in between+ --file =+! /local/tmp <=> --file = "/local/tmp$(inherit)" -- no space in between++Example `(=+)`:++ $ runhaskell Program.hs --warning = "1 2" --warning =+ "0"+ warning: "0 1 2"++Example `(=+!)`:++ $ runhaskell Program.hs --warning = "warn-1,warn-2" --warning =+! "warn-0,"+ warning: "warn-0,warn-1,warn-2"++### Change flag default operation++By default a flag's default operation is the `assign (=)` operation. So if the user sends+a flag and it's value without explicitly using an operation this is the operation used.++Now if you want to change this behavior for a given flag you can do so by using the+`operation` flag configuration. This takes an operation as an argument and sets this+as the default operation for the flag:++```haskell+warning = make ("warn", "warnings to print", [parser stringParser, operation append])+```++Now if you run the program like this:++ $ runhaskell Program.hs --warn 1 --warn 2 --warn 3+ warn: "1 2 3"++You can overwrite this default if you specify the operation in the command line:++ $ runhaskell Program.hs --warn 1 --warn 2 --warn 3 --warn = 0+ warn: "0"++The available operations for the flag are these:++ * `assign` (=)+ * `append` (+=)+ * `append'` (+=!)+ * `prepend` (=+)+ * `prepend'` (=+!)+Build+=====++Build from source using `build` (build and run tests):++ $ ./build++Or using cabal:++ $ cabal build -- builds the text+ $ cabal test -- runs all tests+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/ComplexFlag.hs view
@@ -0,0 +1,64 @@+import System.Console.HsOptions+import qualified Greeter as Greeter++userIdFlag :: Flag Int+userIdFlag = make ("user_id", "the user id of the app", [parser intParser,+ aliasIs ["u"]])++description :: String+description = "Complex Haskell program\n" +++ "Just prints a simple message based on the input flags"++database :: Flag (Maybe String)+database = make ("database", "database connection string. required if user_id == -1",+ [maybeParser stringParser,+ aliasIs ["db"],+ requiredIf (\ fr -> get fr userIdFlag == -1)])++tellJoke :: Flag Bool+tellJoke = make ("tell_joke", "tells a joke", boolFlag)++profileMemory :: Flag Bool+profileMemory = make ("profile_memory", "profiles the memory of the app", boolFlag)++profileDisk :: Flag Bool+profileDisk = make ("profile_disk", "profiles the disk usage of the app", boolFlag)++flagData :: FlagData+flagData = combine [+ combine [ flagToData userIdFlag,+ flagToData database,+ flagToData tellJoke,+ flagToData profileMemory,+ flagToData profileDisk],+ Greeter.flagData,++ -- Global validation+ validate (\fr -> if get fr profileMemory && get fr profileDisk+ then Just "'--profile_memory' and '--profile_disk' can't be on at the same time"+ else Nothing)+ ]++main_success :: ProcessResults -> IO ()+main_success (flags, argsResults) =+ do let userId = flags `get` userIdFlag -- get userId+ db = flags `get` database -- get database++ putStrLn $ "Main.hs: Args: " ++ show argsResults+ putStrLn $ "Main.hs: User id: " ++ show userId+ putStrLn $ "Main.hs: Database: " ++ show db++ -- Call other modules+ Greeter.sayHello flags++ putStrLn $ if flags `get` tellJoke+ then "I never make mistakes…I thought I did once; but I was wrong."+ else "Not a time for jokes."+++main :: IO ()+main = processMain description+ flagData+ main_success+ defaultDisplayErrors+ defaultDisplayHelp
+ examples/DependentDefaultsDemo.hs view
@@ -0,0 +1,32 @@+import System.Console.HsOptions++userName = make ("user_name", "the user", [parser stringParser])++movie = make ( "movie"+ , "the movie of the user"+ , [ parser stringParser+ , defaultIf (\ flags ->+ if flags `get` userName == "neo"+ then Just "matrix"+ else if flags `get` userName == "bruce"+ then Just "batman"+ else Nothing)+ ]+ )++flagData = combine [flagToData userName, flagToData movie]++main :: IO ()+main = processMain "Simple example for HsOptions."+ flagData+ success+ defaultDisplayErrors+ defaultDisplayHelp++putFlag :: Show a => (String, FlagResults, Flag a) -> IO ()+putFlag (name, flags, flag) =+ putStrLn $ name ++ ": " ++ show (flags `get` flag)++success :: ProcessResults -> IO ()+success (flags, args) = do putFlag ("user_name", flags, userName)+ putFlag ("movie", flags, movie)
+ examples/SimpleFlag.hs view
@@ -0,0 +1,30 @@+import System.Console.HsOptions++userName = make ( "user_name"+ , "the user name of the app"+ , [ parser stringParser+ , aliasIs ["u"]+ ]+ )+userAge = make ("age", "the age of the user", [parser intParser])++flagData = combine [flagToData userName, flagToData userAge]++main :: IO ()+main = processMain "Simple example for HsOptions."+ flagData+ success+ failure+ defaultDisplayHelp++success :: ProcessResults -> IO ()+success (flags, args) = do let nextAge = (flags `get` userAge) + 5+ putStrLn ("Hello " ++ flags `get` userName)+ putStrLn ("In 5 years you will be " +++ show nextAge +++ " years old!")++failure :: [FlagError] -> IO ()+failure errs = do putStrLn "Some errors occurred:"+ mapM_ print errs+
+ hsoptions.cabal view
@@ -0,0 +1,156 @@+name: hsoptions+version: 1.0.0.0+cabal-version: >= 1.18+synopsis: Haskell library that supports command-line flag processing+description:+ Haskell library that supports command-line flag processing.+ .+ Too see an user guide and list of features go to+ <https://github.com/josercruz01/hsoptions#table-of-contents>.+ .+ Flags are declared in the code by using the 'make' function, which takes the+ flag's name, help text and type as arguments.+ .+ The flags are parsed from the command line stream of from a file+ if the @--usingFile \<filename\>@ flag is sent to the program.+ .+ Flags can be customized by calling configuration function, such as+ 'defaultIs' or 'aliasIs', that change how the flag behaves, how it+ is parsed and validated.+ .+ The 'processMain' function needs to be called at the beginning of the 'main'+ function. This function takes as arguments:+ .+ * The @program description@+ .+ * A list of @all declared flags@+ .+ * Three callbacks:+ .+ * * @success@+ .+ * * @failure@+ .+ * * @display help@+ .+ If there is any kind of validation error @failure@ is+ called with the list of errors. If the @--help@ flag was sent by the user+ @display help@ is called. Otherwise if there are no problems the @success@+ function is called.+ .+ A default implementation of @failure@ and @display help@ is provided in the+ library ('defaultDisplayHelp', 'defaultDisplayErrors') with a basic bahavior.+ .+ Basically @success@ becomes the \'real\' main function. It takes as argument+ a tuple ('FlagResults', 'ArgsResults'). 'FlagResults' is a data structure+ that can be used to query flags by using the 'get' function. 'ArgsResults' is+ just an array of 'String' containing the remaining not-flag arguments.+ .+ A simple example (more in+ <https://github.com/josercruz01/hsoptions/tree/master/examples>)+ .+ > import System.Console.HsOptions+ >+ > userName = make ( "user_name",+ > , "the user name of the app",+ > , [ parser stringParser,+ > , aliasIs ["u"]+ > ]+ > )+ > userAge = make ("age", "the age of the user", [parser intParser])+ >+ > flagData = combine [flagToData userName, flagToData userAge]+ >+ > main :: IO ()+ > main = processMain "Simple example for HsOptions."+ > flagData+ > success+ > failure+ > defaultDisplayHelp+ >+ > success :: ProcessResults -> IO ()+ > success (flags, args) = do let nextAge = (flags `get` userAge) + 5+ > putStrLn ("Hello " ++ flags `get` userName)+ > putStrLn ("In 5 years you will be " +++ > show nextAge +++ > " years old!")+ >+ > failure :: [FlagError] -> IO ()+ > failure errs = do putStrLn "Some errors occurred:"+ > mapM_ print errs+ .+ At the 'processMain' function each of the input flags is validated against the+ declared flags. Within the @success@ function you can be sure that all required+ flags exist, all flag types are correct and all validation was successful.++homepage: https://github.com/josercruz01/hsoptions+license: Apache-2.0+license-file: LICENSE+author: Jose Raymundo Cruz+maintainer: jose.r.cruz01@gmail.com+copyright: (c) Jose Raymundo Cruz (jose.r.cruz01@gmail.com)+category: System+build-type: Simple+cabal-version: >=1.8+extra-source-files: README.md+source-repository head+ type: git+ location: https://github.com/josercruz01/hsoptions++library+ exposed-modules:+ System.Console.HsOptions+ System.Console.HsOptions.Parser+ System.Console.HsOptions.ParserCore+ System.Console.HsOptions.Types+ System.Console.HsOptions.Core+ -- other-modules:+ build-depends: base == 4.6.*,+ containers == 0.5.*,+ parsec == 3.1.*,+ regex-posix == 0.95.*,+ regex-compat == 0.95.*,+ directory == 1.2.*+ hs-source-dirs: src+ ghc-options: -Wall++test-suite unit-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests/unit, src+ main-is: MainTestSuite.hs+ ghc-options: -Wall+ other-modules: UnitTestHelper, + System.Console.HsOptionsTestHelpers+ build-depends: base == 4.6.*,+ hsoptions,+ containers == 0.5.*,+ parsec == 3.1.*,+ directory == 1.2.*,+ regex-posix == 0.95.*,+ regex-compat == 0.95.*,+ HUnit >=1.2 && <2,+ QuickCheck >=2.4 && <=2.7,+ test-framework == 0.8.*,+ test-framework-hunit == 0.3.*,+ test-framework-quickcheck2 == 0.3.*++-- Example programs+executable SimpleFlag+ main-is: SimpleFlag.hs+ hs-source-dirs: examples+ build-depends: base == 4.6.*,+ hsoptions++executable ComplexFlag+ main-is: ComplexFlag.hs+ hs-source-dirs: examples+ ghc-options: -Wall+ build-depends: base == 4.6.*,+ hsoptions++executable DependentDefaultsDemo+ main-is: DependentDefaultsDemo.hs+ hs-source-dirs: examples+ ghc-options: -Wall+ build-depends: base == 4.6.*,+ hsoptions
+ src/System/Console/HsOptions.hs view
@@ -0,0 +1,177 @@+{- |+Module : System.Console.HsOptions+Description : Command line flag parser for Haskell+Copyright : (c) Jose Raymundo Cruz (jose.r.cruz01@gmail.com)+License : Apache-2.0++Maintainer : Jose Raymundo Cruz (jose.r.cruz01@gmail.com)+Stability : stable+Portability : portable++HsOptions library supports command line flag parsing.++Too see an user guide and list of features go to+<https://github.com/josercruz01/hsoptions#table-of-contents>.++Flags are declared in the code by using the 'make' function, which takes the+flag's name, help text and type as arguments.++The flags are parsed from the command line stream of from a configuration file+if the @--usingFile \<filename\>@ flag is sent to the program.++A configuration file is just a text document that defines command line+arguments for our program in the standard command line syntax. This is a+simple configuration file example that defines two flags and three+positional arguments and also includes a second configuration file:++@+ # confFile1.txt+--user_id = 8+--user_name = batman+--usingFile /tmp/localConfiguration.txt+arg1+arg2+arg3+@++So doing this:++>>> runhaskell Prog.hs --usingFile confFile1.txt++Is equivalent to doing this++>>> runhaskell Prog.hs --user_id = 8 --user_name = batman ... arg2 arg3++Flags can be customized by calling configuration function, such as+'defaultIs' or 'aliasIs', that change how the flag behaves, how it+is parsed and validated.++The 'processMain' function needs to be called at the beginning of the 'main'+function. This function takes as arguments:++ * The @program description@++ * A list of @all declared flags@++ * Success callback function++ * Failure callback function++ * Display-Help callback function++If there is any kind of validation error @failure@ is+called with the list of errors. If the @--help@ flag was sent by the user+@display help@ is called. Otherwise if there are no problems the @success@+function is called.++A default implementation of @failure@ and @display help@ is provided in the+library ('defaultDisplayHelp', 'defaultDisplayErrors') with a basic behavior.++Basically, @success@ becomes the \'real\' main function. It takes as argument+a tuple ('FlagResults', 'ArgsResults'). 'FlagResults' is a data structure+that can be used to query flags by using the 'get' function. 'ArgsResults' is+just an array of 'String' containing the remaining not-flag arguments.++A simple example (more in+<https://github.com/josercruz01/hsoptions/tree/master/examples>)++> import System.Console.HsOptions+>+> userName = make ( "user_name",+> , "the user name of the app",+> , [ parser stringParser,+> , aliasIs ["u"]+> ]+> )+> userAge = make ("age", "the age of the user", [parser intParser])+>+> flagData = combine [flagToData userName, flagToData userAge]+>+> main :: IO ()+> main = processMain "Simple example for HsOptions."+> flagData+> success+> failure+> defaultDisplayHelp+>+> success :: ProcessResults -> IO ()+> success (flags, args) = do let nextAge = (flags `get` userAge) + 5+> putStrLn ("Hello " ++ flags `get` userName)+> putStrLn ("In 5 years you will be " +++> show nextAge +++> " years old!")+>+> failure :: [FlagError] -> IO ()+> failure errs = do putStrLn "Some errors occurred:"+> mapM_ print errs++At the 'processMain' function each of the input flags is validated against the+declared flags. Within the @success@ function you can be sure that all required+flags exist, all flag types are correct and all validation was successful.+-}+module System.Console.HsOptions(+ -- * Definition of flags+ make,++ -- * Query flag values+ get,++ -- * Process flags+ processMain,+ process,+ process',+ flagToData,+ combine,++ -- * Default functions+ defaultDisplayHelp,+ defaultDisplayErrors,++ -- * Flag configurations+ parser,+ maybeParser,+ isOptional,+ emptyValueIs,+ defaultIs,+ defaultIf,+ aliasIs,+ requiredIf,++ -- * Flag parsers #parsers#+ intParser,+ floatParser,+ doubleParser,+ charParser,+ stringParser,+ boolParser,+ arrayParser,+ boolFlag,+ toMaybeParser,++ -- * Global validation+ validate,++ -- * Flag operations+ operation,+ assign,+ append,+ append',+ prepend,+ prepend',++ -- * Data types+ Flag,+ FlagData,+ FlagError(..),+ FlagResults,+ FlagArgument(..),+ GlobalRule,+ ProcessResults,+ ArgsResults,+ FlagConf,+) where++import System.Console.HsOptions.Types+import System.Console.HsOptions.Core++{-# ANN module "HLint: ignore Use camelCase" #-}
+ src/System/Console/HsOptions/Core.hs view
@@ -0,0 +1,2093 @@+{- |+Module : System.Console.HsOptions.Core+Description : Core HsOptions source+Copyright : (c) Jose Raymundo Cruz (jose.r.cruz01@gmail.com)+License : Apache-2.0++Maintainer : Jose Raymundo Cruz (jose.r.cruz01@gmail.com)+Stability : stable+Portability : portable++Core HsOptions library source.+-}+module System.Console.HsOptions.Core+where++import Control.Exception+import Control.Monad+import Data.List+import Data.Maybe+import System.Console.HsOptions.Parser+import System.Directory+import System.Environment+import Text.Read(readMaybe)+import Text.Regex+import Text.Regex.Posix++import qualified Data.Map as Map+import qualified System.Console.GetOpt as Opt+import System.Console.HsOptions.Types++-- | Takes a flag's name and an error message and builds a proper error+-- for the flag.+--+-- Arguments:+--+-- * @flag_name@: the name of the flag+--+-- * @error@: the error message+--+-- Returns:+--+-- * A pretty error message for the flag name.+flagError :: String -> String -> String+flagError name msg = "Error with flag '--" ++ name ++ "': " ++ msg++-- | The keyword for the @usingFile@ flag and its aliases.+--+-- This flag is used to include a configuration text file for flag parsing.+usingFileKw :: (String, [String])+usingFileKw = ("usingFile", [])++-- | The keyword for the @help@ flag and its aliases.+--+-- When the user pass in this flag the @display error@ function is called.+helpKw :: (String, [String])+helpKw = ("help", ["h"])++-- | The keyword for the @inherit@ feature.+--+-- This keyword allows the user to set a flag's value based on it's previous+-- value.+inheritKw :: String+inheritKw = "$(inherit)"++-- | Regex used to match the 'inheritKw'.+inheritRegex :: String+inheritRegex = "\\$\\(inherit\\)"++-- | Holds all words that are reserved on by the library and cannot be used+-- as flag names.+reservedWords :: [String]+reservedWords = uncurry (:) usingFileKw+ ++ uncurry (:) helpKw++-- | Creates a flag configuration that makes the flag as optional.+--+-- Since the flag is optional then it's type must+-- bet @'Flag' ('Maybe' a)@, so that it can be 'Nothing' if the flag was not+-- provided by the user or @'Just' value@ if it was provided.+--+-- Returns:+--+-- * A flag configuration that marks the flag as optional.+-- This method is a specification of the 'requiredIf' method. Is is+-- equivalent to:+--+-- >>> requiredIf (const False)+isOptional :: FlagConf (Maybe a)+isOptional = requiredIf (const False)++-- | Creates a flag configuration that defines the default value when the flag+-- is empty.+--+-- Sets the value a flag should take if it is the case that this flag was+-- provided by the user but not it's value (@i.e. runhaskell Program.hs+-- --user_id@).+--+-- Arguments:+--+-- * @empty_value@: the value to use if the flag value is empty.+--+-- Returns:+--+-- * A flag configuration that sets the flag's empty value.+emptyValueIs :: a -> FlagConf a+emptyValueIs = FlagConf_EmptyValueIs++-- | Creates a flag configuration that sets sets the default value for a flag+-- if the flag is not provided by the user.+--+-- Arguments:+--+-- * @default value@: the default value of the flag.+--+-- Returns:+--+-- * A flag configuration that sets the flag's default value.+-- This method is a specification of the 'defaultIs' method. Is is+-- equivalent to:+--+-- >>> defaultIf a (const True)+defaultIs :: a -> FlagConf a+defaultIs a = defaultIf (const $ Just a)++-- | Creates a flag configuration that sets a dependent default value for a+-- flag.+--+-- This configuration requires a function that takes in a `FlagResults` as+-- argument and returns a `Maybe a` value, `Nothing` says that there is no+-- default value and `Just something` says that there is a default value.+--+-- Arguments:+--+-- *@default_getter@: function that given a `FlagResults` returns the+-- default value (`Just`) or `Nothing` if no default value exist;+--+-- Returns:+--+-- * A flag configuration that sets the dependent default value for the+-- flag.+defaultIf :: (FlagResults -> Maybe a) -> FlagConf a+defaultIf = FlagConf_DefaultIf++-- | Creates a flag configuration for the aliases of the flag.+--+-- Sets multiple alias for a single flag. @(i.e. --user_id alias:+-- [\"u\", \"uid\",\"user_identifier\"])@. These aliases can be used to set+-- the flag value, so @--user_id = 8@ is equivalent to @-u = 8@.+--+-- Arguments:+--+-- *@aliases@: the alias list for the flag.+--+-- Returns:+--+-- * A flag configuration that sets the aliases for a given flag.+aliasIs :: [String] -> FlagConf a+aliasIs = FlagConf_Alias++-- | Creates a flag configuration that marks a flag as conditionally required.+--+-- The flag will be required from the user if the @condition@ returns 'True'+-- and the user does not provides the flag in the input stream, a \"flag is+-- required\" error is displayed in this scenario.+--+-- The flag type must be @'Maybe' a@, if the @condition@ returns 'False' and+-- the flag is not provided then it's value is 'Nothing'. On the other hand+-- if the flag is provided it's value will be @'Just' value@.+--+-- Arguments:+--+-- *@condition@: the condition to determine if the flag is required.+--+-- Returns:+--+-- * A flag configuration that sets the conditional flag required+-- constraint.+requiredIf :: (FlagResults -> Bool) -> FlagConf (Maybe a)+requiredIf = FlagConf_RequiredIf++-- | Sets the flag's parser configuration.+--+-- It takes the function that will parse the string input to the corresponding+-- flag type value. A set of this functions, such as 'intParser', was created+-- to provide a basic set of parsers.+--+-- Arguments:+--+-- *@parser_function@: a function that takes a flag argument and returns+-- 'Nothing' if the argument can not be parsed or the parsed value ('Just')+-- if the argument can be parsed correctly.+--+-- Returns:+--+-- * A flag configuration that defines how to parse the string input.+parser :: (FlagArgument -> Maybe a) -> FlagConf a+parser = FlagConf_Parser++-- | Combination of the 'parser' and 'toMaybeParser' for syntactic sugar since+-- this is a very common scenario.+--+-- Basically is defined as:+--+-- > maybeParser = parser . toMaybeParser+--+-- So instead of always doing:+--+-- >>> user_id = make ("user_id", "help", [parser $ toMaybeParser intParser])+--+-- You can do:+--+-- >>> user_id = make ("user_id", "help", [maybePaser intParser])+--+-- Arguments:+--+-- *@parser_function@: parser function that defines how to parse the+-- string input to the flag's value.+--+-- Returns:+--+-- * A flag configuration that sets how to parse the string input.+maybeParser :: (FlagArgument -> Maybe a) -> FlagConf (Maybe a)+maybeParser = parser . toMaybeParser++-- | Creates a flag configuration for the default operation of the flag.+--+-- Defines the default operation for the flag if no operation is made+-- explicit by the user. If this method is not called then the default+-- operation is always 'assign'.+--+-- >>> runhaskell Program.hs --user_name += batman+-- Operation was explicit: Operation = "Append operation"+--+-- >>> runhaskell Program.hs --user_name batman+-- Operation not specified: Operation = @default_operation@+--+-- Arguments:+--+-- *@default_operation@: operation to use if no operation is provided for+-- the flag in the input stream.+--+-- Returns:+--+-- * A flag configuration that sets the default operation of the flag.+operation :: OperationToken -> FlagConf a+operation = FlagConf_DefaultOperation++-- | Append operation (+=). One of the available flag operations.+--+-- The flag value is appended with it's previous value using a space in+-- between values. It is used as the argument of 'operation' function:+--+-- >>> operation append+-- Sets the default operation for the flag to append+--+-- Returns:+--+-- * Append flag operation.+append :: OperationToken+append = OperationTokenAppend++-- | Append\' operation (+=!). One of the available flag operations.+--+-- Same as 'append' but appends with no space in between. It is used as+-- the argument of 'operation' function:+--+-- >>> operation append'+-- Sets the default operation for the flag to append'+--+-- Returns:+--+-- * Append\' flag operation.+append' :: OperationToken+append' = OperationTokenAppend'++-- | Prepend operation (=+). One of the available flag operations.+--+-- The flag value is prepended with it's previous value using a space in+-- between values. It is used as the argument of 'operation' function:+--+-- >>> operation prepend+-- Sets the default operation for the flag to prepend+--+-- Returns:+--+-- * Prepend flag operation.+prepend :: OperationToken+prepend = OperationTokenPrepend++-- | Prepend\' operation (=+!). One of the available flag operations.+--+-- Same as 'prepend' but appends with no space in between. It is used as+-- the argument of 'operation' function:+--+-- >>> operation prepend'+-- Sets the default operation for the flag to prepend'+--+-- Returns:+--+-- * Prepend\' flag operation.+prepend' :: OperationToken+prepend' = OperationTokenPrepend'++-- | Assign operation (=). Default flag operation if no operation is set.+--+-- Sets the flag value to the current value, overwriting any previous value+-- the flag may have.+--+-- >>> operation assign+-- Sets the default operation for the flag to assign+--+-- Returns:+--+-- * Assign flag operation.+assign :: OperationToken+assign = OperationTokenAssign++-- | Wraps a parser function that takes a 'FlagArgument' and returns a+-- \"@'Maybe' a@\" and converts it to a function that returns a+-- \"@'Maybe' ('Maybe' a)@\".+--+-- This new function does will never fail if the argument is missing or+-- if the argument value is missing ('FlagMissing' or 'FlagValueMissing'),+-- instead this function maps any of these two to a 'Nothing' value.+--+-- If the flag argument is of type 'FlagValue' then the original parser+-- is used.+--+-- It is a convenient way to reuse current parsers, like 'intParser', without+-- having to redefine them. For instance \"'intParser'\" is of type+-- @'FlagArgument' -> ('Maybe' 'Int')@, but \"@toMaybeParser intParser@\" is of+-- type @'FlagArgument' -> ('Maybe' ('Maybe' 'Int'))@.+--+-- Usage example:+--+-- > user_id :: Flag (Maybe Int)+-- > user_id = make ("user_id", "help", [parser (toMaybeParser intParser)])+--+-- As you can observe @intParser@ was reused.+--+-- Arguments:+--+-- *@original_parser@: the original parser to be wrapped.+--+-- Returns:+--+-- * A new parser that changes the result type to an optional type.+toMaybeParser :: (FlagArgument -> Maybe a)+ -> FlagArgument+ -> Maybe (Maybe a)+toMaybeParser p arg = case arg of+ FlagMissing _ -> Just Nothing+ FlagValueMissing _ -> Just Nothing+ flagValue -> case p flagValue of+ Nothing -> Nothing+ val -> Just val++-- | Method to get a flag value out of a 'FlagResults'.+--+-- This is the method used to get the proper value for each flag after the+-- input stream has been processed. The 'processMain' method will create the+-- 'FlagResults' data structure for a set of defined flags.+--+-- This is an example on how to use this method:+--+-- > user_id :: Flag Int+-- > user_id = make ("user_id", "help", [parser intParser]+-- >+-- > main_success :: (FlagResults, ArgsResults) -> IO ()+-- > main_success (flags, _) = putStrLn ("Next user id: " +++-- > show ((get flags user_id) + 1)))+--+-- Arguments:+--+-- *@flag_results@: the 'FlagResults' created from the input stream.+--+-- Returns:+--+-- * The value of the given flag.+--+-- Throws:+--+-- * An exception is raised if flag does not exist in the 'FlagResults'.+-- At this point, the 'get' method should always succeed parsing a flag+-- value. If the flag is not found then that means that the flag was not+-- processed by the parser, possibly because the flag was not added to the+-- 'FlagData' sent to the processor.+get :: FlagResults -> Flag a -> a+get result (Flag name _ conf) = fromJust $ runParser result conf value+ where value = fromMaybe (error fatalError) $ Map.lookup name result+ fatalError = "Error while trying to get flag value for '" ++ name+ ++ "'. Flag was not added to the flagData array"++-- | Finds the default value from a flag's list of configurations if the+-- default value was configured for the flag.+--+-- If a dependent default value was configured for the flag then it is matched+-- agains the @flag_results@, if the match returns 'True' then the default+-- value is returned, otherwise 'Nothing' is returned.+--+-- Arguments:+--+-- *@flag_results@: the current 'FlagResults'.+--+-- *@configurations@: the list of configurations for the flag.+--+-- Returns:+--+-- * Nothing: if there is no dependent default configuration.+--+-- * Nothing: if the depedent default configuration predicate returns+-- 'False'+--+-- * Just @defaultValue@: if the dependent default configuration predicate+-- returns 'True'+flagDefault :: FlagResults -> [FlagConf a] -> Maybe a+flagDefault fr fc = fromMaybe Nothing result+ where result = listToMaybe [ p fr | (FlagConf_DefaultIf p) <- fc]++-- | Returns the list of flag alias configured for the flag.+--+-- Arguments:+--+-- *@configurations@: the list of configurations for the flag.+--+-- Returns:+--+-- * A list of all the flag alias configured for the flag.+flagAlias :: [FlagConf a] -> [String]+flagAlias fc = concat [ x | (FlagConf_Alias x) <- fc]++-- | Returns the list of flag alias configured for the flag.+--+-- Similar to 'flagAlias' but for 'FlagDataConf' instead.+--+-- Arguments:+--+-- *@configurations@: the list of configurations for the flag.+--+-- Returns:+--+-- * A list of all the flag alias configured for the flag.+flagDAlias :: [FlagDataConf] -> [String]+flagDAlias fc = concat [ x | (FlagDataConf_Alias x) <- fc]++-- | Finds the default operation for the flag.+--+-- If the default operation is not found the the 'assign' operation is used+-- as the default.+--+-- Arguments:+--+-- *@configurations@: the list of configurations for the flag.+--+-- Returns:+--+-- * The default operation for the flag.+flagDDefaultOperation :: [FlagDataConf] -> OperationToken+flagDDefaultOperation fc =+ case [ x | (FlagDataConf_DefaultOperation x) <- fc] of+ [] -> OperationTokenAssign+ res -> head res++-- | Finds the value to use if the flag value is empty.+--+-- Arguments:+--+-- *@configurations@: the list of configurations for the flag.+--+-- Returns:+--+-- * Nothing: if there is no empty value configured for the flag+-- * Just value: if the empty value is found.+flagEmptyValue :: [FlagConf a] -> Maybe a+flagEmptyValue fc = listToMaybe [ x | (FlagConf_EmptyValueIs x) <- fc]++-- | Finds the parser for the flags and runs it against the flag argument.+--+-- Arguments:+--+-- *@configurations@: the list of configurations for the flag.+--+-- *@flag_argument@: the argument of the flag.+--+-- Returns:+--+-- * The parsed value of the @flag_argument@ by using the original flag+-- parser+--+-- Throws:+--+-- * An exception if no parser is found. This method depend on previous+-- validation that the parser was configured for the flag.+runRealParser :: [FlagConf a] -> FlagArgument -> Maybe a+runRealParser flagconf = head [x | (FlagConf_Parser x) <- flagconf]++-- | Runs the parser for the flag depending on the type of 'FlagArgument'.+--+-- Takes into considerations scenarios where the flag argument is missing but+-- the user defined a default value for the flag or if the flag argument is+-- empty and the user defined an empty value for the flag.+--+-- Arguments:+--+-- *@flag_results@: the current 'FlagResults'.+--+-- *@configurations@: the list of configurations for the flag.+--+-- *@flag_argument@: the argument of the flag.+--+-- Returns:+--+-- * The default value for the flag: if a default value was configured and+-- the flag argument is 'FlagMissing'.+--+-- * The empty value for the flag: if an empty value was configured and+-- the flag argument is 'FlagValueMissing'+--+-- * Otherwise: The result of the real parser configured for the flag.+runParser :: FlagResults -> [FlagConf a] -> FlagArgument -> Maybe a+runParser fr fc arg@(FlagMissing _) = case flagDefault fr fc of+ Nothing -> runRealParser fc arg+ Just val -> Just val+runParser _ fc arg@(FlagValueMissing _) = case flagEmptyValue fc of+ Nothing -> runRealParser fc arg+ Just val -> Just val+runParser _ fc arg = runRealParser fc arg++-- | Takes a list of 'FlagData' and combines them together into a single+-- 'FlagData'.+--+-- Validates that a flag name is not repeated in the incoming list of+-- flag data.+--+-- Usage example:+--+-- > flagData = combine [ flagToData user_id+-- > , flagToData user_name,+-- > , flagToData database+-- > ]+--+-- Arguments:+--+-- * @flag_data_list@: list of flag data to combine.+--+-- Returns:+--+-- * A combined 'FlagData' result+--+-- Throws:+--+-- * An exception if any two flag names are duplicated in the input+-- @flag_data_list@.+combine :: [FlagData] -> FlagData+combine = foldl combine' (Map.empty, Map.empty, [])+ where combine' (m1, a1, gr1) (m2, a2, gr2) =+ case duplicates (m1, a1) (m2, a2) of+ [] -> (m1 `Map.union` m2, a1 `Map.union` a2, gr1 ++ gr2)+ flags -> error ( "Duplicate flag names: The following flag "+ ++ "names are duplicated in the code "+ ++ show flags)++ allKeys (m1, m2)= Map.keys m1 ++ Map.keys m2+ duplicates (m1, a1) (m2, a2) = allKeys (m1, a1) `intersect`+ allKeys (m2, a2)++-- | Constructs a 'FlagData' out of a 'GlobalRule'.+--+-- This global rule will be used in the last validation stage of the+-- 'process' method.+--+-- Usage example:+--+-- > flagData = combine [ flagToData user_id+-- > , validate (\fr -> if get fr user_id < 0+-- > then Just "user id negative error"+-- > else Nothing)+-- > ]+--+-- Multiple validation rules can exist.+--+-- Arguments:+--+-- *@global_rule@: global validation rule+--+-- Returns:+--+-- * A 'FlagData' representation of the @global_rule@.+validate :: GlobalRule -> FlagData+validate rule = (Map.empty, Map.empty, [rule])++-- | Converts a 'Flag' to a 'FlagData'.+--+-- 'FlagData' is the general form of the flag that is not bounded by the+-- type @\"a\"@ of the @\"'Flag' a\"@ input, thus it can be added to a+-- collection of flags later.+--+-- Arguments:+--+-- *@flag@: the flag to be mapped.+--+-- Returns:+--+-- * A corresponding 'FlagData' for the flag.+flagToData :: Flag a -> FlagData+flagToData (Flag name help flagConf) = (flagData, aliasMap, [])+ where flagData = Map.singleton name (help, flagDConf)+ aliasMap = Map.fromList [(s, name) | s <- flagAlias flagConf]+ flagDConf = map fConfToFDataConf flagConf++-- | Maps a @'FlagConf' a@ to a 'FlagDataConf' data type.+--+-- Arguments:+--+-- *@flag_conf@: the flag configuration to be mapped to a 'FlagDataConf'.+--+-- Returns:+--+-- * A corresponding 'FlagDataConf' mapped from the input.+fConfToFDataConf :: FlagConf a -> FlagDataConf+fConfToFDataConf conf = case conf of+ (FlagConf_DefaultIf p) -> FlagDataConf_HasDefault (isJust . p)+ (FlagConf_RequiredIf p) -> FlagDataConf_RequiredIf p+ (FlagConf_EmptyValueIs _) -> FlagDataConf_HasEmptyValue+ (FlagConf_Parser p) -> FlagDataConf_Validator (isJust . p)+ (FlagConf_Alias as) -> FlagDataConf_Alias as+ (FlagConf_DefaultOperation op) -> FlagDataConf_DefaultOperation op++-- | Checks if a flag is invalid.+--+-- Among the validation rules checks that the file name follows the correct+-- convention, as well as all the flag\'s aliases.+--+-- Arguments:+--+-- *@(flag_name, flag_configuration)@: the data of the flag required to+-- validate it.+--+-- Returns:+--+-- * 'Nothing' if the flag is valid.+--+-- * An error message ('Just') if the flag failed.+invalidFlag :: (String, [FlagConf a]) -> Maybe String+invalidFlag (n, fc) = case invalidFlags of+ [] -> Nothing+ flags -> Just $ "Error: The following flags names are invalid "+ ++ show flags+ ++ ". A valid flag name consist of a letter followed "+ ++ " by letters, numbers, dash or undercore."+ where invalidFlags = [x | x <- n:flagAlias fc, invalidFlagName x]++-- | Returns 'True' if the flag name is value, 'False' otherwise.+--+-- Enforces the convention for the flag name: \"@Letter@ followed by many @(+-- Letters - Numbers - Dashes (-) - Underscores (_) )@.+--+-- Arguments:+--+-- *@flag_name@: the name of the flag.+--+-- Returns:+--+-- * 'True' if the flag name follows the convention, 'False' otherwise.+invalidFlagName :: String -> Bool+invalidFlagName s = not (s =~ "^[a-zA-Z][a-zA-Z0-9\\-_]*$" :: Bool)++-- | Maps a flag alias to the real flag name.+--+-- For example if the flag @--user_id@ has the @-uid@ alias configured in the+-- @flag_alias_map@ then:+--+-- >>> mapAlias flag_alias_map "uid"+-- will return "user_id"+--+-- If the alias is not found in the @flag_alias_map@ then the @flag_alias@+-- argument is returned unmodified.+--+-- Arguments:+--+-- *@flag_alias_map@: the map of flag alias to flag name.+--+-- *@flag_alias@: the alias to be mapped to the real flag name.+--+-- Returns:+--+-- * The real flag name for the @flag_alias@ if found or the same argument+-- unmodified if not found.+mapAlias :: FlagAliasMap -> String -> String+mapAlias aliasMap name = fromMaybe name $ Map.lookup name aliasMap++-- | Replaces the @sub_string@ with the @replacement_string@ in the input+-- @input_string@.+--+-- >>> replaceStr "One two three@" ("two", "four")+-- "One four three"+--+-- Arguments:+--+-- *@input_string@: the string to be searched.+--+-- *@sub_string@: the string to be replaced in the @input_string@.+--+-- *@replacement_string@: the string to be used as a replacement of+-- @sub_string@.+--+-- Returns:+--+-- * The @input_string@ with any @sub_string@ replaced for+-- @replacement_string@.+replaceStr :: String -> (String, String) -> String+replaceStr str (pattern, repl) = subRegex (mkRegex pattern) str repl++-- | Creates the flag argument from the parser results for a given flag based+-- on the operation performed on the flag.+--+-- Maps the flag opereration to the respective method that will produce the+-- flag value, such as 'execAppend' (that produces the flag value by+-- appending the current value with the previous value).+--+-- Arguments:+--+-- *@parse_results@: the current state of the parse process.+--+-- *@(flag_name, operation, flag_value)@: flag and flag value information,+-- as well as the operation being performed to the flag.+--+-- Returns:+--+-- * A flag argument containing the final value for the flag after the+-- operation was performed.+executeOp :: ParseResults+ -> (String, OperationToken, FlagValueToken)+ -> FlagArgument+executeOp st (name, op, val) = case op of+ OperationTokenAssign -> execAssign st (name, val)+ OperationTokenAppend -> execAppend st (name, val)+ OperationTokenAppend' -> execAppend' st (name, val)+ OperationTokenPrepend -> execPrepend st (name, val)+ OperationTokenPrepend' -> execPrepend' st (name, val)++-- | Performs the assign flag operation.+--+-- Assigns the current value to the flag disregarding any previous state of+-- the flag.+--+-- Arguments:+--+-- *@parse_results@: the current state of the parse process.+--+-- *@(flag_name, flag_value)@: name and value of the current operation.+--+-- Returns:+--+-- * 'FlagValue' if the flag is being assigned to a not empty value,+-- 'FlagValueMissing' otherwise.+execAssign :: ParseResults -> (String, FlagValueToken) -> FlagArgument+execAssign _ (name, val) = case val of+ FlagValueTokenEmpty -> FlagValueMissing name+ (FlagValueToken value) -> FlagValue name value++-- | Performs the append flag operation.+--+-- Appends the current value of the flag to the previous value of the flag.+-- A space is used as a separator between the two values.+--+-- If the current value for the flag is empty then the previous value is+-- taken as the new flag value.+--+-- Arguments:+--+-- *@parse_results@: the current state of the parse process.+--+-- *@(flag_name, flag_value)@: name and value of the current operation.+--+-- Returns:+--+-- * The current value of the flag appended to the previous value of the+-- flag using a space as separator.+execAppend :: ParseResults -> (String, FlagValueToken) -> FlagArgument+execAppend (fr, _) (name, val) = case val of+ FlagValueTokenEmpty -> previousOrEmpty fr name+ (FlagValueToken value) -> FlagValue name (inheritKw ++ prefix ++ value)+ where prefix = if isJust $ Map.lookup name fr then " " else ""++-- | Performs the append' flag operation.+--+-- Similar to 'append' but does not use a space as separator.+--+-- If the current value for the flag is empty then the previous value is+-- taken as the new flag value.+--+-- Arguments:+--+-- *@parse_results@: the current state of the parse process.+--+-- *@(flag_name, flag_value)@: name and value of the current operation.+--+-- Returns:+--+-- * The current value of the flag appended to the previous value of the+-- flag without using any in between separator.+execAppend' :: ParseResults -> (String, FlagValueToken) -> FlagArgument+execAppend' (fr, _) (name, val) = case val of+ FlagValueTokenEmpty -> previousOrEmpty fr name+ (FlagValueToken value) -> FlagValue name (inheritKw ++ value)++-- | Performs the prepend flag operation.+--+-- Prepends the current value of the flag to the previous value of the flag.+-- A space is used as a separator between the two values.+--+-- If the current value for the flag is empty then the previous value is+-- taken as the new flag value.+--+-- Arguments:+--+-- *@parse_results@: the current state of the parse process.+--+-- *@(flag_name, flag_value)@: name and value of the current operation.+--+-- Returns:+--+-- * The current value of the flag prepended to the previous value of the+-- flag using a space as separator.+execPrepend :: ParseResults -> (String, FlagValueToken) -> FlagArgument+execPrepend (fr, _) (name, val) = case val of+ FlagValueTokenEmpty -> previousOrEmpty fr name+ (FlagValueToken value) -> FlagValue name (value ++ prefix ++ inheritKw)+ where prefix = if isJust $ Map.lookup name fr then " " else ""++-- | Performs the prepend' flag operation.+--+-- Similar to 'prepend' but does not use a space as separator.+--+-- If the current value for the flag is empty then the previous value is+-- taken as the new flag value.+--+-- Arguments:+--+-- *@parse_results@: the current state of the parse process.+--+-- *@(flag_name, flag_value)@: name and value of the current operation.+--+-- Returns:+--+-- * The current value of the flag prepend to the previous value of the+-- flag without using any in between separator.+execPrepend' :: ParseResults -> (String, FlagValueToken) -> FlagArgument+execPrepend' (fr, _) (name, val) = case val of+ FlagValueTokenEmpty -> previousOrEmpty fr name+ (FlagValueToken value) -> FlagValue name (value ++ inheritKw)++-- | Tries to find the previous result of a flag in the 'FlagResults'.+--+-- Arguments:+--+-- *@parse_results@: the current parsed flags.+--+-- *@flag_name@: flag name used to find the flag\'s value.+--+-- Returns:+--+-- * The value of the flag inside the @parse_results@ if it exists or+-- 'FlagValueMissing' otherwise.+previousOrEmpty :: FlagResults -> String -> FlagArgument+previousOrEmpty fr name = fromMaybe (FlagValueMissing name)+ (Map.lookup name fr)++-- | Checks if the value for the flag includes the $(inherit) keyword and+-- replaces this keyword by the previous value of the flag.+--+-- It is a generalization of the append or prepend features, you can insert+-- the previous value of the flag in any position of the new value.+--+-- For example, if the previous flag value was @\"batman\"@ and the new value+-- was @\"a-$(inherit)-z\"@ then the new value will be expanded to+-- @\"a-batman-z\"@.+--+-- Arguments:+--+-- *@parse_results@: the current parsed flags.+--+-- *@argument@: the value of the flag.+--+-- Returns:+--+-- * A new flag value by expanding any $(inherit) keyword with the previous+-- value of the flag.+applyInherit :: ParseResults -> FlagArgument -> FlagArgument+applyInherit (fr, _) arg = case arg of+ (FlagMissing _) -> arg+ (FlagValueMissing _) -> arg+ (FlagValue name value0) -> FlagValue name value1+ where value1 = value0 `replaceStr` (inheritRegex, previous)+ previous = case Map.lookup name fr of+ Just (FlagValue _ v) -> v+ _ -> ""++-- | Takes a 'Token' and produces a 'ParseResults'.+--+-- 'ParseResults' contains the final result of the flag after being analysed.+--+-- If the token is an 'ArgToken' then it is mapped unmodified to a+-- 'ParseResults'. If the token is a 'FlagToken' then the flag operation is+-- performed and the inherit keyword is expanded, then a 'ParseResults' is+-- created with this final flag value.+--+-- Arguments:+--+-- *@(parse_results, token)@: the parse results so far and the current+-- token to parse.+--+-- Returns:+--+-- * A parse results after evaluating the current token.+parseToken :: (ParseResults, Token) -> ParseResults+parseToken (st, tok) = case tok of+ (ArgToken arg) -> (Map.empty, [arg])+ (FlagToken name op value0) -> let value1 = executeOp st (name, op, value0)+ value2 = applyInherit st value1+ in (Map.singleton name value2, [])++-- | Takes a list of tokens, an initial 'ParseResults' and returns a+-- complete merge 'ParsedResults' after parsing each token in order.+--+-- Every token is parsed using the 'parseToken' and it\'s result is+-- continuously merged until all tokens are consumed.+--+-- Arguments:+--+-- *@tokens@: the list of tokens to parse.+--+-- *@initial_parse_result@: the initial state of the parse process.+--+-- Returns:+--+-- * A complete 'ParseResults' after parsing all of the input tokens in+-- order.+parseArgs :: [Token] -> ParseResults -> ParseResults+parseArgs [] st0 = st0+parseArgs (tok:toks) st0 = let st1 = parseToken (st0, tok)+ st2 = mergeSt (st0, st1)+ in parseArgs toks st2+ where mergeSt ((fr1, args1), (fr2, args2)) = ( fr2 `Map.union` fr1+ , args1 ++ args2)++-- | Concatenates two 'TokenizeResult' together.+--+-- If both are errors ('Left') then the errors are concatenated.+--+-- If only one of them is errors ('Left') then that result is returned.+--+-- If non are errors, but tokens ('Right'), then the tokens are concatenated+-- and returned.+--+-- Arguments:+--+-- *@tokenize_result1@: first result.+--+-- *@tokenize_result2@: second result.+--+-- Returns:+--+-- * @tokenize_result1@ concatenated with @tokenize_result2@+concatToks :: TokenizeResult -> TokenizeResult -> TokenizeResult+concatToks (Left errs) (Left errs2) = Left (errs ++ errs2)+concatToks (Left errs) _ = Left errs+concatToks _ (Left errs) = Left errs+concatToks (Right toks1) (Right toks2) = Right $ toks1 ++ toks2++-- | Reads a file from disk and returns the file content or an error.+--+-- Arguments:+--+-- *@filename@: the filename of the file to be opened.+--+-- Returns:+--+-- * Either an exception ('Left') or the file content ('Right').+readFile' :: String -> IO (Either SomeException String)+readFile' name = try $ readFile name :: IO (Either SomeException String)++-- | Parses the content of a configuration file.+--+-- If there is an error reading the file then that error is returned,+-- otherwise the file content is processed and tokenized.+--+-- A preprocessor stage is performed on the content to remove the comments+-- in the text file (comments starts with a hash (#) ).+--+-- Arguments:+--+-- *@(parents, flag_data)@: the parents is the tree of configuraiton file+-- parents of this current configuration file. The flag_data is the+-- information about the flags defined in the code.+--+-- *@configuration_filename@: the path of the configuration file to include.+--+-- Returns:+--+-- * The tokenized version of the content of the configuration file or+-- an error ('Left') if any errors found during the process.+parseConfFile :: ([String], FlagData)+ -> String+ -> IO TokenizeResult+parseConfFile (parents, fd) filename = do+ fileResult <- readFile' filename+ case fileResult of+ Left except -> return $ Left [errorWithFile except]+ Right content -> tokenize (parents, fd) (removeComments content)++ where errorWithFile err = FlagFatalError $ "Error on '"+ ++ filename+ ++ "': "+ ++ show err++-- | Removes all the comments of the @input_text@.+--+-- A comment is a string that begins with hash symbol (#) and ends with a+-- line change (\'\\n\').+--+-- Arguments:+--+-- *@input_text@: the input text.+--+-- Returns:+--+-- * The same input text but with all comments removed.+removeComments :: String -> String+removeComments [] = []+removeComments (c:cs) = if c == '#'+ then removeComments $ dropWhile (/= '\n') cs+ else c:removeComments cs++-- | Checks if the token is the flag @\'--usingFile\'@.+--+-- Arguments:+--+-- *@token@: the token to evaluate.+--+-- Returns:+--+-- * 'Nothing' if the token is not for the @--usingFile@ flag.+--+-- * The canonical path of the configuration file ('Just') if the token is+-- for the flag @--usingFile@.+isUsingConfFlag :: Token -> IO (Maybe String)+isUsingConfFlag (FlagToken name _ (FlagValueToken file)) =+ if name `notElem` uncurry (:) usingFileKw+ then return Nothing+ else liftM Just (canonicalizePath file)+isUsingConfFlag _ = return Nothing++-- | Recursively expands all the configuration file includes from the+-- input token stream.+--+-- It takes the input tokens and searches for any instance of the+-- @--usingFile@ flag. If this flag is found then that flag is consumed,+-- the configuration file defined by that flag is tokenized and these new+-- tokens are inserted in the current spot of the input token stream.+--+-- This is a recurvise process that will stop once all the @--usingFile@+-- have been consumed and we got a stream of pure flag tokens.+--+-- If a circular dependency is detected then an error is reported to user.+-- @parents@ has the current tree of parents so we can check if we are+-- including one parent configuration file, which will cause an infinite loop.+--+-- Arguments:+--+-- *@(parents, flag_data)@: the parents is the tree of configuraiton file+-- parents of this current configuration file. The flag_data is the+-- information about the flags defined in the code.+--+-- *@input_tokens@: the input token stream.+--+-- Returns:+--+-- * A new token stream with all the configuration file includes expanded,+-- or an error if any error is found (either with circular dependency or+-- invalid flag values).+includeConfig :: ([String], FlagData) -> [Token] -> IO TokenizeResult+includeConfig _ [] = return $ Right []+includeConfig (parents, flags) (t:ts) = do+ isUsingConf <- isUsingConfFlag t+ case isUsingConf of+ Nothing -> do rest <- includeConfig (parents, flags) ts+ return $ Right [t] `concatToks` rest+ Just conf -> let parents' = parents ++ [conf] in+ if conf `elem` parents+ then reportCircularDependency parents'+ else do confToks <- parseConfFile (parents', flags) conf+ restToks <- includeConfig (parents, flags) ts+ return $ confToks `concatToks` restToks++-- | Creates an error message when a circular dependency is found.+--+-- Creates a pretty error highlighting the circular dependency.+--+-- Arguments:+--+-- *@tree@: the tree of configuration files that caused the problem.+--+-- Returns:+--+-- * An error showing the problem.+reportCircularDependency :: [String] -> IO TokenizeResult+reportCircularDependency files = return (Left [FlagFatalError msg])+ where msg = "Error while parsing conf file: "+ ++ "Circular includes on files\n"+ ++ format files+ format fs = case fs of+ [] -> ""+ [x] -> " " ++ x+ (x:xs) -> " " ++ x ++ " ->\n" ++ format xs++-- | Takes an input string and creates a stream of tokens after parsing+-- the input with the 'parseInput'.+--+-- After the initial token stream is created all the configuration files+-- includes are expanded to create a clean token stream.+--+-- Arguments:+--+-- *@(parents, flag_data)@: the parents is the tree of configuraiton file+-- parents of this current configuration file. The flag_data is the+-- information about the flags defined in the code.+--+-- *@input_string@: the input string to tokenize.+--+--+-- Returns:+--+-- * A tokenized stream processed from the input string.+tokenize :: ([String], FlagData) -> String -> IO TokenizeResult+tokenize (parents, flags) input = includeConfig (parents, flags) toks+ where (fd, _, _) = flags+ defaultOp = mkDefaultOp $ Map.toList fd+ toks = parseInput defaultOp input++-- | Creates a map of flag name to flag default operation.+--+-- This map is used in the parser to correctly retrieve which is+-- the default operation for each flag when the user does not explicitly+-- specifies the flag operation.+--+-- Arguments:+--+-- *@flag_list@: all the flags in the code (including the flag+-- configuration).+--+-- Returns:+--+-- * A map from flag to default operation.+mkDefaultOp :: [(String, (String, [FlagDataConf]))] -> DefaultOp+mkDefaultOp [] = Map.empty+mkDefaultOp (x:xs) = Map.singleton name defaultOp `Map.union` defaultOps+ where (name, (_, flagDataConf)) = x+ defaultOps = mkDefaultOp xs+ defaultOp = flagDDefaultOperation flagDataConf++-- | Does the actual flag parsing.+--+-- It begins by parsing the entire input stream and creating a tokenized+-- input stream. A recursive search is done in these tokens to find any+-- configuration files includes. Each conf file include is expanded until+-- the tokenized stream is just composed of flags and positional arguments.+--+-- This tokenized stream is validated then by the rules of each flag, such as+-- type validation, required flags, constraints, etc.+--+-- This method is an IO action because it needs to expand the configuration+-- file includes (open the file and get it\'s content). When the stream is+-- tokenized and no more IO is needed the 'process\'' method is called.+--+-- The validation is divided in two, local validation and global validation.+--+-- Local validation handled things like reserved words, unknown flags and+-- correct flag types.+--+-- Global validation happens at the end and does all the validation that needs+-- a context, such as global validation constraints, conditionally required+-- flags and dependent default. Global validation only happens if the local+-- validation succeeds.+--+-- Arguments:+--+-- *@flag_data@: a set of all the flags to process.+--+-- *@input_stream@: the command line input stream.+--+-- Returns:+--+-- * Either a @list of errors@ ('Left') or a successful @result@ ('Right').+process :: FlagData -> [String] -> IO (Either [FlagError] ProcessResults)+process fd args = do result <- tokenize ([], fd) (unwords args)+ case result of+ Left errs -> return $ Left errs+ Right toks -> return $ process' fd toks++-- | Does the actual flag parsing after the input stream have been tokenized+-- and the configuration files have been expanded.+--+-- Updates the tokenized input stream and changes any flag alias set by the+-- user to the actual name of the flag, meaning if the user sent @--uid = 8@+-- then the token is changed to @--user_id = 8@ (considering @uid@ is an alias+-- for @user_id@). This means from this point forward the flag name is used+-- as the flag identifier (any alias was mapped to the flag name).+--+-- Performs local validation:+--+-- * Verifies that no reserved words was used for the flag\'s name.+--+-- * Validates that no unknown flag was sent by the user.+--+-- * Validates that for every value set to a flag this value can be parsed+-- to the type the flag is expecting. (i.e. checks the string value of an+-- 'Int' flag can be parsed from string to 'Int' correctly).+--+-- Performs global validation:+--+-- * Validates the 'requiredIf' constraints.+--+-- * Validates the 'defaultIf' constraints.+--+-- * Validates all global validation rules are passing (rules created by+-- using the 'validate' function)+--+-- Arguments:+--+-- *@flag_data@: a set of all the flags to process.+--+-- *@tokenized_input_stream@: the complete input stream after tokenized.+--+-- Returns:+-- * Either a @list of errors@ ('Left') or a successful @result@ ('Right').+process' :: FlagData -> [Token] -> Either [FlagError] ProcessResults+process' fd toks =+ case pipelines [localValidation, globalValidation] (fd, flags) of+ ([], res) -> Right (res, args)+ (errs, _) -> Left errs+ where toks' = updateFlagAlias fd toks+ (flags, args) = parseArgs toks' (Map.empty, [])+ localValidation = [ validateReservedWords+ , addMissingFlags+ , validateUnknownFlags+ , validateFlagParsers]+ globalValidation = [ validateRequiredIf+ , validateDependentDefault+ , validateGlobalRules]++-- | Maps the flag alias to the real flag name for each of the input tokens.+--+-- The alias is mapped using the 'mapAlias' method.+--+-- Arguments:+--+-- *@flag_data@: contains information for the configured aliases.+--+-- *@tokens@: the list of tokens.+--+-- Returns:+--+-- * An update list of tokens with each flag alias replaced with the+-- real name of the flag.+updateFlagAlias :: FlagData -> [Token] -> [Token]+updateFlagAlias (_, aliasMap, _) = map updateAlias+ where updateAlias tok = case getFlagName tok of+ Nothing -> tok+ Just name -> let name' = mapAlias aliasMap name+ in updateName tok name'++-- | Gets the flag name from a token if the token is a flag.+--+-- Arguments:+--+-- *@token@: the token.+--+-- Returns:+--+-- * The flag name ('Just') if the token is a 'FlagToken'. 'Nothing'+-- otherwise.+getFlagName :: Token -> Maybe String+getFlagName tok = case tok of+ (FlagToken name _ _) -> Just name+ _ -> Nothing++-- | Replaces the name of a flag with a new name.+--+-- Arguments:+--+-- *@token@: the token.+--+-- *@name@: the new name for the flag.+--+-- Returns:+--+-- * An updated token with the name replaced with the new name if the token+-- is a 'FlagToken'. The unmodified token otherwise.+updateName :: Token -> String -> Token+updateName tok name = case tok of+ (FlagToken _ op value) -> FlagToken name op value+ _ -> tok++-- | Checks if the help flag was sent by the user.+--+-- Arguments:+--+-- *@arguments@: the arguments from the user.+--+-- Returns:+--+-- * 'True' if the user sent the @--help@ or the @-h@ flags.+anyArgIsHelp :: [String] -> Bool+anyArgIsHelp args = any (`elem` args) helpFlags+ where helpFlags = concat [["--" ++ x, "-" ++ x] | x <- uncurry (:) helpKw]++-- | Processes the input arguments and parses all the flags.+--+-- Starts the process flags pipeline. First checks if the user wants to+-- display the help text of the program. This is done by looking for the+-- flag \"@--help@\" or \"@-h@\" flag in the input stream. If this flag is+-- found then the @display_help@ function is called with all the compiled+-- helptext and the program description.+--+-- If the user does not wants to display the help then the 'process' function+-- is called to do the actual flag parsing. This function can return errors+-- or a success result ('FlagResults', 'ArgsResults'). If any error is found+-- then the @failure@ function is called with the list of errors, otherwise the+-- @success@ function is called with the results.+--+-- See the 'process' documentation to see the rules and conditions of flag+-- parsing.+--+-- Arguments:+--+-- *@description@: the description of the program. Sent to the+-- @display_help@ function.+--+-- *@flag_data@: a collection of all the flags defined in the code.+--+-- *@success@: a success callback function. Called if no errors were found+-- while parsing the flags from the input.+--+-- *@failure@: a failure callback function. Called if some errors were+-- found while parsing the input.+--+-- *@display_help@: a display help callback function. Called when the+-- \"@--help@\" or \"@-h@\" flag was sent by the user.+--+-- Returns:+--+-- * An IO action.+processMain :: String+ -> FlagData+ -> (ProcessResults -> IO ())+ -> ([FlagError] -> IO ())+ -> (String -> [(String, [String], String)] -> IO ())+ -> IO ()+processMain desc flags success failure displayHelp = do+ args <- getQuotedArgs+ if anyArgIsHelp args+ then displayHelp desc $ getFlagHelp flags+ else do result <- process flags args+ case result of+ Left errs -> failure errs+ Right res -> success res++-- | Returns the arguments sent by the user.+--+-- Double quote any argument that contains whitespace.+--+-- Returns:+--+-- * The list of the command line arguments quoting any argument with+-- whitespace.+getQuotedArgs :: IO [String]+getQuotedArgs = do args <- getArgs+ return $ map quote' args+ where quote' s = if length (words s) > 1+ then "\"" ++ s ++ "\""+ else s++-- | Checks if a fatal error occurred.+--+-- Arguments:+--+-- *@errors@: all flag errors.+--+-- Returns:+--+-- * 'True' if a 'FlagFatalError' is found. 'False' otherwise.+hasFatalError :: [FlagError] -> Bool+hasFatalError errs = not $ null [True | FlagFatalError _ <- errs]++-- | Merges a list of pipelines.+--+-- If any pipeline returns an error then the error is returned without+-- processing the remaining pipelines.+--+-- Arguments:+--+-- *@pipelines@: a list of pipelines.+--+-- Returns:+--+-- * A pipeline function that merges a list of pipelines.+pipelines :: [[PipelineFunction]] -> PipelineFunction+pipelines [] (_, flags) = ([], flags)+pipelines (p:ps) (fd, flags) = case pipeline p (fd, flags) of+ ([], res) -> pipelines ps (fd, res)+ errs -> errs++-- | Executes the pipeline functions in order.+--+-- The result of the current pipeline function is sent to the next function+-- in the list.+--+-- The functions are evaluated until the list is consumed or any function+-- returns a fatal error.+--+-- Arguments:+--+-- *@pipelines@: the list of pipeline functions+--+-- Returns:+--+-- * A pipeline function that executes the list of pipelines in order.+pipeline :: [PipelineFunction] -> PipelineFunction+pipeline [] (_, flags) = ([], flags)+pipeline (val:vs) (fd, flags0) = case val (fd, flags0) of+ ([], flags1) -> pipeline vs (fd, flags1)+ (errs1, flags1) -> if hasFatalError errs1+ then (errs1, flags1)+ else let (errs2, flags2) = pipeline vs (fd, flags1)+ in (errs1 ++ errs2, flags2)++-- | Pipeline function that validates no flag is using a reserved word as+-- it\'s name.+--+-- Arguments:+--+-- *@(flag_data, flag_results)@: the flag data and the current flag+-- results.+--+-- Returns:+--+-- * An error if any flag is using a reserved word as it\'s name. The+-- @flag_results@ is not modified for the next pipeline function.+validateReservedWords :: PipelineFunction+validateReservedWords ((fd, aliasMap, _), flags) =+ case reservedWords `intersect` codeFlags of+ [] -> ([], flags)+ names -> (map reservedWordsError names, flags)+ where codeFlags = Map.keys fd ++ Map.keys aliasMap+ errorMsg = "The name is a reserved word and can not be used"+ reservedWordsError name = FlagFatalError $ flagError name errorMsg++-- | Applies the predicate if the value is 'Just'.+--+-- Arguments:+--+-- *@value@: value to apply the predicate+--+-- *@predicate@: the predicate to apply.+--+-- Returns:+--+-- * 'True' if the value is 'Nothing'.+--+-- * The predicate applied to the internal value if is 'Just'.+ifIsJust :: Maybe a -> (a -> Bool) -> Bool+ifIsJust val predicate = case val of+ Nothing -> True+ Just a -> predicate a++-- | Pipeline function that modifies the results by inserting all missing+-- flags into it.+--+-- At this point the flags have been processed by the parser, so the+-- 'FlagResults' will have only the flags sent by the user. The remaining+-- flags are inserted into the 'FlagResults' with a 'FlagMissing' value.+--+-- This is useful so that future pipeline functions don\'t need to worry+-- about any flag not present in the flag results, as all defined flags+-- will be there, and missing flags will be there with the 'FlagMissing'+-- value.+--+-- Arguments:+--+-- *@(flag_data, flag_results)@: the flag data and the current flag+-- results.+--+-- Returns:+--+-- * The modified @flag_results@.+addMissingFlags :: PipelineFunction+addMissingFlags ((fd, aliasMap, _), flags) = ([], flags')+ where flags' = flags `Map.union` Map.fromList missingFlags'+ inputFlags = Map.keys flags+ codeFlags = Map.keys fd+ missingFlags = [x | x <- codeFlags+ , x `notElem` inputFlags+ , ifIsJust (Map.lookup x aliasMap)+ (`notElem` inputFlags)+ ]+ missingFlags' = map (\name -> (name, FlagMissing name)) missingFlags++-- | Pipeline function that checks if any unknown flag was sent by the user.+--+-- If a flag exists in the @flag_results@ that does not exist in the+-- @flag_data@ then an error is returned.+--+-- Arguments:+--+-- *@(flag_data, flag_results)@: the flag data and the current flag+-- results.+--+-- Returns:+--+-- * An error if an unknown flag is found.+validateUnknownFlags :: PipelineFunction+validateUnknownFlags ((fd, aliasMap, _), flags) = (errors, flags)+ where inputFlags = Map.keys flags+ codeFlags = Map.keys fd ++ Map.keys aliasMap+ missingFlags = inputFlags \\ codeFlags+ errors = map (FlagFatalError . flagUnkownError) missingFlags+ errorMsg = "Unkown flag is not defined in the code"+ flagUnkownError name = flagError name errorMsg++-- | Pipeline function that runs the 'checkValidator' on all the+-- define flags on @flag_data@.+--+-- Arguments:+--+-- *@(flag_data, flag_results)@: the flag data and the current flag+-- results.+--+-- Returns:+--+-- * An error if the flag validator fails.+validateFlagParsers :: PipelineFunction+validateFlagParsers ((fd, _, _), flags) =+ (mapMaybe aux (Map.toList fd), flags)+ where aux (name, (_, conf)) = case checkValidator conf value of+ ValidationError err -> Just err+ _ -> Nothing+ where value = fromJust (Map.lookup name flags)++-- | Pipeline function that runs the 'requiredIfValidator' on all the+-- define flags on @flag_data@.+--+-- Arguments:+--+-- *@(flag_data, flag_results)@: the flag data and the current flag+-- results.+--+-- Returns:+-- * An error if the flag is required.+validateRequiredIf :: PipelineFunction+validateRequiredIf ((fd, _, _), flags) = (mapMaybe aux (Map.toList fd), flags)+ where aux (name, (_, flagDataConf)) =+ case requiredIfValidator flagDataConf flags value of+ ValidationError err -> Just err+ _ -> Nothing+ where value = fromJust (Map.lookup name flags)++-- | Pipeline function that runs the 'defaultIfValidator' on all the+-- define flags on @flag_data@.+--+-- Arguments:+--+-- *@(flag_data, flag_results)@: the flag data and the current flag+-- results.+--+-- Returns:+-- * An error if the flag is required.+validateDependentDefault :: PipelineFunction+validateDependentDefault ((fd, _, _), flags) =+ (mapMaybe aux (Map.toList fd), flags)+ where aux (name, (_, flagDataConf)) =+ case defaultIfValidator flagDataConf flags value of+ ValidationError err -> Just err+ _ -> Nothing+ where value = fromJust (Map.lookup name flags)++-- | Pipeline function that runs all the global rules defined in the+-- @flag_data@.+--+-- Arguments:+--+-- *@(flag_data, flag_results)@: the flag data and the current flag+-- results.+--+-- Returns:+-- * An error if any validation rules fails.+validateGlobalRules :: PipelineFunction+validateGlobalRules ((_, _, gr), flags) = (flagErrs, flags)+ where errs = mapMaybe (\ r -> r flags) gr+ flagErrs = map FlagNonFatalError errs++-- | Validates if the flag should be conditionally required.+--+-- If the flag is missing, was marked as conditionally required (using+-- 'requiredIf') and the required predicate returns true then+-- a \"flag required\" error is reported.+--+-- In any other condition a success validation result is returned.+--+-- Arguments:+--+-- *@flag_configurations@: the configurations for a flag.+--+-- *@flag_results@: current state of the flags.+--+-- *@flag_argument@: the flag argument.+--+-- Returns:+--+-- * 'ValidationSuccess' if the flag is not required.+-- An error ('ValidationError') if it is not.+requiredIfValidator :: [FlagDataConf]+ -> FlagResults+ -> FlagArgument+ -> ValidationResult+requiredIfValidator fdc fr (FlagMissing name)+ | flagDIsRequiredIf fdc fr = validationError name "Flag is required"+ | otherwise = ValidationSuccess+requiredIfValidator _ _ _ = ValidationSuccess++-- | Validates if the flag has a default value or the flag is optional+-- when the flag is missing.+--+-- If the flag is missing and it is not optional or it does not have a+-- default value configured then a \"flag required\" error is reported.+--+-- In any other condition a success validation result is returned.+--+-- Arguments:+--+-- *@flag_configurations@: the configurations for a flag.+--+-- *@flag_results@: current state of the flags.+--+-- Returns:+--+-- * 'ValidationSuccess' if the flag is valid with respect to the default+-- value. An error ('ValidationError') if it is not.+defaultIfValidator :: [FlagDataConf]+ -> FlagResults+ -> FlagArgument+ -> ValidationResult+defaultIfValidator fdc fr (FlagMissing name)+ | flagDHasDefaultForResults fdc fr = ValidationSuccess+ | flagDIsOptional fdc = ValidationSuccess+ | otherwise = validationError name "Flag is required"+defaultIfValidator _ _ _ = ValidationSuccess++-- | Defines a flag.+--+-- A defined flag consist of a name, a helptext and a list of flag+-- configurations. The name is the flag identifier, it must be unique among+-- all other defined flags.+--+-- The name must follow the pattern \" @\'Letter\'@ followed by many+-- @\'Letters || Numbers || Dashes (-) || Underscores (_)\'@ \".+-- If the name of the flag is invalid an+-- exception is thrown.+--+-- A parser for the flag must be set in the @configuration@ by using 'parser'+-- or 'maybeParser'. If a parser is not found an exception is thrown.+--+-- Arguments:+--+-- *@(name, helptext, configurations)@: A triple containing the flag name,+-- the helptext and the flag configurations.+--+-- Returns:+--+-- * A flag.+--+-- Throws:+--+-- * An exception if the name is invalid (does not follows the pattern).+--+-- * An exception if the parser was not set in the @configurations@.+make :: (String, String, [FlagConf a]) -> Flag a+make (name, help, flagConf) = case anyErrorWithFlag of+ Nothing -> Flag name help flagConf+ Just err -> error err+ where anyErrorWithFlag = listToMaybe $ catMaybes [validParser, validName]+ validParser = if null [True | (FlagConf_Parser _) <- flagConf]+ then Just (flagError name "Flag parser was not provided")+ else Nothing+ validName = invalidFlag (name, flagConf)++-- | Prints the help text to the screen using an standard format.+--+-- Arguments:+--+-- *@description@: the description of the program.+--+-- *@flag_helptexts@: A list of triples (name, aliases, helptext) that+-- contains an entry for each flag, with the flag's name, aliases and+-- helptext.+defaultDisplayHelp :: String -> [(String, [String], String)] -> IO ()+defaultDisplayHelp desc flags = putStrLn helpText+ where helpText = Opt.usageInfo desc (map getOptDescr flags)+ getOptDescr (name, alias, help) = mapOptOption (name:alias) help++-- | Creates an option description from the names and helptext.+--+-- Arguments:+--+-- *@names@: the names for the flag.+--+-- *@helptext@: the helptext for the flag.+--+-- Returns:+--+-- * An 'Opt.OptDescr' that describes the flag.+mapOptOption :: [String] -> String -> Opt.OptDescr String+mapOptOption names = Opt.Option short long (Opt.NoArg "")+ where (short, long) = splitShortName names++-- | Takes the single character strings from the @input_list@ and+-- separates them from the list.+--+-- >>> splitShortName ["one", "a", "two","b"]+-- ("ab", ["one", "two"])+--+-- Arguments:+--+-- *@input_list@: a list of strings.+--+-- Returns:+--+-- * A tuple where the first element is a list of the single character+-- strings from the @input_list@ and the second if the remaining strings+-- from the @input_list@.+splitShortName :: [String] -> (String, [String])+splitShortName = foldl aux ([], [])+ where aux (s, l) current = if length current == 1+ then (s ++ [head current], l)+ else (s, l ++ [current])++-- | Displaye the list of errors to the screen.+--+-- Arguments:+--+-- *@errors@: list of errors to display.+defaultDisplayErrors :: [FlagError] -> IO ()+defaultDisplayErrors errs = do putStrLn "Errors occurred while parsing flags:"+ mapM_ print errs++-- | Creates a data structure with all the flag helptext information.+--+-- Arguments:+--+-- *@flag_data@: all configured flags in the system.+--+-- Returns:+--+-- * A list of triples. Each triple contains (flag_name, [flag_alias],+-- flag_helptext). After all flags in @flag_data@ are processed the+-- two system flags (@help@ and @usingFile@) are appended to the end of+-- the list.+getFlagHelp :: FlagData -> [(String, [String], String)]+getFlagHelp (fd, _, _) = helps ++ [usingFileHelpText] ++ [helpHelpText]+ where helps = map aux (Map.toList fd)+ aux (name, (help, conf)) = (name, flagDAlias conf, help)++ usingFileHelpText = ( fst usingFileKw+ , snd usingFileKw+ , "read flags from configuration file"+ )+ helpHelpText = ( fst helpKw+ , snd helpKw+ , "show this help"+ )++-- | Returns whether the flag configuration marked this flag as optional.+--+-- Arguments:+--+-- *@flag_configurations@: the configurations for a flag.+--+-- Returns:+--+-- * 'True' if the flag is an optional flag. 'False' otherwise.+flagDIsOptional :: [FlagDataConf] -> Bool+flagDIsOptional fdc = not $ null [True | (FlagDataConf_RequiredIf _) <- fdc]++-- | Returns whether the flag should be required to the user based on the+-- current results.+--+-- First checks if the flag was configured as conditionally required (with the+-- use of the 'requiredIf' function).+--+-- If it was, this required condition is checked against the current+-- state.+--+-- Arguments:+--+-- *@flag_configurations@: the configurations for a flag.+--+-- *@flag_results@: current state of the flags.+--+-- Returns:+--+-- * 'True' if the flag should be required to the user.+flagDIsRequiredIf :: [FlagDataConf] -> FlagResults -> Bool+flagDIsRequiredIf fdc fr = case res of+ Nothing -> False+ Just p -> p fr+ where res = listToMaybe [ p | (FlagDataConf_RequiredIf p) <- fdc]++-- | Returns `True` if any of the `FlagDataConf_HasDefault` returns+-- `True`.+--+-- For all the configured default values of the flag (like when+-- using `defaultIs` or `defaultIf` checks if any of the predicates+-- returns true for the given `FlagResults`.+--+-- Arguments:+--+-- *@flag_configurations@: the configurations for a flag.+--+-- *@flag_results@: current state of the flags.+--+-- Returns:+--+-- * 'True' if there is any default value configured for the flag.+-- 'False' otherwise.+flagDHasDefaultForResults :: [FlagDataConf] -> FlagResults -> Bool+flagDHasDefaultForResults fdc fr = result+ where result = or [ p fr | (FlagDataConf_HasDefault p) <- fdc]++-- | Checks if a dependent default value was configured for the flag, like+-- when the 'defaultIf' or 'defaultIs' functions are used.+--+-- Arguments:+--+-- *@flag_configurations@: the configurations for a flag.+--+-- Returns:+--+-- * 'True' if a dependent default was configured for the flag.+-- 'False' otherwise.+flagDHasDefault :: [FlagDataConf] -> Bool+flagDHasDefault fdc = not $ null [ True | (FlagDataConf_HasDefault _) <- fdc]++-- | Checks if an empty value was configured for the flag, like+-- when the 'emptyValueIs' function is used.+--+-- Arguments:+--+-- *@flag_configurations@: the configurations for a flag.+--+-- Returns:+--+-- * 'True' if an empty value was configured for the flag.+-- 'False' otherwise.+flagDHasEmptyValue :: [FlagDataConf] -> Bool+flagDHasEmptyValue fdc = not $ null [ True | FlagDataConf_HasEmptyValue <- fdc]++-- | Finds the flag validator ('FlagDataConf_Validator') in the list of+-- flag configurations and runs it against the flag argument.+--+-- Arguments:+--+-- *@flag_configurations@: the configurations for a flag.+--+-- *@flag_argument@: the argument for the flag.+--+-- Returns:+--+-- * The result of the validator when run against the flag argument.+runDValidator :: [FlagDataConf] -> FlagArgument -> Bool+runDValidator fdc = validator+ where validator = head [x | (FlagDataConf_Validator x) <- fdc]++-- | Creates a failed validation result for a flag.+--+-- Constructor method to easily created a failed validation result+-- ('ValidationError').+--+-- Arguments:+--+-- *@flag_name@: flag name that caused the error.+--+-- *@error_message@: error message.+--+-- Returns:+--+-- * A validation result for a flag error.+validationError :: String -> String -> ValidationResult+validationError name s = ValidationError $ FlagNonFatalError errorMsg+ where errorMsg = flagError name s++-- | Checks if the flag value provided in 'FlagArgument' is valid by using+-- the validation found in the @flag_configurations@.+--+-- The configured flag validator will only be used if required.+--+-- Under these conditions the flag is considered valid, and a+-- 'ValidationSuccess' is returned, without the need to use the flag+-- validator:+--+-- * The flag is missing but was marked as optional.+--+-- * The flag is missing but has a default value.+--+-- * The flag is empty but has an empty value configured.+--+-- If none of the above applies, then this is the expected results:+--+-- * The flag is missing: A \"flag is required\" error is reported.+--+-- * The flag is empty: A \"flag value is empty\" error is reported.+--+-- * The flag has a value: The configured flag validator is run with this+-- value. If it fails a \"flag value invalid\" error is reported.+--+-- Arguments:+--+-- *@flag_configurations@: the configurations for a flag.+--+-- *@flag_argument@: the argument for the flag.+--+-- Returns:+--+-- * 'ValidationSuccess' if the flag is valid or an error (+-- 'ValidationError') if it is not.+checkValidator :: [FlagDataConf] -> FlagArgument -> ValidationResult+checkValidator fdc (FlagMissing name)+ | flagDIsOptional fdc = ValidationSuccess+ | flagDHasDefault fdc = ValidationSuccess+ | otherwise = validationError name "Flag is required"+checkValidator fdc (FlagValueMissing name)+ | flagDHasEmptyValue fdc = ValidationSuccess+ | otherwise = validationError name "Flag value was not provided"+checkValidator fdc flagArgument@(FlagValue name value)+ | runDValidator fdc flagArgument = ValidationSuccess+ | otherwise = validationError name $ "Value '" ++ value ++ "' is not valid"++-- | Helper parser function.+--+-- Parses any type that is instance of the 'Read' class.+--+-- Arguments:+--+-- *@argument@: the input argument.+--+-- Returns:+--+-- * 'Nothing' if the argument is missing or if it's value is missing.+--+-- * Otherwise it calls 'read' on the argument value and returns a \"+-- 'Maybe' a\" with the result of read.+valueParser :: Read a => FlagArgument -> Maybe a+valueParser arg = case arg of+ (FlagMissing _) -> Nothing+ (FlagValueMissing _) -> Nothing+ (FlagValue _ value) -> readMaybe value++-- | Parses an 'Int' from the input 'FlagArgument'+--+-- Arguments:+--+-- *@argument@: the input argument+--+-- Returns:+--+-- * 'Nothing' if the argument cannot be parsed to the type or the @parsed+-- value ('Just')@ if it can.+intParser :: FlagArgument -> Maybe Int+intParser = valueParser++-- | Parses an 'Double' from the input 'FlagArgument'+--+-- Arguments:+--+-- *@argument@: the input argument+--+-- Returns:+--+-- * 'Nothing' if the argument cannot be parsed to the type or the @parsed+-- value ('Just')@ if it can.+doubleParser :: FlagArgument -> Maybe Double+doubleParser = valueParser++-- | Parses an 'Float' from the input 'FlagArgument'+--+-- Arguments:+--+-- *@argument@: the input argument+--+-- Returns:+--+-- * 'Nothing' if the argument cannot be parsed to the type or the @parsed+-- value ('Just')@ if it can.+floatParser :: FlagArgument -> Maybe Float+floatParser = valueParser++-- | Parses an 'Array' from the input 'FlagArgument'+--+-- Arguments:+--+-- *@argument@: the input argument+--+-- Returns:+--+-- * 'Nothing' if the argument cannot be parsed to the type or the @parsed+-- value ('Just')@ if it can.+arrayParser :: Read a => FlagArgument -> Maybe [a]+arrayParser = valueParser++-- | Parses a 'Char' from the input 'FlagArgument'+--+-- Arguments:+--+-- *@argument@: the input argument+--+-- Returns:+--+-- * 'Nothing' if the argument cannot be parsed to the type or the @parsed+-- value ('Just')@ if it can.+charParser :: FlagArgument -> Maybe Char+charParser arg = case arg of+ (FlagMissing _) -> Nothing+ (FlagValueMissing _) -> Nothing+ (FlagValue _ value) -> if length value /= 1+ then Nothing+ else Just $ head value++-- | Parses a 'String' from the input 'FlagArgument'+--+-- Arguments:+--+-- *@argument@: the input argument+--+-- Returns:+--+-- * 'Nothing' if the argument cannot be parsed to the type or the @parsed+-- value ('Just')@ if it can.+stringParser :: FlagArgument -> Maybe String+stringParser arg = case arg of+ (FlagMissing _) -> Nothing+ (FlagValueMissing _) -> Nothing+ (FlagValue _ value) -> Just value++-- | Parses a 'Bool' from the input 'FlagArgument'+--+-- Arguments:+--+-- *@argument@: the input argument+--+-- Returns:+--+-- * @'False' ('Just')@ if the flag is missing.+--+-- * @'True' ('Just')@ if the flag value is missing.+--+-- * 'Nothing' if the argument cannot be parsed to the type or the @parsed+-- value ('Just')@ if it can.+boolParser :: FlagArgument -> Maybe Bool+boolParser arg = case arg of+ (FlagMissing _) -> Just False+ (FlagValueMissing _) -> Just True+ (FlagValue _ value) -> readMaybe value++-- | A predefined set of flag configurations for a boolean flag.+--+-- Defines a set of configurations that specifies:+--+-- * The parser to be 'boolParser'.+--+-- * The default value to be 'False'.+--+-- * The empty value to be 'True'+--+-- This defines a default boolean flag behavior such that if the flag is+-- missing then it is treated as 'False', if the flag is present (i.e+-- @--help@) then it is 'True'.+boolFlag :: [FlagConf Bool]+boolFlag = [ parser boolParser+ , defaultIs False+ , emptyValueIs True+ ]++{-# ANN module "HLint: ignore Use camelCase" #-}
+ src/System/Console/HsOptions/Parser.hs view
@@ -0,0 +1,23 @@+{- |+Module : System.Console.HsOptions.Parser+Description : Parses the flags from the input stream for HsOptions+Copyright : (c) Jose Raymundo Cruz (jose.r.cruz01@gmail.com)+License : Apache-2.0++Maintainer : Jose Raymundo Cruz (jose.r.cruz01@gmail.com)+Stability : stable+Portability : portable++Provides the parser features that takes a input stream of characters+and returns a stream of tokens.++These tokens are easier to handle as the syntax of the flags was enforced by+the parser.+-}+module System.Console.HsOptions.Parser (+ -- * Parser functions+ parseInput+) where++import System.Console.HsOptions.ParserCore+
+ src/System/Console/HsOptions/ParserCore.hs view
@@ -0,0 +1,204 @@+{- |+Module : System.Console.HsOptions.ParserCore+Description : Core features of the Parser module+Copyright : (c) Jose Raymundo Cruz (jose.r.cruz01@gmail.com)+License : Apache-2.0++Maintainer : Jose Raymundo Cruz (jose.r.cruz01@gmail.com)+Stability : stable+Portability : portable++Core functions of the 'System.Console.HsOptions.Parser.Parser'.+-}++module System.Console.HsOptions.ParserCore+where++import Control.Monad(void)+import Data.Char+import Data.Maybe+import Text.ParserCombinators.Parsec+import qualified Data.Map as Map+import System.Console.HsOptions.Types++-- | Map of operation keywords to the corresponding operation token.+operationsKeyMap :: [(String, OperationToken)]+operationsKeyMap = [ ("+=!", OperationTokenAppend')+ , ("+=", OperationTokenAppend)+ , ("=+!", OperationTokenPrepend')+ , ("=+", OperationTokenPrepend)+ , ("=", OperationTokenAssign)+ ]++-- | Returns a list of all operation keywords.+operationKeywords :: [String]+operationKeywords = [k | (k,_) <- operationsKeyMap]++-- | Returns the corresponding operation token for the input keyword.+operationTokenFor :: String -> OperationToken+operationTokenFor s = head [v | (k, v) <- operationsKeyMap, k == s]++-- | Parses a flag.+--+-- A flag consist of a 'name', followed by an 'flagOperation' and+-- a 'value'.+--+-- Returns:+--+-- * A 'FlagToken'.+flag :: DefaultOp -> GenParser Char st Token+flag defaultOp = do name <- flagName+ op <- flagOperation name defaultOp+ value <- flagValue+ return (FlagToken name op value)+++-- | Parses the name of a flag.+--+-- The name must follow the pattern of: \"'flagPrefix' 'letter'+-- 'validFlagChars'\".+--+-- Returns:+--+-- * A string with the flag name (without the prefix part).+flagName :: GenParser Char st String+flagName = do spaces+ flagPrefix+ l1 <- letter+ ls <- validFlagChars+ return (l1:ls)++-- | Parses the flag prefix.+--+-- A flag prefix is a double dash (--) or a single dash (-).+flagPrefix :: GenParser Char st ()+flagPrefix = void $ try (string "--") <|> string "-"++-- | Parses a flag operation.+--+-- Flag operations will be parsed from the keywords defined in the+-- 'operationsKeyMap'.+flagOperation :: String -> DefaultOp -> GenParser Char st OperationToken+flagOperation name defaultOp = try operation <|>+ do spaceOrEof+ return defaultOp'+ where defaultOp' = fromMaybe OperationTokenAssign (Map.lookup name defaultOp)++-- | Parses a space or the end of file character.+spaceOrEof :: GenParser Char st ()+spaceOrEof = void space <|> eof++-- | Parses a word that is not a flag.+--+-- \"Not a flag\" parses anything that is not parsed by 'flag' parser.+notFlag :: GenParser Char st String+notFlag = do spaces+ choice [ try (quotedString '"')+ , try twoDash+ , try singleDash+ , try nf1+ , try nf2+ , nf3+ ]+ where nf1 = do c1 <- string "--"+ c2 <- satisfy (not . isLetter)+ rest <- allButSpace+ return (c1 ++ [c2] ++ rest)++ nf2 = do c1 <- string "-"+ c2 <- satisfy (\s -> (not . isLetter) s && s /= '-')+ rest <- allButSpace+ return (c1 ++ [c2] ++ rest)++ nf3 = do c1 <- noneOf "-"+ rest <- allButSpace+ return (c1:rest)++ twoDash = do c1 <- string "--"+ spaceOrEof+ return c1++ singleDash = do c1 <- string "-"+ spaceOrEof+ return c1++-- | Parses a quoted string using the @character@ for quotes.+--+-- Arguments:+--+-- *@character@: the character used as quotes.+quotedString :: Char -> GenParser Char st String+quotedString c = do _ <- char c+ middle <- many (noneOf [c])+ void (char c) <|> eof+ return middle++-- | Parses a flag value.+--+-- A flag value is parsed with 'notFlag'. If this parser fails then+-- 'FlagValueTokenEmpty' is returned.+flagValue :: GenParser Char st FlagValueToken+flagValue = try getValue <|> return FlagValueTokenEmpty+ where getValue = do value <- notFlag+ return (FlagValueToken value)++-- | Parses all characters until a space is found.+allButSpace :: GenParser Char st String+allButSpace = many (satisfy (not . isSpace))++-- | Parses a command line argument.+--+-- A command argument is an argument that is not a flag ('notFlag').+cmdLineArg :: GenParser Char st Token+cmdLineArg = do arg <- notFlag+ return (ArgToken arg)++-- | Parses a flag operation.+--+-- Returns: a token representing for that operation.+operation :: GenParser Char st OperationToken+operation = do op <- choice $ map aux operationKeywords+ return $ operationTokenFor op+ where aux op = try (spaces >> string op)++-- | Parses and returns the characters that are valid for a flag.+validFlagChars :: GenParser Char st String+validFlagChars = many (oneOf "-_" <|> alphaNum)++-- | Parses many flags and/or many positional arguments.+--+-- Returns:+--+-- * A list of tokens.+manyToken :: DefaultOp -> GenParser Char st [Token]+manyToken defaultOp = many (try (flag defaultOp) <|>+ try cmdLineArg)++-- | Runs parser with the 'manyToken' parser.+parseInput' :: DefaultOp -> String -> Either ParseError [Token]+parseInput' defaultOp = parse (manyToken defaultOp ) "Top level parse error"++-- | Parses the flags from the input stream of characters to a stream of+-- tokens.+--+-- Based on the syntax of the @flags input@ this parser should not fail.+-- If there is any kind of errors while parsing an exception is thrown.+--+-- Arguments:+--+-- *@default_operations@: a map from flag name to default operation.+--+-- *@input@: the input stream of characters.+--+-- Returns:+--+-- * A stream of tokens.+--+-- Throws:+--+-- * An exception if some error with the parser occurs.+parseInput :: DefaultOp -> String -> [Token]+parseInput defaultOp input = case parseInput' defaultOp input of+ Left err -> error (show err)+ Right result -> result+
+ src/System/Console/HsOptions/Types.hs view
@@ -0,0 +1,268 @@+{- |+Module : System.Console.HsOptions.Types+Description : Data types and Types for HsOptions+Copyright : (c) Jose Raymundo Cruz (jose.r.cruz01@gmail.com)+License : Apache-2.0++Maintainer : Jose Raymundo Cruz (jose.r.cruz01@gmail.com)+Stability : stable+Portability : portable++Modules that contains all types and data types created in the library.+-}+module System.Console.HsOptions.Types+where++import qualified Data.Map as Map++-- | Data type that represents a defined flag.+-- It contains:+--+-- * the name of the flag+-- * help text for the flag+-- * list of configurations for the flags such as type, default values, etc.+data Flag a = Flag String String [FlagConf a]++-- | Data type for a flag error. It will contain the error message and+-- what kind of error occurred:+--+-- * FatalError: an error that the system can't recover from+-- * NonFatalError: an error that does not stop the process+data FlagError = FlagNonFatalError String+ | FlagFatalError String++-- | Type that represents a collection of all defined flags.+--+-- It has three components:+--+-- * A flag map: The key is the flag name and the value is the flag data+-- * An alias map: A map that connects any flag alias with it's unique flag+-- name. This is used to convert each flag alias to it's flag name when+-- parsing.+-- * A list of global validation rules+type FlagData = (FlagDataMap, FlagAliasMap, [GlobalRule])++-- | Type that holds a collection of all flags.+--+-- It's a map from flag name to flag data. The flag data holds all defined+-- configuration for each flag such as flag type, parser, default, etc.+type FlagDataMap = Map.Map String (String, [FlagDataConf])++-- | Type that holds a map from flag alias to flag name.+--+-- It is used to identify the corresponding flag given a flag alias. For+-- example if the user_id flag has two alias, @u@ and @uid@, this map will+-- have these entries: { @uid@ => @user_id@, @u@ => @user_id@ }.+type FlagAliasMap = (Map.Map String String)++-- | Type that represents the final result of the parse process.+--+-- It maps a flag name to it's value. This value is of type 'FlagArgument',+-- which means that it can be empty or not.+--+-- This type is used by the user to get each flag value in the main method by+-- using the 'get' method and passing a flag variable.+type FlagResults = (Map.Map String FlagArgument)++-- | Data type that represents an input flag argument.+--+-- It's type will vary depending on the user input. For example if the user+-- calls the program that expects the @user_id@ flag:+--+-- >>> ./runhaskell Program.hs+-- FlagArgument = FlagMissing "user_id"+--+-- >>> ./runhaskell Program.hs --user_id+-- FlagArgument = FlagValueMissing "user_id"'+--+-- >>> ./runhaskell Program.hs --user_id 8+-- FlagArgument = FlagValue "user_id" "8"+--+data FlagArgument = FlagMissing String -- ^ argument not provided+ | FlagValueMissing String -- ^ argument provided but+ -- not it's value+ | FlagValue String String -- ^ argument with value+ -- provided++-- | Type that is the list of remaining positional arguments after the parse+-- process is completed. For example:+--+-- > ./runhaskell Program.hs --user_id 8 one two three+--+-- 'ArgsResults' will contain the list [\"one\", \"two\", \"three\"]+type ArgsResults = [String]+++-- | Type that holds the 'FlagResults' and 'ArgsResults' together.+type ParseResults = (FlagResults, ArgsResults)++-- | Type of the return value of the 'process' function and it's sub-functions.+type ProcessResults = (FlagResults, ArgsResults)++-- | Type that represents a pipeline validation/processing function.+--+-- It takes a previous state as a parameter and does a set of modifications+-- to this state.+--+-- It returns a list of errors (if any error occurred) and+-- a modified state that will be passed in to the next function in the+-- pipeline.+type PipelineFunction = (FlagData, FlagResults) -> ([FlagError], FlagResults)++-- | Type that represents a global validation rule for a 'FlagResults'.+--+-- It is used to create global validation after the flags are processed. If+-- the result is a 'Nothing' then the rule passed. Otherwise if a+-- @'Just' err'@ is returned then the ruled failed with the message \"@err@\".+type GlobalRule = FlagResults -> Maybe String++-- | Type that represents the result of the 'tokenize' function and it's+-- sub-functions.+--+-- It returns either a list of errors or a valid list of tokens.+type TokenizeResult = Either [FlagError] [Token]++-- | Type that specifies whether a given validation was successful or not.+--+-- If it was not successful it contains a 'FlagError' that explains what+-- failed.+data ValidationResult =+ ValidationError FlagError+ | ValidationSuccess++-- | Data type that represent a flag configuration.+--+-- It is used when a flag is created to set the type of the flag, how it is+-- parsed, if the flag is required or optional, etc.+data FlagConf a =+ -- | Function that parses the input value of the flag to it's+ -- corresponding type, see 'charParser' for an example of this+ -- type of function.+ --+ -- The flag input text is of type 'FlagArgument', so you can determine+ -- how to map the value if it's missing or it's value is missing or if+ -- it's value was provided.+ --+ -- The function returns a 'Maybe a' type,+ -- @'Nothing'@ if the string value cannot be parsed from the input text and+ -- @'Just'@ value if it can be parsed.+ FlagConf_Parser (FlagArgument -> Maybe a)++ -- | Function that sets a dependent default value to the flag.+ --+ -- If the flag was not provided by the user this will be the default+ -- value for the flag if the default value getter function returns+ -- `Just`.+ | FlagConf_DefaultIf (FlagResults -> Maybe a)++ -- | Function that given a 'FlagResults' constraints the flag to be+ -- either required or not required.+ --+ -- If this function returns true then the flag will be required, and if+ -- not present a @flag is required@ message will be displayed to the user.+ --+ -- If this function returns false then the flag presence will be ignored.+ | FlagConf_RequiredIf (FlagResults -> Bool)++ -- | Default value for the flag when the flag was provided by the user+ -- but not the flag value (@i.e. runhaskell Program.hs --user_id@).+ --+ -- In this example @user_id@ will take the default value configured with+ -- this flag configuration since it's value is 'FlagValueMissing'+ | FlagConf_EmptyValueIs a++ -- | Alias for the flags. Allows the user to specify multiple names for+ -- the same flag, such as short name or synonyms.+ | FlagConf_Alias [String]++ -- | Default operation for flag when no operation is specified.+ --+ -- >>> runhaskell Program.hs --user_name += batman+ -- Operation was specified: Operation = "Append value"+ --+ -- >>> runhaskell Program.hs --user_name batman+ -- Operation not specified: Operation = 'FlagConf_DefaultOperation'+ | FlagConf_DefaultOperation OperationToken++-- | Data type that represents a generic flag type configuration.+--+-- It is mapped from the 'FlagConf' of each flag so that it can be bundled+-- together with all other flag's data. It is used at the validation/parsing+-- phase of the 'process' method to verify that the input flag value is+-- valid for each flag (i.e. if a required flag was not provided by the user+-- but this flag has a default value then an error does not occur).+--+-- It has a direct mapping of each 'FlagData' to a non-generic version.+data FlagDataConf =+ -- | Determines if a flag value is valid for a given flag.+ --+ -- Corresponds to 'FlagConf_Parser' and returns 'True' if the result value+ -- of the 'FlagConf_Parser' is 'Just', returns 'False' otherwise+ FlagDataConf_Validator (FlagArgument -> Bool)++ -- | Determines if a flag has a dependent default value configured.+ --+ -- Corresponds just to the predicate part of 'FlagConf_DefaultIf'.+ | FlagDataConf_HasDefault (FlagResults -> Bool)++ -- | Exactly the same as 'FlagConf_RequiredIf'+ | FlagDataConf_RequiredIf (FlagResults -> Bool)++ -- | Determines if a flag has a @empty value@ configured.+ --+ -- It is mapped from an 'FlagConf_EmptyValueIs'.+ | FlagDataConf_HasEmptyValue++ -- | Exactly the same as 'FlagConf_Alias'+ | FlagDataConf_Alias [String]++ -- | Exactly the same as 'FlagConf_DefaultOperation'+ | FlagDataConf_DefaultOperation OperationToken++-- | Data types for the flag operations+data OperationToken =+ -- Assign operation for a flag (=).+ OperationTokenAssign++ -- Append operation for a flag (+=).+ | OperationTokenAppend++ -- Append' operation for a flag (+=!).+ | OperationTokenAppend'++ -- Prepend' operation for a flag (=+).+ | OperationTokenPrepend++ -- Prepend' operation for a flag (=+!).+ | OperationTokenPrepend'+ deriving (Eq)++-- | Data type that represents the value for a flag when parsed from the+-- input stream.+data FlagValueToken =+ -- Type taken when the flag value was not provided.+ FlagValueTokenEmpty++ -- Type taken when the flag value was provided.+ | FlagValueToken String++-- | Data type that represents a flag stream using tokens.+data Token =+ -- | Token for a flag. Contains name, operation and value.+ FlagToken String OperationToken FlagValueToken++ -- | Token for a positional argument. Contains the value of the argument.+ | ArgToken String++-- | Type that contains a map from flag name to default flag operation.+type DefaultOp = Map.Map String OperationToken++-- | Making 'FlagError' an instance of 'Show'+instance Show FlagError where+ -- | To show a 'FlagFatalError' we just return the error message+ show (FlagFatalError err) = err++ -- | To show a 'FlagNonFatalError' we just return the error message+ show (FlagNonFatalError err) = err++{-# ANN module "HLint: ignore Use camelCase" #-}
+ tests/unit/MainTestSuite.hs view
@@ -0,0 +1,17 @@+module Main (+ main+ ) where++import Test.Framework++import UnitTestHelper+import qualified System.Console.HsOptionsTest as HsOptionsTest++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests =+ [+ unitTestGroup "HsOptions" HsOptionsTest.tests+ ]
+ tests/unit/System/Console/HsOptionsTestHelpers.hs view
@@ -0,0 +1,81 @@+module System.Console.HsOptionsTestHelpers+where++import Test.HUnit+import Control.Monad+import Control.Exception+import qualified System.Console.HsOptions as HSO++f2d :: HSO.Flag a -> HSO.FlagData+f2d = HSO.flagToData++data TestProcessResult =+ TestProcessError [HSO.FlagError]+ | TestProcessSuccess HSO.ProcessResults++errorsToString :: [HSO.FlagError] -> String+errorsToString [] = ""+errorsToString (er:errs) = aux er ++ errorsToString errs+ where aux (HSO.FlagNonFatalError erMessage) = " * '" ++ erMessage ++ "'\n"+ aux (HSO.FlagFatalError erMessage) = " * '" ++erMessage ++ "'\n"++assertError :: TestProcessResult -> String -> Assertion+assertError (TestProcessSuccess _) errorMessage =+ assertFailure $ "assertError failed. expected '" ++ errorMessage ++ "' but zero errors occurred"+assertError (TestProcessError errs) errorMessage =+ let nfErrs = [er | (HSO.FlagNonFatalError er) <- errs] ++ [er | (HSO.FlagFatalError er) <- errs]in+ when ( errorMessage `notElem` nfErrs)+ (assertFailure $ "assertError failed. expected '" +++ errorMessage +++ "' but error not found.\n" +++ "** other errors that where found:\n" +++ errorsToString errs)++assertSingleError :: TestProcessResult -> Assertion+assertSingleError (TestProcessSuccess _) =+ assertFailure "assertSingleError failed. expected single error but zero errors occurred"+assertSingleError (TestProcessError errs) = let count = length errs in+ when (count /= 1) (assertFailure $ "assertSingleError failed. expected single error but "+++ show count ++ " errors occurred")+++assertFlagValueEquals :: (Eq a, Show a) => TestProcessResult -> HSO.Flag a -> a -> Assertion+assertFlagValueEquals (TestProcessError errs) _flag _value =+ assertFailure ("assertFlagValueEquals failed. expected no errors when getting flag value" +++ " but errors found:\n" +++ "** errors that where found:\n" +++ errorsToString errs)++assertFlagValueEquals (TestProcessSuccess (results, _args)) flag expected = assertEqual "" expected value+ where value = HSO.get results flag++assertArgsEquals :: TestProcessResult -> [String] -> Assertion+assertArgsEquals (TestProcessError errs) _args =+ assertFailure ("assertFlagValueEquals failed. expected no errors when getting args value" +++ " but errors found:\n" +++ "** errors that where found:\n" +++ errorsToString errs)+assertArgsEquals (TestProcessSuccess (_results, args)) expected = assertEqual "" expected args+++assertException :: a -> String -> Assertion+assertException expr msg = do result <- evaluate' expr+ case result of+ Left err -> assertEqual "" msg (show err)+ Right _ -> fail "Expected exception but no exception occurred"++evaluate' :: a -> IO (Either SomeException a)+evaluate' flag = try (evaluate flag)++process :: HSO.FlagData -> String -> IO TestProcessResult+process fd input = do result <- HSO.process fd (words input)+ case result of+ Left errs -> return (TestProcessError errs)+ Right r -> return (TestProcessSuccess r)++makeFlagData :: [HSO.FlagData] -> HSO.FlagData+makeFlagData = HSO.combine+++makeConfFile :: [String] -> String+makeConfFile = unlines
+ tests/unit/UnitTestHelper.hs view
@@ -0,0 +1,26 @@+module UnitTestHelper+(+ UnitTest,+ unitTest,+ unitTestGroup+) where++import Test.HUnit+import Test.Framework.Providers.HUnit+import qualified Test.Framework as TestFramework++data UnitTest = UnitTest String Assertion++unitTest :: String -> Assertion -> UnitTest+unitTest = UnitTest++unitTestToTest :: UnitTest -> TestFramework.Test+unitTestToTest (UnitTest name assertion) = testCase name assertion++unitTestsToTests :: [UnitTest] -> [TestFramework.Test]+unitTestsToTests = map unitTestToTest++unitTestGroup :: String -> [UnitTest] -> TestFramework.Test+unitTestGroup name unitTests = TestFramework.testGroup name tests+ where tests = unitTestsToTests unitTests+