diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 ` -- 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 ` 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. + +[![Build Status](https://travis-ci.org/josercruz01/hsoptions.svg?branch=master)](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 `. + +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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/ComplexFlag.hs b/examples/ComplexFlag.hs new file mode 100644 --- /dev/null +++ b/examples/ComplexFlag.hs @@ -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 diff --git a/examples/DependentDefaultsDemo.hs b/examples/DependentDefaultsDemo.hs new file mode 100644 --- /dev/null +++ b/examples/DependentDefaultsDemo.hs @@ -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) diff --git a/examples/SimpleFlag.hs b/examples/SimpleFlag.hs new file mode 100644 --- /dev/null +++ b/examples/SimpleFlag.hs @@ -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 + diff --git a/hsoptions.cabal b/hsoptions.cabal new file mode 100644 --- /dev/null +++ b/hsoptions.cabal @@ -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 + . + . + 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 \@ 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 + ) + . + > 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 diff --git a/src/System/Console/HsOptions.hs b/src/System/Console/HsOptions.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/HsOptions.hs @@ -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 +. + +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 \@ 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 +) + +> 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" #-} diff --git a/src/System/Console/HsOptions/Core.hs b/src/System/Console/HsOptions/Core.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/HsOptions/Core.hs @@ -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" #-} diff --git a/src/System/Console/HsOptions/Parser.hs b/src/System/Console/HsOptions/Parser.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/HsOptions/Parser.hs @@ -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 + diff --git a/src/System/Console/HsOptions/ParserCore.hs b/src/System/Console/HsOptions/ParserCore.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/HsOptions/ParserCore.hs @@ -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 + diff --git a/src/System/Console/HsOptions/Types.hs b/src/System/Console/HsOptions/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/HsOptions/Types.hs @@ -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" #-} diff --git a/tests/unit/MainTestSuite.hs b/tests/unit/MainTestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/unit/MainTestSuite.hs @@ -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 + ] diff --git a/tests/unit/System/Console/HsOptionsTestHelpers.hs b/tests/unit/System/Console/HsOptionsTestHelpers.hs new file mode 100644 --- /dev/null +++ b/tests/unit/System/Console/HsOptionsTestHelpers.hs @@ -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 diff --git a/tests/unit/UnitTestHelper.hs b/tests/unit/UnitTestHelper.hs new file mode 100644 --- /dev/null +++ b/tests/unit/UnitTestHelper.hs @@ -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 +