-
Notifications
You must be signed in to change notification settings - Fork 4
/
Simple.hs
176 lines (168 loc) · 5.44 KB
/
Simple.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
{-# LANGUAGE TemplateHaskell #-}
-- | Simple interface to program arguments.
--
-- Typical usage with no commands:
--
-- @
-- do (opts,()) <-
-- simpleOptions "ver"
-- "header"
-- "desc"
-- (flag () () (long "some-flag"))
-- empty
-- doThings opts
-- @
--
-- Typical usage with commands:
--
-- @
-- do (opts,runCmd) <-
-- simpleOptions "ver"
-- "header"
-- "desc"
-- (pure ()) $
-- do addCommand "delete"
-- "Delete the thing"
-- (const deleteTheThing)
-- (pure ())
-- addCommand "create"
-- "Create a thing"
-- createAThing
-- (strOption (long "hello"))
-- runCmd
-- @
module Options.Applicative.Simple
( module Options.Applicative.Simple
, module Options.Applicative
) where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Either
import Control.Monad.Trans.Writer
import Data.Monoid
import Data.Version
import Development.GitRev (gitDirty, gitHash)
import Language.Haskell.TH (Q,Exp)
import qualified Language.Haskell.TH.Syntax as TH
import Options.Applicative
import System.Environment
-- | Generate and execute a simple options parser.
simpleOptions
:: String
-- ^ version string
-> String
-- ^ header
-> String
-- ^ program description
-> Parser a
-- ^ global settings
-> EitherT b (Writer (Mod CommandFields b)) ()
-- ^ commands (use 'addCommand')
-> IO (a,b)
simpleOptions versionString h pd globalParser commandParser =
do args <- getArgs
case execParserPure (prefs idm) parser args of
Failure _ | null args -> withArgs ["--help"] (execParser parser)
parseResult -> handleParseResult parseResult
where parser = info (versionOption <*> simpleParser globalParser commandParser) desc
desc = fullDesc <> header h <> progDesc pd
versionOption =
infoOption
versionString
(long "version" <>
help "Show version")
-- | Generate a string like @Version 1.2, Git revision 1234@.
--
-- @$(simpleVersion …)@ @::@ 'String'
simpleVersion :: Version -> Q Exp
simpleVersion version =
[|concat (["Version "
,$(TH.lift $ showVersion version)
] ++
if $gitHash == ("UNKNOWN" :: String)
then []
else
[", Git revision "
,$gitHash
,if $gitDirty
then " (dirty)"
else ""
])|]
-- | Add a command to the options dispatcher.
addCommand :: String -- ^ command string
-> String -- ^ title of command
-> (a -> b) -- ^ constructor to wrap up command in common data type
-> Parser a -- ^ command parser
-> EitherT b (Writer (Mod CommandFields b)) ()
addCommand cmd title constr inner =
lift (tell (command cmd
(info (constr <$> inner)
(progDesc title))))
-- | Add a command that takes sub-commands to the options dispatcher.
--
-- Example:
--
-- @
-- addSubCommands "thing"
-- "Subcommands that operate on things"
-- (do addCommand "delete"
-- "Delete the thing"
-- (const deleteTheThing)
-- (pure ())
-- addCommand "create"
-- "Create a thing"
-- createAThing
-- (strOption (long "hello")))
-- @
--
-- If there are common options between all the sub-commands, use 'addCommand'
-- in combination with 'simpleParser' instead of 'addSubCommands'.
addSubCommands
:: String
-- ^ command string
-> String
-- ^ title of command
-> EitherT b (Writer (Mod CommandFields b)) ()
-- ^ sub-commands (use 'addCommand')
-> EitherT b (Writer (Mod CommandFields b)) ()
addSubCommands cmd title commandParser =
addCommand cmd
title
(\((), a) -> a)
(simpleParser (pure ()) commandParser)
-- | Generate a simple options parser.
--
-- Most of the time you should use 'simpleOptions' instead, but 'simpleParser'
-- can be used for sub-commands that need common options. For example:
--
-- @
-- addCommand "thing"
-- "Subcommands that operate on things"
-- (\\(opts,runSubCmd) -> runSubCmd opts)
-- (simpleParser (flag () () (long "some-flag")) $
-- do addCommand "delete"
-- "Delete the thing"
-- (const deleteTheThing)
-- (pure ())
-- addCommand "create"
-- "Create a thing"
-- createAThing
-- (strOption (long "hello")))
-- @
--
simpleParser
:: Parser a
-- ^ common settings
-> EitherT b (Writer (Mod CommandFields b)) ()
-- ^ commands (use 'addCommand')
-> Parser (a,b)
simpleParser commonParser commandParser =
helpOption <*> config
where helpOption =
abortOption ShowHelpText $
long "help" <>
help "Show this help text"
config =
(,) <$> commonParser <*>
case runWriter (runEitherT commandParser) of
(Right (),d) -> subparser d
(Left b,_) -> pure b