module Futhark.Util.Options
( FunOptDescr,
mainWithOptions,
commonOptions,
optionsError,
module System.Console.GetOpt,
)
where
import Control.Monad.IO.Class
import Data.List (sortBy)
import Data.Text.IO qualified as T
import Futhark.Version
import System.Console.GetOpt
import System.Environment (getProgName)
import System.Exit
import System.IO
type FunOptDescr cfg = OptDescr (Either (IO ()) (cfg -> cfg))
mainWithOptions ::
cfg ->
[FunOptDescr cfg] ->
String ->
([String] -> cfg -> Maybe (IO ())) ->
String ->
[String] ->
IO ()
mainWithOptions :: forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions cfg
emptyConfig [FunOptDescr cfg]
commandLineOptions String
usage [String] -> cfg -> Maybe (IO ())
f String
prog [String]
args =
case forall a.
ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
getOpt' forall a. ArgOrder a
Permute [FunOptDescr cfg]
commandLineOptions' [String]
args of
([Either (IO ()) (cfg -> cfg)]
opts, [String]
nonopts, [], []) ->
case forall {m :: * -> *}. Monad m => [m (cfg -> cfg)] -> m cfg
applyOpts [Either (IO ()) (cfg -> cfg)]
opts of
Right cfg
config
| Just IO ()
m <- [String] -> cfg -> Maybe (IO ())
f [String]
nonopts cfg
config -> IO ()
m
| Bool
otherwise -> [String] -> [String] -> [String] -> IO ()
invalid [String]
nonopts [] []
Left IO ()
m -> IO ()
m
([Either (IO ()) (cfg -> cfg)]
_, [String]
nonopts, [String]
unrecs, [String]
errs) -> [String] -> [String] -> [String] -> IO ()
invalid [String]
nonopts [String]
unrecs [String]
errs
where
applyOpts :: [m (cfg -> cfg)] -> m cfg
applyOpts [m (cfg -> cfg)]
opts = do
[cfg -> cfg]
fs <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [m (cfg -> cfg)]
opts
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a. [a] -> [a]
reverse [cfg -> cfg]
fs) cfg
emptyConfig
invalid :: [String] -> [String] -> [String] -> IO ()
invalid [String]
nonopts [String]
unrecs [String]
errs = do
String
help <- forall a. String -> String -> [OptDescr a] -> IO String
helpStr String
prog String
usage [FunOptDescr cfg]
commandLineOptions'
String -> [String] -> [String] -> [String] -> IO ()
badOptions String
help [String]
nonopts [String]
errs [String]
unrecs
commandLineOptions' :: [FunOptDescr cfg]
commandLineOptions' =
forall cfg.
String -> String -> [FunOptDescr cfg] -> [FunOptDescr cfg]
commonOptions String
prog String
usage [FunOptDescr cfg]
commandLineOptions forall a. [a] -> [a] -> [a]
++ [FunOptDescr cfg]
commandLineOptions
helpStr :: String -> String -> [OptDescr a] -> IO String
helpStr :: forall a. String -> String -> [OptDescr a] -> IO String
helpStr String
prog String
usage [OptDescr a]
opts = do
let header :: String
header = [String] -> String
unlines [String
"Usage: " forall a. [a] -> [a] -> [a]
++ String
prog forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
usage, String
"Options:"]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. String -> [OptDescr a] -> String
usageInfo String
header forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy forall {a} {a}. OptDescr a -> OptDescr a -> Ordering
cmp [OptDescr a]
opts
where
cmp :: OptDescr a -> OptDescr a -> Ordering
cmp (Option String
_ (String
a : [String]
_) ArgDescr a
_ String
_) (Option String
_ (String
b : [String]
_) ArgDescr a
_ String
_) = forall a. Ord a => a -> a -> Ordering
compare String
a String
b
cmp (Option (Char
a : String
_) [String]
_ ArgDescr a
_ String
_) (Option (Char
b : String
_) [String]
_ ArgDescr a
_ String
_) = forall a. Ord a => a -> a -> Ordering
compare Char
a Char
b
cmp (Option String
_ [String]
_ ArgDescr a
_ String
a) (Option String
_ [String]
_ ArgDescr a
_ String
b) = forall a. Ord a => a -> a -> Ordering
compare String
a String
b
badOptions :: String -> [String] -> [String] -> [String] -> IO ()
badOptions :: String -> [String] -> [String] -> [String] -> IO ()
badOptions String
usage [String]
nonopts [String]
errs [String]
unrecs = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadIO m => String -> m ()
errput forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Junk argument: " ++)) [String]
nonopts
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadIO m => String -> m ()
errput forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Unrecognised argument: " ++)) [String]
unrecs
Handle -> String -> IO ()
hPutStr Handle
stderr forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
errs forall a. [a] -> [a] -> [a]
++ String
usage
forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
errput :: (MonadIO m) => String -> m ()
errput :: forall (m :: * -> *). MonadIO m => String -> m ()
errput = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
stderr
commonOptions :: String -> String -> [FunOptDescr cfg] -> [FunOptDescr cfg]
commonOptions :: forall cfg.
String -> String -> [FunOptDescr cfg] -> [FunOptDescr cfg]
commonOptions String
prog String
usage [FunOptDescr cfg]
options =
[ forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
String
"V"
[String
"version"]
( forall a. a -> ArgDescr a
NoArg forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ do
IO ()
header
forall a. IO a
exitSuccess
)
String
"Print version information and exit.",
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
String
"h"
[String
"help"]
( forall a. a -> ArgDescr a
NoArg forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ do
IO ()
header
String -> IO ()
putStrLn String
""
String -> IO ()
putStrLn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. String -> String -> [OptDescr a] -> IO String
helpStr String
prog String
usage (forall cfg.
String -> String -> [FunOptDescr cfg] -> [FunOptDescr cfg]
commonOptions String
prog String
usage [] forall a. [a] -> [a] -> [a]
++ [FunOptDescr cfg]
options)
forall a. IO a
exitSuccess
)
String
"Print help and exit."
]
where
header :: IO ()
header = do
Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"Futhark " forall a. Semigroup a => a -> a -> a
<> Text
versionString
Text -> IO ()
T.putStrLn Text
"Copyright (C) DIKU, University of Copenhagen, released under the ISC license."
Text -> IO ()
T.putStrLn Text
"This is free software: you are free to change and redistribute it."
Text -> IO ()
T.putStrLn Text
"There is NO WARRANTY, to the extent permitted by law."
optionsError :: String -> IO ()
optionsError :: String -> IO ()
optionsError String
s = do
String
prog <- IO String
getProgName
Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
prog forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> String
s
forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2