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
|
module Main (main) where
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Data.List
import Data.Proxy
import Data.Text qualified as T
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.IO
import Command
import Command.Run
import Config
import Version
data CmdlineOptions = CmdlineOptions
{ optShowHelp :: Bool
, optShowVersion :: Bool
}
defaultCmdlineOptions :: CmdlineOptions
defaultCmdlineOptions = CmdlineOptions
{ optShowHelp = False
, optShowVersion = False
}
options :: [OptDescr (CmdlineOptions -> CmdlineOptions)]
options =
[ Option ['h'] ["help"]
(NoArg $ \opts -> opts { optShowHelp = True })
"show this help and exit"
, Option ['V'] ["version"]
(NoArg $ \opts -> opts { optShowVersion = True })
"show version and exit"
]
data SomeCommandType = forall c. Command c => SC (Proxy c)
commands :: [ SomeCommandType ]
commands =
[ SC $ Proxy @RunCommand
]
lookupCommand :: String -> Maybe SomeCommandType
lookupCommand name = find p commands
where
p (SC cmd) = commandName cmd == name
main :: IO ()
main = do
args <- getArgs
(opts, cmdargs) <- case getOpt RequireOrder options args of
(o, cmdargs, []) -> return (foldl (flip id) defaultCmdlineOptions o, cmdargs)
(_, _, errs) -> do
hPutStrLn stderr $ concat errs <> "Try `minici --help' for more information."
exitFailure
when (optShowHelp opts) $ do
let header = "Usage: minici [<option>...] <command> [<args>]"
putStr $ usageInfo header options
exitSuccess
when (optShowVersion opts) $ do
putStrLn versionLine
exitSuccess
(ncmd, cargs) <- case cmdargs of
[] -> return (head commands, [])
(cname : cargs)
| Just nc <- lookupCommand cname -> return (nc, cargs)
| otherwise -> do
hPutStr stderr $ unlines
[ "Unknown command `" <> cname <> "'."
, "Try `minici --help' for more information."
]
exitFailure
runSomeCommand ncmd cargs
data FullCommandOptions c = FullCommandOptions
{ fcoSpecific :: CommandOptions c
, fcoShowHelp :: Bool
}
defaultFullOptions :: Command c => proxy c -> FullCommandOptions c
defaultFullOptions proxy = FullCommandOptions
{ fcoSpecific = defaultCommandOptions proxy
, fcoShowHelp = False
}
fullCommandOptions :: Command c => proxy c -> [ OptDescr (FullCommandOptions c -> FullCommandOptions c) ]
fullCommandOptions proxy =
map (fmap $ \f fco -> fco { fcoSpecific = f (fcoSpecific fco) } ) (commandOptions proxy)
++
[ Option [ 'h' ] [ "help" ]
(NoArg $ \opts -> opts { fcoShowHelp = True })
"show this help and exit"
]
runSomeCommand :: SomeCommandType -> [ String ] -> IO ()
runSomeCommand (SC tproxy) args = do
let exitWithErrors errs = do
hPutStrLn stderr $ concat errs <> "Try `minici " <> commandName tproxy <> " --help' for more information."
exitFailure
(opts, cmdargs) <- case getOpt Permute (fullCommandOptions tproxy) args of
(o, strargs, []) -> case runExcept $ argsFromStrings strargs of
Left err -> exitWithErrors [ err <> "\n" ]
Right cmdargs -> do
let fullOptions = foldl (flip id) (defaultFullOptions tproxy) o
return (fullOptions, cmdargs)
(_, _, errs) -> exitWithErrors errs
when (fcoShowHelp opts) $ do
putStr $ usageInfo (T.unpack $ commandUsage tproxy) (fullCommandOptions tproxy)
exitSuccess
Just configPath <- findConfig
config <- parseConfig configPath
let cmd = commandInit tproxy (fcoSpecific opts) cmdargs
let CommandExec exec = commandExec cmd
flip runReaderT config exec
|