├── .editorconfig ├── .github └── workflows │ └── test.yaml ├── .gitignore ├── .stylish-haskell.yaml ├── ChangeLog.md ├── LICENSE ├── Makefile ├── README.md ├── cabal.project ├── cabal.project.9.2.8.freeze ├── cabal.project.9.4.4.freeze ├── cabal.project.9.6.2.freeze ├── example ├── bool.hs ├── list.hs ├── nonstrargs.hs ├── optparse-declarative-example.cabal ├── simple.hs ├── subcmd.hs └── verbose.hs ├── hie.yaml ├── optparse-declarative.cabal └── src └── Options └── Declarative.hs /.editorconfig: -------------------------------------------------------------------------------- 1 | root = true 2 | 3 | [*] 4 | end_of_line = lf 5 | insert_final_newline = true 6 | charset = utf-8 7 | indent_style = space 8 | indent_size = 4 9 | 10 | [Makefile] 11 | indent_style = tab 12 | 13 | [*.cabal] 14 | indent_size = 2 15 | -------------------------------------------------------------------------------- /.github/workflows/test.yaml: -------------------------------------------------------------------------------- 1 | name: test 2 | 3 | on: 4 | - push 5 | - pull_request 6 | 7 | jobs: 8 | test: 9 | strategy: 10 | matrix: 11 | ghc: ['9.2.8', '9.4.4', '9.6.2'] 12 | 13 | runs-on: ubuntu-latest 14 | 15 | steps: 16 | - uses: actions/checkout@v3 17 | - uses: haskell/actions/setup@v2 18 | id: setup-haskell 19 | with: 20 | ghc-version: ${{ matrix.ghc }} 21 | - run: cp cabal.project.${{ matrix.ghc }}.freeze cabal.project.freeze 22 | - uses: actions/cache/restore@v3 23 | id: restore-cache 24 | with: 25 | path: | 26 | ${{ steps.setup-haskell.outputs.cabal-store }} 27 | ./dist-newstyle 28 | key: cabal-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('./cabal.project.freeze') }} 29 | restore-keys: cabal-${{ runner.os }}-${{ matrix.ghc }}- 30 | - run: make build-deps 31 | - uses: actions/cache/save@v3 32 | if: steps.restore-cache.outputs.cache-hit != 'true' 33 | with: 34 | path: | 35 | ${{ steps.setup-haskell.outputs.cabal-store }} 36 | ./dist-newstyle 37 | key: cabal-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('./cabal.project.freeze') }} 38 | - run: make build 39 | - run: make test-example-bool 40 | - run: make test-example-list 41 | - run: make test-example-nonstrargs 42 | - run: make test-example-simple 43 | - run: make test-example-subcmd 44 | - run: make test-example-verbose 45 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.cabal-sandbox/ 2 | /cabal.sandbox.config 3 | /dist/ 4 | /.stack-work/ 5 | /stack.yaml 6 | /dist-newstyle/ 7 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Align the right hand side of some elements. This is quite conservative 19 | # and only applies to statements where each element occupies a single 20 | # line. All default to true. 21 | - simple_align: 22 | cases: true 23 | top_level_patterns: true 24 | records: true 25 | 26 | # Import cleanup 27 | - imports: 28 | # There are different ways we can align names and lists. 29 | # 30 | # - global: Align the import names and import list throughout the entire 31 | # file. 32 | # 33 | # - file: Like global, but don't add padding when there are no qualified 34 | # imports in the file. 35 | # 36 | # - group: Only align the imports per group (a group is formed by adjacent 37 | # import lines). 38 | # 39 | # - none: Do not perform any alignment. 40 | # 41 | # Default: global. 42 | align: global 43 | 44 | # The following options affect only import list alignment. 45 | # 46 | # List align has following options: 47 | # 48 | # - after_alias: Import list is aligned with end of import including 49 | # 'as' and 'hiding' keywords. 50 | # 51 | # > import qualified Data.List as List (concat, foldl, foldr, head, 52 | # > init, last, length) 53 | # 54 | # - with_alias: Import list is aligned with start of alias or hiding. 55 | # 56 | # > import qualified Data.List as List (concat, foldl, foldr, head, 57 | # > init, last, length) 58 | # 59 | # - new_line: Import list starts always on new line. 60 | # 61 | # > import qualified Data.List as List 62 | # > (concat, foldl, foldr, head, init, last, length) 63 | # 64 | # Default: after_alias 65 | list_align: after_alias 66 | 67 | # Right-pad the module names to align imports in a group: 68 | # 69 | # - true: a little more readable 70 | # 71 | # > import qualified Data.List as List (concat, foldl, foldr, 72 | # > init, last, length) 73 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 74 | # > init, last, length) 75 | # 76 | # - false: diff-safe 77 | # 78 | # > import qualified Data.List as List (concat, foldl, foldr, init, 79 | # > last, length) 80 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 81 | # > init, last, length) 82 | # 83 | # Default: true 84 | pad_module_names: true 85 | 86 | # Long list align style takes effect when import is too long. This is 87 | # determined by 'columns' setting. 88 | # 89 | # - inline: This option will put as much specs on same line as possible. 90 | # 91 | # - new_line: Import list will start on new line. 92 | # 93 | # - new_line_multiline: Import list will start on new line when it's 94 | # short enough to fit to single line. Otherwise it'll be multiline. 95 | # 96 | # - multiline: One line per import list entry. 97 | # Type with constructor list acts like single import. 98 | # 99 | # > import qualified Data.Map as M 100 | # > ( empty 101 | # > , singleton 102 | # > , ... 103 | # > , delete 104 | # > ) 105 | # 106 | # Default: inline 107 | long_list_align: inline 108 | 109 | # Align empty list (importing instances) 110 | # 111 | # Empty list align has following options 112 | # 113 | # - inherit: inherit list_align setting 114 | # 115 | # - right_after: () is right after the module name: 116 | # 117 | # > import Vector.Instances () 118 | # 119 | # Default: inherit 120 | empty_list_align: inherit 121 | 122 | # List padding determines indentation of import list on lines after import. 123 | # This option affects 'long_list_align'. 124 | # 125 | # - : constant value 126 | # 127 | # - module_name: align under start of module name. 128 | # Useful for 'file' and 'group' align settings. 129 | # 130 | # Default: 4 131 | list_padding: 4 132 | 133 | # Separate lists option affects formatting of import list for type 134 | # or class. The only difference is single space between type and list 135 | # of constructors, selectors and class functions. 136 | # 137 | # - true: There is single space between Foldable type and list of it's 138 | # functions. 139 | # 140 | # > import Data.Foldable (Foldable (fold, foldl, foldMap)) 141 | # 142 | # - false: There is no space between Foldable type and list of it's 143 | # functions. 144 | # 145 | # > import Data.Foldable (Foldable(fold, foldl, foldMap)) 146 | # 147 | # Default: true 148 | separate_lists: true 149 | 150 | # Space surround option affects formatting of import lists on a single 151 | # line. The only difference is single space after the initial 152 | # parenthesis and a single space before the terminal parenthesis. 153 | # 154 | # - true: There is single space associated with the enclosing 155 | # parenthesis. 156 | # 157 | # > import Data.Foo ( foo ) 158 | # 159 | # - false: There is no space associated with the enclosing parenthesis 160 | # 161 | # > import Data.Foo (foo) 162 | # 163 | # Default: false 164 | space_surround: false 165 | 166 | # Language pragmas 167 | - language_pragmas: 168 | # We can generate different styles of language pragma lists. 169 | # 170 | # - vertical: Vertical-spaced language pragmas, one per line. 171 | # 172 | # - compact: A more compact style. 173 | # 174 | # - compact_line: Similar to compact, but wrap each line with 175 | # `{-#LANGUAGE #-}'. 176 | # 177 | # Default: vertical. 178 | style: vertical 179 | 180 | # Align affects alignment of closing pragma brackets. 181 | # 182 | # - true: Brackets are aligned in same column. 183 | # 184 | # - false: Brackets are not aligned together. There is only one space 185 | # between actual import and closing bracket. 186 | # 187 | # Default: true 188 | align: true 189 | 190 | # stylish-haskell can detect redundancy of some language pragmas. If this 191 | # is set to true, it will remove those redundant pragmas. Default: true. 192 | remove_redundant: true 193 | 194 | # Replace tabs by spaces. This is disabled by default. 195 | # - tabs: 196 | # # Number of spaces to use for each tab. Default: 8, as specified by the 197 | # # Haskell report. 198 | # spaces: 8 199 | 200 | # Remove trailing whitespace 201 | - trailing_whitespace: {} 202 | 203 | # Squash multiple spaces between the left and right hand sides of some 204 | # elements into single spaces. Basically, this undoes the effect of 205 | # simple_align but is a bit less conservative. 206 | # - squash: {} 207 | 208 | # A common setting is the number of columns (parts of) code will be wrapped 209 | # to. Different steps take this into account. Default: 80. 210 | columns: 80 211 | 212 | # By default, line endings are converted according to the OS. You can override 213 | # preferred format here. 214 | # 215 | # - native: Native newline format. CRLF on Windows, LF on other OSes. 216 | # 217 | # - lf: Convert to LF ("\n"). 218 | # 219 | # - crlf: Convert to CRLF ("\r\n"). 220 | # 221 | # Default: native. 222 | newline: lf 223 | 224 | # Sometimes, language extensions are specified in a cabal file or from the 225 | # command line instead of using language pragmas in the file. stylish-haskell 226 | # needs to be aware of these, so it can parse the file correctly. 227 | # 228 | # No language extensions are enabled by default. 229 | # language_extensions: 230 | # - TemplateHaskell 231 | # - QuasiQuotes 232 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # 0.4.2 — 2021.06.24 2 | 3 | - Add `Alternative`, `MonadFix`, `MonadPlus`, `MonadFail`, `MonadThrow`, and `MonadCatch` instances for `Cmd` 4 | 5 | # 0.4.1 — 2020.11.01 6 | 7 | - Allow no options for `[a]` 8 | 9 | # 0.4.0 — 2020.11.01 10 | 11 | ## Breaking changes 12 | 13 | - Change in behavior when the same option is specified multiple times [#8](https://github.com/tanakh/optparse-declarative/pull/8) 14 | 15 | ## Other changes 16 | 17 | - Support for list types [#8](https://github.com/tanakh/optparse-declarative/pull/8) 18 | 19 | # 0.3.1 20 | 21 | - Allow False as a default value for Bool arguments [#2](https://github.com/tanakh/optparse-declarative/pull/2) 22 | - Make `[]` a `IsCmd` instance [#6](https://github.com/tanakh/optparse-declarative/pull/6) 23 | - Fix typo in README [#1](https://github.com/tanakh/optparse-declarative/pull/1) 24 | 25 | # 0.3.0 26 | 27 | - Simplify API 28 | - Support -vv -vvv verbosity 29 | - Improve help message 30 | 31 | # 0.2.0 32 | 33 | - Verbosity support 34 | 35 | # 0.1.0 36 | 37 | - First release 38 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020 Kazuki Okamoto, 2015 Hideyuki Tanaka 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PWSH = pwsh 2 | 3 | .PHONY: build 4 | build: build-deps 5 | cabal v2-build $(CABAL_OPTIONS) optparse-declarative 6 | 7 | .PHONY: build-deps 8 | build-deps: 9 | cabal v2-build --only-dependencies $(CABAL_OPTIONS) 10 | 11 | .PHONY: test 12 | test: test-example-bool test-example-list test-example-nonstrargs test-example-simple test-example-subcmd test-example-verbose 13 | 14 | .PHONY: test-example-bool 15 | test-example-bool: build 16 | cabal v2-build $(CABAL_OPTIONS) optparse-declarative-example:exe:bool 17 | cabal exec -- bool 18 | cabal exec -- bool -b 19 | cabal exec -- bool --bool 20 | 21 | .PHONY: test-example-list 22 | test-example-list: build 23 | cabal v2-build $(CABAL_OPTIONS) optparse-declarative-example:exe:list 24 | cabal exec -- list -n A 25 | cabal exec -- list -n A -n B 26 | 27 | .PHONY: test-example-nonstrargs 28 | test-example-nonstrargs: build 29 | cabal v2-build $(CABAL_OPTIONS) optparse-declarative-example:exe:nonstrargs 30 | cabal exec -- nonstrargs 1 31 | cabal exec -- nonstrargs 1 2 3 32 | 33 | .PHONY: test-example-simple 34 | test-example-simple: build 35 | cabal v2-build $(CABAL_OPTIONS) optparse-declarative-example:exe:simple 36 | cabal exec -- simple Tanaka 37 | 38 | .PHONY: test-example-subcmd 39 | test-example-subcmd: build 40 | cabal v2-build $(CABAL_OPTIONS) optparse-declarative-example:exe:subcmd 41 | cabal exec -- subcmd greet Tanaka 42 | 43 | .PHONY: test-example-verbose 44 | test-example-verbose: build 45 | cabal v2-build $(CABAL_OPTIONS) optparse-declarative-example:exe:verbose 46 | cabal exec -- verbose -v3 47 | 48 | .PHONY: freeze 49 | freeze: 50 | $(PWSH) -Command '&{\ 51 | $$file = "cabal.project.$$(ghc --numeric-version).freeze";\ 52 | if (Test-Path $$file) { Remove-Item $$file };\ 53 | cabal freeze;\ 54 | Move-Item cabal.project.freeze $$file;\ 55 | }' 56 | 57 | .PHONY: repl 58 | repl: 59 | cabal v2-repl $(CABAL_OPTIONS) 60 | 61 | .PHONY: format 62 | format: 63 | $(PWSH) -Command "& { Get-ChildItem -Filter '*.hs' -Recurse src, app, test | ForEach-Object { stylish-haskell -i $$_.FullName } }" 64 | 65 | .PHONY: setup-format 66 | setup-format: 67 | cabal v2-install stylish-haskell --overwrite-policy=always 68 | 69 | .PHONY: lint 70 | lint: 71 | hlint src 72 | hlint app 73 | 74 | .PHONY: setup-lint 75 | setup-lint: 76 | cabal v2-install hlint --overwrite-policy=always 77 | 78 | .PHONY: doc 79 | doc: 80 | cabal v2-haddock 81 | 82 | .PHONY: clean 83 | clean: 84 | cabal v2-clean 85 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # optparse-declarative 2 | 3 | [![Hackage](https://matrix.hackage.haskell.org/api/v2/packages/optparse-declarative/badge)](http://hackage.haskell.org/package/optparse-declarative) [![GitHub Actions: test](https://github.com/tanakh/optparse-declarative/workflows/test/badge.svg)](https://github.com/tanakh/optparse-declarative/actions?query=workflow%3Atest) [![Join the chat at https://gitter.im/optparse-declarative/community](https://badges.gitter.im/optparse-declarative/community.svg)](https://gitter.im/optparse-declarative/community?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) 4 | 5 | `optparse-declarative` is a declarative and easy-to-use command-line option parser. 6 | 7 | # Install 8 | 9 | ```bash 10 | $ cabal install optparse-declarative 11 | ``` 12 | 13 | # Usage 14 | 15 | ## Writing a simple command 16 | 17 | First, you need to enable `DataKinds` extension. Then import `Options.Declarative` module. 18 | 19 | ```hs 20 | {-# LANGUAGE DataKinds #-} 21 | import Options.Declarative 22 | ``` 23 | 24 | Next, define command line options as a **type of the function**. 25 | For example, this is a simple greeting program with `-g` option that 26 | takes a message of type `String` and an unnamed command-line argument 27 | that specifies a name: 28 | 29 | ```hs 30 | greet :: Flag "g" '["greet"] "STRING" "greeting message" (Def "Hello" String) 31 | -> Arg "NAME" String 32 | -> Cmd "Greeting command" () 33 | greet msg name = 34 | liftIO $ putStrLn $ get msg ++ ", " ++ get name ++ "!" 35 | ``` 36 | 37 | There are two types of options, `Flag` and `Arg`. 38 | `Flag` represents a named argument (e.g., `--greet "Hola"`), and `Arg` an unnamed argument (e.g., `John` of `greet --greet Hola John`). 39 | The last argument of `Flag` and `Arg` is the type of the value of the 40 | argument; in this example, they are both `String`. 41 | You can specify any type for the value as long as the type is an 42 | instance of `ArgRead` typeclass, in which the conversion function 43 | from `String` to the specified type is defined. 44 | `Options.Declarative` provides following instances of `ArgRead` 45 | typeclass. 46 | 47 | - Int 48 | - Integer 49 | - Bool 50 | - Double 51 | - String 52 | - (ArgRead a) => Maybe a 53 | 54 | Users can add a new instance of `ArgRead` to support any user-defined type. 55 | Please see Section "How to add a new instance of `ArgRead`" for details. 56 | 57 | If you wish to specify a default value for allowing users to omit a 58 | value, use the modifier `Def` with the default value as the second type argument (and the third type argument is the type of the value). 59 | You need to specify the default value in `String` instead of the final 60 | value of the target type; the string will be converted to the final 61 | value via `ArgRead` typeclass. 62 | 63 | In the example above, the variable `msg` has a very complex type (`Flag "g" '["greet"] "STRING" "greeting message" (Def "Hello" String)`). 64 | In order to get the value of the target type (in this case, that is `String`), 65 | you can use `get` function. 66 | 67 | The whole type of command is `Cmd`. 68 | `Cmd` is an instance of `MonadIO` and it has some extra information. 69 | 70 | Finally, you can run the whole program by `run_`. 71 | 72 | ```hs 73 | main :: IO () 74 | main = run_ greet 75 | ``` 76 | 77 | Here is an example session with the program shown above. 78 | 79 | ```bash 80 | $ ghc simple.hs 81 | 82 | $ ./simple 83 | simple: not enough arguments 84 | Try 'simple --help' for more information. 85 | 86 | $ ./simple --help 87 | Usage: simple [OPTION...] NAME 88 | Options: 89 | -g STRING --greet=STRING greeting message 90 | -? --help display this help and exit 91 | 92 | $ ./simple World 93 | Hello, World! 94 | 95 | $ ./simple --greet=Goodbye World 96 | Goodbye, World! 97 | ``` 98 | 99 | Note that only the final option is used when multiple options of the 100 | same name are given. This behavior emulates the behavior of a naive 101 | program that uses GNU Getopt. 102 | 103 | ```bash 104 | $ ./simple --greet=Hello --greet=Goodbye World 105 | Goodbye, World! 106 | ``` 107 | 108 | There is another way of interpreting multiple options of the same name. 109 | Suppose if you need to get multiple values from the same option. 110 | Say, you wish to get `["Hello", "Goodbye"]` from the command-line 111 | option `--greet=Hello --greeet=Goodbye`. Then, you can use 112 | the type `[]` to indicate that it accepts multiple values. 113 | The first line of the function `greet` in the example above 114 | would be changed as this: 115 | 116 | ```hs 117 | greet :: Flag "g" '["greet"] "STRING" "greeting message" [String] 118 | ``` 119 | 120 | The value returned by `get` will be a value of type `[String]`. 121 | See the complete working example at `example/list.hs` for details. 122 | 123 | 124 | ## Writing multiple subcommands 125 | 126 | You can write (nested) subcommands. 127 | You don't know what subcommands are? Imagine `git` command. 128 | `git` has subcommands such as `git add`, `git commit`, `git log`, etc. 129 | `git` has nested subcommands such as `git remote add`, `git remote rm`, 130 | etc. 131 | `optparse-declarative` provides an easy way to provide such possibly 132 | nested subcommands. 133 | 134 | Just group subcommands by `Group`, then you get a subcommand parser. 135 | Here is an example with two subcommands `greet` and `connect`: 136 | 137 | ```hs 138 | {-# LANGUAGE DataKinds #-} 139 | 140 | import Options.Declarative 141 | 142 | main :: IO () 143 | main = run_ $ 144 | Group "Test program for library" 145 | [ subCmd "greet" greet 146 | , subCmd "connect" connect 147 | ] 148 | 149 | greet :: Flag "g" '["greet"] "STRING" "greeting message" (Def "Hello" String) 150 | -> Flag "" '["decolate"] "" "decolate message" Bool 151 | -> Arg "NAME" String 152 | -> Cmd "Greeting command" () 153 | greet msg deco name = do 154 | let f x | get deco = "*** " ++ x ++ " ***" 155 | | otherwise = x 156 | liftIO $ putStrLn $ f $ get msg ++ ", " ++ get name ++ "!" 157 | 158 | connect :: Flag "h" '["host"] "HOST" "host name" (Def "localhost" String) 159 | -> Flag "p" '["port"] "PORT" "port number" (Def "8080" Int ) 160 | -> Cmd "Connect command" () 161 | connect host port = do 162 | let addr = get host ++ ":" ++ show (get port) 163 | liftIO $ putStrLn $ "connect to " ++ addr 164 | ``` 165 | 166 | This is a sample session for the program above: 167 | 168 | ```bash 169 | $ ./subcmd --help 170 | Usage: subcmd [OPTION...] [ARGS...] 171 | Options: 172 | -? --help display this help and exit 173 | 174 | Commands: 175 | greet Greeting command 176 | port Server command 177 | 178 | $ ./subcmd connect --port=1234 179 | connect to localhost:1234 180 | ``` 181 | 182 | If you wish to specify the program name or the version number, 183 | use `run` instead of `run_`. The first argument of `run` is 184 | a program name (of type `String`). The second argument is 185 | a version number (of type `Maybe String`). 186 | 187 | ```hs 188 | main :: IO () 189 | main = run "program_name" (Just "1.3.2") $ 190 | Group "Test program for library" 191 | [ subCmd "greet" greet 192 | , subCmd "connect" connect 193 | ] 194 | ``` 195 | 196 | For more examples, please see `example` directory. 197 | 198 | 199 | ## Default options 200 | `optparse-declarative` provides a few default options. 201 | For example, `--help` is defined automatically so users do not have to 202 | write it by their own. If run with `run` and the version number, 203 | `--version` is defined automatically. Also, `--verbosity` option (`-v` 204 | for short) is defined by default. 205 | `getVerbosity` returns the verbosity level in `Int`. 206 | `-v` gives 1, `-vv` gives 2, `-vvv` gives 3. 207 | Alternatively, `--verbose=3` would yield 3. 208 | 209 | 210 | ## How to add a new instance of `ArgRead` 211 | Users need to create an instance of `ArgRead` for supporting a new type 212 | for the command line argument. Here is the definition of class 213 | `ArgRead`. 214 | 215 | ```hs 216 | class ArgRead a where 217 | -- | Type of the argument 218 | type Unwrap a :: * 219 | type Unwrap a = a 220 | 221 | -- | Get the argument's value 222 | unwrap :: a -> Unwrap a 223 | default unwrap :: a ~ Unwrap a => a -> Unwrap a 224 | unwrap = id 225 | 226 | -- | Argument parser 227 | argRead :: [String] -> Maybe a 228 | default argRead :: Read a => [String] -> Maybe a 229 | argRead ss = getLast $ mconcat $ Last . readMaybe <$> ss 230 | 231 | -- | Indicate this argument is mandatory 232 | needArg :: Proxy a -> Bool 233 | needArg _ = True 234 | ``` 235 | 236 | Suppose you are adding a support for your type `T`. 237 | We explain which function to define explicitly, depending on the 238 | property of `T`. 239 | 240 | If `T` is the type of the final value you take out of a command line, 241 | you do not have to define `Unwrap`. If `T` is a wrapper like `Def`, 242 | define `type Unwrap T = `. For `Def x y`, 243 | `type Unwrap (Def x y) = y`. If you defined `Unwrap`, define `unwrap` 244 | that takes an actual value out of the wrapped value. 245 | 246 | `argRead` is the main function that converts String into a value. 247 | If the type is an instance of `Read` and you are satisfied with 248 | how `read` converts a `String` into value, there is no need to 249 | define your own `argRead`. Otherwise, you define a function that 250 | converts a `String` into a value of the target type. When parsing 251 | is successful, return `Just`. When it fails, return `Nothing`. 252 | If the input is `[]`, it indicates the option does not have an 253 | argument; otherwise the input is a list of a single `String`. 254 | Last but not least, define `needArg _ = False` when the option 255 | allows us to omit the associated value; consider a boolean 256 | option like `--help`. 257 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | , example 3 | -------------------------------------------------------------------------------- /cabal.project.9.2.8.freeze: -------------------------------------------------------------------------------- 1 | active-repositories: hackage.haskell.org:merge 2 | constraints: any.array ==0.5.4.0, 3 | any.base ==4.16.4.0, 4 | any.deepseq ==1.4.6.1, 5 | any.exceptions ==0.10.4, 6 | any.ghc-bignum ==1.2, 7 | any.ghc-boot-th ==9.2.8, 8 | any.ghc-prim ==0.8.0, 9 | any.mtl ==2.2.2, 10 | any.pretty ==1.1.3.6, 11 | any.rts ==1.0.2, 12 | any.stm ==2.5.0.2, 13 | any.template-haskell ==2.18.0.0, 14 | any.transformers ==0.5.6.2 15 | index-state: hackage.haskell.org 2023-06-30T03:42:07Z 16 | -------------------------------------------------------------------------------- /cabal.project.9.4.4.freeze: -------------------------------------------------------------------------------- 1 | active-repositories: hackage.haskell.org:merge 2 | constraints: any.array ==0.5.4.0, 3 | any.base ==4.17.0.0, 4 | any.deepseq ==1.4.8.0, 5 | any.exceptions ==0.10.5, 6 | any.ghc-bignum ==1.3, 7 | any.ghc-boot-th ==9.4.4, 8 | any.ghc-prim ==0.9.0, 9 | any.mtl ==2.2.2, 10 | any.pretty ==1.1.3.6, 11 | any.rts ==1.0.2, 12 | any.stm ==2.5.1.0, 13 | any.template-haskell ==2.19.0.0, 14 | any.transformers ==0.5.6.2 15 | index-state: hackage.haskell.org 2023-06-30T03:42:07Z 16 | -------------------------------------------------------------------------------- /cabal.project.9.6.2.freeze: -------------------------------------------------------------------------------- 1 | active-repositories: hackage.haskell.org:merge 2 | constraints: any.array ==0.5.5.0, 3 | any.base ==4.18.0.0, 4 | any.deepseq ==1.4.8.1, 5 | any.exceptions ==0.10.7, 6 | any.ghc-bignum ==1.3, 7 | any.ghc-boot-th ==9.6.2, 8 | any.ghc-prim ==0.10.0, 9 | any.mtl ==2.3.1, 10 | any.pretty ==1.1.3.6, 11 | any.rts ==1.0.2, 12 | any.stm ==2.5.1.0, 13 | any.template-haskell ==2.20.0.0, 14 | any.transformers ==0.6.1.0 15 | index-state: hackage.haskell.org 2023-06-30T03:42:07Z 16 | -------------------------------------------------------------------------------- /example/bool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | import Control.Monad.Trans 4 | import Options.Declarative 5 | 6 | main' :: Flag "b" '["bool"] "STRING" "boolean flag" Bool 7 | -> Cmd "Simple greeting example" () 8 | main' b = 9 | liftIO $ putStrLn $ if get b then "Flag is True" else "Flag is False" 10 | 11 | main :: IO () 12 | main = run_ main' 13 | -------------------------------------------------------------------------------- /example/list.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | import Control.Monad 4 | import Control.Monad.Trans 5 | import Options.Declarative 6 | 7 | greet :: Flag "n" '["name"] "STRING" "name" [String] 8 | -> Cmd "Count the number of people" () 9 | greet name = 10 | let people_name_list = get name 11 | num_people = length people_name_list 12 | in liftIO $ do 13 | putStrLn $ "There are " ++ show num_people ++ " people on the list." 14 | putStrLn " -- " 15 | forM_ people_name_list putStrLn 16 | 17 | main :: IO () 18 | main = run_ greet 19 | -------------------------------------------------------------------------------- /example/nonstrargs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | import Control.Monad.Trans 4 | import Options.Declarative 5 | 6 | sum' :: Arg "N" Int 7 | -> Arg "NS" [Int] 8 | -> Cmd "Simple greeting example" () 9 | sum' n ns = 10 | liftIO $ putStrLn $ show (get n) ++ ", " ++ show (sum $ get ns) 11 | 12 | main :: IO () 13 | main = run_ sum' 14 | -------------------------------------------------------------------------------- /example/optparse-declarative-example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: optparse-declarative-example 3 | version: 0.1.0 4 | synopsis: Declarative command line option parser 5 | description: Declarative and easy to use command line option parser 6 | homepage: https://github.com/tanakh/optparse-declarative 7 | license: MIT 8 | author: Hideyuki Tanaka 9 | maintainer: tanaka.hideyuki@gmail.com, kazuki.okamoto@kakkun61.com 10 | copyright: 2020 Kazuki Okamoto (岡本和樹), (c) Hideyuki Tanaka 2015 11 | category: System 12 | build-type: Simple 13 | 14 | source-repository head 15 | type: git 16 | location: https://github.com/tanakh/optparse-declarative.git 17 | 18 | common common 19 | build-depends: base >=4.7 && <5 20 | default-language: Haskell2010 21 | 22 | executable simple 23 | import: common 24 | main-is: simple.hs 25 | hs-source-dirs: . 26 | build-depends: optparse-declarative 27 | , mtl 28 | 29 | executable subcmd 30 | import: common 31 | main-is: subcmd.hs 32 | hs-source-dirs: . 33 | build-depends: optparse-declarative 34 | , mtl 35 | 36 | executable verbose 37 | import: common 38 | main-is: verbose.hs 39 | hs-source-dirs: . 40 | build-depends: optparse-declarative 41 | , mtl 42 | 43 | executable nonstrargs 44 | import: common 45 | main-is: nonstrargs.hs 46 | hs-source-dirs: . 47 | build-depends: optparse-declarative 48 | , mtl 49 | 50 | executable bool 51 | import: common 52 | main-is: bool.hs 53 | hs-source-dirs: . 54 | build-depends: optparse-declarative 55 | , mtl 56 | 57 | executable list 58 | import: common 59 | main-is: list.hs 60 | hs-source-dirs: . 61 | build-depends: optparse-declarative 62 | , mtl 63 | -------------------------------------------------------------------------------- /example/simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | import Control.Monad.Trans 4 | import Options.Declarative 5 | 6 | greet :: Flag "g" '["greet"] "STRING" "greeting message" (Def "Hello" String) 7 | -> Arg "NAME" String 8 | -> Cmd "Simple greeting example" () 9 | greet msg name = 10 | liftIO $ putStrLn $ get msg ++ ", " ++ get name ++ "!" 11 | 12 | main :: IO () 13 | main = run_ greet 14 | -------------------------------------------------------------------------------- /example/subcmd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | import Control.Monad.Trans 4 | import Options.Declarative 5 | 6 | greet :: Flag "g" '["greet"] "STRING" "greeting message" (Def "Hello" String) 7 | -> Flag "" '["decolate"] "" "decolate message" Bool 8 | -> Arg "NAME" String 9 | -> Cmd "Greeting command" () 10 | greet msg deco name = do 11 | let f x | get deco = "*** " ++ x ++ " ***" 12 | | otherwise = x 13 | liftIO $ putStrLn $ f $ get msg ++ ", " ++ get name ++ "!" 14 | 15 | connect :: Flag "h" '["host"] "HOST" "host name" (Def "localhost" String) 16 | -> Flag "p" '["port"] "PORT" "port number" (Def "8080" Int ) 17 | -> Cmd "Connect command" () 18 | connect host port = do 19 | let addr = get host ++ ":" ++ show (get port) 20 | liftIO $ putStrLn $ "connect to " ++ addr 21 | 22 | getOptExample 23 | :: Flag "o" '["output"] "FILE" "output FILE" (Def "stdout" String) 24 | -> Flag "c" '[] "FILE" "input FILE" (Def "stdin" String) 25 | -> Flag "L" '["libdir"] "DIR" "library directory" String 26 | -> Cmd "GetOpt example" () 27 | getOptExample output input libdir = 28 | liftIO $ print (get output, get input, get libdir) 29 | 30 | main :: IO () 31 | main = run_ $ 32 | Group "Test program for sub commands" 33 | [ subCmd "greet" greet 34 | , subCmd "connect" connect 35 | , subCmd "getopt" getOptExample 36 | ] 37 | -------------------------------------------------------------------------------- /example/verbose.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | import Options.Declarative 4 | 5 | test :: Cmd "verbosity test" () 6 | test = do 7 | logStr 0 "verbosity level 0" 8 | logStr 1 "verbosity level 1" 9 | logStr 2 "verbosity level 2" 10 | logStr 3 "verbosity level 3" 11 | 12 | main :: IO () 13 | main = run_ test 14 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "./src/Options/Declarative.hs" 4 | component: "lib:optparse-declarative" 5 | 6 | - path: "./example/list.hs" 7 | component: "optparse-declarative-example:exe:list" 8 | 9 | - path: "./example/bool.hs" 10 | component: "optparse-declarative-example:exe:bool" 11 | 12 | - path: "./example/nonstrargs.hs" 13 | component: "optparse-declarative-example:exe:nonstrargs" 14 | 15 | - path: "./example/verbose.hs" 16 | component: "optparse-declarative-example:exe:verbose" 17 | 18 | - path: "./example/subcmd.hs" 19 | component: "optparse-declarative-example:exe:subcmd" 20 | 21 | - path: "./example/simple.hs" 22 | component: "optparse-declarative-example:exe:simple" 23 | -------------------------------------------------------------------------------- /optparse-declarative.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: optparse-declarative 3 | version: 0.4.2 4 | synopsis: Declarative command line option parser 5 | description: Declarative and easy to use command line option parser 6 | homepage: https://github.com/tanakh/optparse-declarative 7 | license: MIT 8 | license-file: LICENSE 9 | author: Hideyuki Tanaka 10 | maintainer: tanaka.hideyuki@gmail.com, kazuki.okamoto@kakkun61.com 11 | copyright: 2020 Kazuki Okamoto (岡本和樹), (c) Hideyuki Tanaka 2015 12 | category: System 13 | build-type: Simple 14 | 15 | extra-source-files: README.md 16 | ChangeLog.md 17 | example/*.hs 18 | 19 | source-repository head 20 | type: git 21 | location: https://github.com/tanakh/optparse-declarative.git 22 | 23 | library 24 | hs-source-dirs: src 25 | exposed-modules: Options.Declarative 26 | build-depends: base >=4.7 && <5 27 | , exceptions 28 | , mtl 29 | default-language: Haskell2010 30 | -------------------------------------------------------------------------------- /src/Options/Declarative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 9 | {-# LANGUAGE KindSignatures #-} 10 | {-# LANGUAGE MultiWayIf #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TupleSections #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeOperators #-} 17 | 18 | -- | Declarative options parser 19 | 20 | module Options.Declarative ( 21 | -- * Command type 22 | IsCmd, 23 | Cmd, 24 | logStr, 25 | getVerbosity, 26 | getLogger, 27 | 28 | -- * Argument definition tools 29 | Option(..), 30 | Flag, 31 | Arg, 32 | 33 | -- * Defining argument types 34 | ArgRead(..), 35 | Def, 36 | 37 | -- * Subcommands support 38 | Group(..), 39 | SubCmd, subCmd, 40 | 41 | -- * Run a command 42 | run, run_, 43 | ) where 44 | 45 | import Control.Applicative 46 | import Control.Monad 47 | import Control.Monad.Catch 48 | import Control.Monad.Fix 49 | import Control.Monad.Reader 50 | import Data.List 51 | import Data.Maybe 52 | import Data.Monoid 53 | import Data.Proxy 54 | import GHC.TypeLits 55 | import System.Console.GetOpt 56 | import System.Environment 57 | import System.Exit 58 | import System.IO 59 | import Text.Read 60 | 61 | #if !MIN_VERSION_base(4,13,0) 62 | import Control.Monad.Fail 63 | #endif 64 | 65 | -- | Command line option 66 | class Option a where 67 | -- | Type of the argument' value 68 | type Value a :: * 69 | -- | Get the argument' value 70 | get :: a -> Value a 71 | 72 | -- | Named argument 73 | newtype Flag (shortNames :: Symbol ) 74 | (longNames :: [Symbol]) 75 | (placeholder :: Symbol ) 76 | (help :: Symbol ) 77 | a 78 | = Flag { getFlag :: a } 79 | 80 | -- | Unnamed argument 81 | newtype Arg (placeholder :: Symbol) a = Arg { getArg :: a } 82 | 83 | instance ArgRead a => Option (Flag _a _b _c _d a) where 84 | type Value (Flag _a _b _c _d a) = Unwrap a 85 | get = unwrap . getFlag 86 | 87 | instance Option (Arg _a a) where 88 | type Value (Arg _a a) = a 89 | get = getArg 90 | 91 | -- | Command line option's annotated types 92 | class ArgRead a where 93 | -- | Type of the argument 94 | type Unwrap a :: * 95 | type Unwrap a = a 96 | 97 | -- | Get the argument's value 98 | unwrap :: a -> Unwrap a 99 | default unwrap :: a ~ Unwrap a => a -> Unwrap a 100 | unwrap = id 101 | 102 | -- | Argument parser 103 | argRead :: [String] -> Maybe a 104 | default argRead :: Read a => [String] -> Maybe a 105 | argRead ss = getLast $ mconcat $ Last . readMaybe <$> ss 106 | 107 | -- | Indicate this argument is mandatory 108 | needArg :: Proxy a -> Bool 109 | needArg _ = True 110 | 111 | instance ArgRead Int 112 | 113 | instance ArgRead Integer 114 | 115 | instance ArgRead Double 116 | 117 | instance {-# OVERLAPPING #-} ArgRead String where 118 | argRead [] = Nothing 119 | argRead xs = Just $ last xs 120 | 121 | instance ArgRead Bool where 122 | argRead [] = Just False 123 | argRead ["f"] = Just False 124 | argRead ["t"] = Just True 125 | argRead _ = Nothing 126 | 127 | needArg _ = False 128 | 129 | instance ArgRead a => ArgRead (Maybe a) where 130 | argRead [] = Just Nothing 131 | argRead xs = Just <$> argRead xs 132 | 133 | instance {-# OVERLAPPABLE #-} ArgRead a => ArgRead [a] where 134 | argRead xs = Just $ mapMaybe (argRead . (:[])) xs 135 | 136 | -- | The argument which has default value 137 | newtype Def (defaultValue :: Symbol) a = 138 | Def { getDef :: a } 139 | 140 | instance (KnownSymbol defaultValue, ArgRead a) => ArgRead (Def defaultValue a) where 141 | type Unwrap (Def defaultValue a) = Unwrap a 142 | unwrap = unwrap . getDef 143 | 144 | argRead s = 145 | let s' = case s of 146 | [] -> [symbolVal (Proxy :: Proxy defaultValue)] 147 | v -> v 148 | in Def <$> argRead s' 149 | 150 | -- | Command 151 | newtype Cmd (help :: Symbol) a = 152 | Cmd (ReaderT Int IO a) 153 | deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadFix, MonadPlus, MonadFail, MonadThrow, MonadCatch) 154 | 155 | -- | Output string when the verbosity level is greater than or equal to `logLevel` 156 | logStr :: Int -- ^ Verbosity Level 157 | -> String -- ^ Message 158 | -> Cmd help () 159 | logStr logLevel msg = do 160 | l <- getLogger 161 | l logLevel msg 162 | 163 | -- | Return the verbosity level ('--verbosity=n') 164 | getVerbosity :: Cmd help Int 165 | getVerbosity = Cmd ask 166 | 167 | -- | Retrieve the logger function 168 | getLogger :: MonadIO m => Cmd a (Int -> String -> m ()) 169 | getLogger = do 170 | verbosity <- getVerbosity 171 | return $ \logLevel msg -> when (verbosity >= logLevel) $ liftIO $ putStrLn msg 172 | 173 | -- | Command group 174 | data Group = 175 | Group 176 | { groupHelp :: String 177 | , groupCmds :: [SubCmd] 178 | } 179 | 180 | -- | Sub command 181 | data SubCmd = forall c. IsCmd c => SubCmd String c 182 | 183 | -- | Command class 184 | class IsCmd c where 185 | getCmdHelp :: c -> String 186 | default getCmdHelp :: (c ~ (a -> b), IsCmd b) => c -> String 187 | getCmdHelp f = getCmdHelp $ f undefined 188 | 189 | getOptDescr :: c -> [OptDescr (String, String)] 190 | default getOptDescr :: (c ~ (a -> b), IsCmd b) => c -> [OptDescr (String, String)] 191 | getOptDescr f = getOptDescr $ f undefined 192 | 193 | getUsageHeader :: c -> String -> String 194 | default getUsageHeader :: (c ~ (a -> b), IsCmd b) => c -> String -> String 195 | getUsageHeader f = getUsageHeader $ f undefined 196 | 197 | getUsageFooter :: c -> String -> String 198 | default getUsageFooter :: (c ~ (a -> b), IsCmd b) => c -> String -> String 199 | getUsageFooter f = getUsageFooter $ f undefined 200 | 201 | runCmd :: c 202 | -> [String] -- ^ Command name 203 | -> Maybe String -- ^ Version 204 | -> [(String, String)] -- ^ Options 205 | -> [String] -- ^ Non options 206 | -> [String] -- ^ Unrecognized options 207 | -> IO () 208 | 209 | class KnownSymbols (s :: [Symbol]) where 210 | symbolVals :: Proxy s -> [String] 211 | 212 | instance KnownSymbols '[] where 213 | symbolVals _ = [] 214 | 215 | instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where 216 | symbolVals _ = symbolVal (Proxy :: Proxy s) : symbolVals (Proxy :: Proxy ss) 217 | 218 | instance ( KnownSymbol shortNames 219 | , KnownSymbols longNames 220 | , KnownSymbol placeholder 221 | , KnownSymbol help 222 | , ArgRead a 223 | , IsCmd c ) 224 | => IsCmd (Flag shortNames longNames placeholder help a -> c) where 225 | getOptDescr f = 226 | let flagName = head $ 227 | symbolVals (Proxy :: Proxy longNames) ++ 228 | [ [c] | c <- symbolVal (Proxy :: Proxy shortNames) ] 229 | in Option 230 | (symbolVal (Proxy :: Proxy shortNames)) 231 | (symbolVals (Proxy :: Proxy longNames)) 232 | (if needArg (Proxy :: Proxy a) 233 | then ReqArg 234 | (flagName, ) 235 | (symbolVal (Proxy :: Proxy placeholder)) 236 | else NoArg 237 | (flagName, "t")) 238 | (symbolVal (Proxy :: Proxy help)) 239 | : getOptDescr (f undefined) 240 | 241 | runCmd f name mbver options nonOptions unrecognized = 242 | let flagName = head $ 243 | symbolVals (Proxy :: Proxy longNames) ++ 244 | [ [c] | c <- symbolVal (Proxy :: Proxy shortNames) ] 245 | mbs = map snd $ filter ((== flagName) . fst) options 246 | in case (argRead mbs, mbs) of 247 | (Nothing, []) -> 248 | errorExit name $ "flag must be specified: --" ++ flagName 249 | (Nothing, s:_) -> 250 | errorExit name $ "bad argument: --" ++ flagName ++ "=" ++ s 251 | (Just arg, _) -> 252 | runCmd (f $ Flag arg) name mbver options nonOptions unrecognized 253 | 254 | instance {-# OVERLAPPABLE #-} 255 | ( KnownSymbol placeholder, ArgRead a, IsCmd c ) 256 | => IsCmd (Arg placeholder a -> c) where 257 | getUsageHeader = getUsageHeaderOne (Proxy :: Proxy placeholder) 258 | 259 | runCmd = runCmdOne 260 | 261 | instance {-# OVERLAPPING #-} 262 | ( KnownSymbol placeholder, IsCmd c ) 263 | => IsCmd (Arg placeholder String -> c) where 264 | getUsageHeader = getUsageHeaderOne (Proxy :: Proxy placeholder) 265 | 266 | runCmd = runCmdOne 267 | 268 | getUsageHeaderOne :: ( KnownSymbol placeholder, ArgRead a, IsCmd c ) 269 | => Proxy placeholder -> (Arg placeholder a -> c) -> String -> String 270 | getUsageHeaderOne proxy f prog = 271 | " " ++ symbolVal proxy ++ getUsageHeader (f undefined) prog 272 | 273 | runCmdOne f name mbver options nonOptions unrecognized = 274 | case nonOptions of 275 | [] -> errorExit name "not enough arguments" 276 | (opt: rest) -> 277 | case argRead [opt] of 278 | Nothing -> 279 | errorExit name $ "bad argument: " ++ opt 280 | Just arg -> 281 | runCmd (f $ Arg arg) name mbver options rest unrecognized 282 | 283 | instance {-# OVERLAPPING #-} 284 | ( KnownSymbol placeholder, ArgRead a, IsCmd c ) 285 | => IsCmd (Arg placeholder [a] -> c) where 286 | getUsageHeader f prog = 287 | " " ++ symbolVal (Proxy :: Proxy placeholder) ++ getUsageHeader (f undefined) prog 288 | 289 | runCmd f name mbver options nonOptions unrecognized = 290 | case traverse argRead $ (:[]) <$> nonOptions of 291 | Nothing -> 292 | errorExit name $ "bad arguments: " ++ unwords nonOptions 293 | Just opts -> 294 | runCmd (f $ Arg opts) name mbver options [] unrecognized 295 | 296 | instance KnownSymbol help => IsCmd (Cmd help ()) where 297 | getCmdHelp _ = symbolVal (Proxy :: Proxy help) 298 | getOptDescr _ = [] 299 | 300 | getUsageHeader _ _ = "" 301 | getUsageFooter _ _ = "" 302 | 303 | runCmd (Cmd m) name _ options nonOptions unrecognized = 304 | case (options, nonOptions, unrecognized) of 305 | (_, [], []) -> do 306 | let verbosityLevel = fromMaybe 0 $ do 307 | s <- lookup "verbose" options 308 | if | null s -> return 1 309 | | all (== 'v') s -> return $ length s + 1 310 | | otherwise -> readMaybe s 311 | runReaderT m verbosityLevel 312 | 313 | _ -> do 314 | forM_ nonOptions $ \o -> 315 | errorExit name $ "unrecognized argument '" ++ o ++ "'" 316 | forM_ unrecognized $ \o -> 317 | errorExit name $ "unrecognized option '" ++ o ++ "'" 318 | exitFailure 319 | 320 | instance IsCmd Group where 321 | getCmdHelp = groupHelp 322 | getOptDescr _ = [] 323 | 324 | getUsageHeader _ _ = " [ARGS...]" 325 | getUsageFooter g _ = unlines $ 326 | [ "" 327 | , "Commands: " 328 | ] ++ 329 | [ " " ++ name ++ replicate (12 - length name) ' ' ++ getCmdHelp c 330 | | SubCmd name c <- groupCmds g 331 | ] 332 | 333 | runCmd g name mbver _options (cmd: nonOptions) unrecognized = 334 | case [ SubCmd subname c | SubCmd subname c <- groupCmds g, subname == cmd ] of 335 | [SubCmd subname c] -> 336 | run' c (name ++ [subname]) mbver (nonOptions ++ unrecognized) 337 | _ -> 338 | errorExit name $ "unrecognized command: " ++ cmd 339 | runCmd _ name _ _ _ _ = 340 | errorExit name "no command given" 341 | 342 | -- | Make a sub command 343 | subCmd :: IsCmd c => String -> c -> SubCmd 344 | subCmd = SubCmd 345 | 346 | -- runner 347 | 348 | run' :: IsCmd c => c -> [String] -> Maybe String -> [String] -> IO () 349 | run' cmd name mbver args = do 350 | let optDescr = 351 | getOptDescr cmd 352 | ++ [ Option "?" ["help"] (NoArg ("help", "t")) "display this help and exit" ] 353 | ++ [ Option "V" ["version"] (NoArg ("version", "t")) "output version information and exit" 354 | | isJust mbver ] 355 | ++ [ Option "v" ["verbose"] (OptArg (\arg -> ("verbose", fromMaybe "" arg)) "n") "set verbosity level" ] 356 | 357 | prog = unwords name 358 | verMsg = prog ++ maybe "" (" version " ++) mbver 359 | header = "Usage: " ++ prog ++ " [OPTION...]" ++ getUsageHeader cmd prog ++ "\n" ++ 360 | " " ++ getCmdHelp cmd ++ "\n\n" ++ 361 | "Options:" 362 | 363 | usage = 364 | usageInfo header optDescr ++ 365 | getUsageFooter cmd prog 366 | 367 | case getOpt' RequireOrder optDescr args of 368 | (options, nonOptions, unrecognized, errors) 369 | | not $ null errors -> 370 | errorExit name $ intercalate ", " errors 371 | | isJust (lookup "help" options) -> do 372 | putStr usage 373 | exitSuccess 374 | | isJust (lookup "version" options) -> do 375 | putStrLn verMsg 376 | exitSuccess 377 | | otherwise -> 378 | runCmd cmd name mbver options nonOptions unrecognized 379 | 380 | -- | Run a command with specifying program name and version 381 | run :: IsCmd c => String -> Maybe String -> c -> IO () 382 | run progName progVer cmd = 383 | run' cmd [progName] progVer =<< getArgs 384 | 385 | -- | Run a command 386 | run_ :: IsCmd c => c -> IO () 387 | run_ cmd = do 388 | progName <- getProgName 389 | run progName Nothing cmd 390 | 391 | errorExit :: [String] -> String -> IO () 392 | errorExit name msg = do 393 | let prog = unwords name 394 | hPutStrLn stderr $ prog ++ ": " ++ msg 395 | hPutStrLn stderr $ "Try '" ++ prog ++ " --help' for more information." 396 | exitFailure 397 | --------------------------------------------------------------------------------