-- | Common code for parsing command line options based on getopt.
module Futhark.Util.Options
  ( FunOptDescr,
    mainWithOptions,
    commonOptions,
    module System.Console.GetOpt,
  )
where

import Control.Monad.IO.Class
import Futhark.Version
import System.Console.GetOpt
import System.Exit
import System.IO

-- | A command line option that either purely updates a configuration,
-- or performs an IO action (and stops).
type FunOptDescr cfg = OptDescr (Either (IO ()) (cfg -> cfg))

-- | Generate a main action that parses the given command line options
-- (while always adding 'commonOptions').
mainWithOptions ::
  cfg ->
  [FunOptDescr cfg] ->
  String ->
  ([String] -> cfg -> Maybe (IO ())) ->
  String ->
  [String] ->
  IO ()
mainWithOptions :: 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 ArgOrder (Either (IO ()) (cfg -> cfg))
-> [FunOptDescr cfg]
-> [String]
-> ([Either (IO ()) (cfg -> cfg)], [String], [String], [String])
forall a.
ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
getOpt' ArgOrder (Either (IO ()) (cfg -> cfg))
forall a. ArgOrder a
Permute [FunOptDescr cfg]
commandLineOptions' [String]
args of
    ([Either (IO ()) (cfg -> cfg)]
opts, [String]
nonopts, [], []) ->
      case [Either (IO ()) (cfg -> cfg)] -> Either (IO ()) cfg
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 <- [m (cfg -> cfg)] -> m [cfg -> cfg]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [m (cfg -> cfg)]
opts
      cfg -> m cfg
forall (m :: * -> *) a. Monad m => a -> m a
return (cfg -> m cfg) -> cfg -> m cfg
forall a b. (a -> b) -> a -> b
$ ((cfg -> cfg) -> (cfg -> cfg) -> cfg -> cfg)
-> (cfg -> cfg) -> [cfg -> cfg] -> cfg -> cfg
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (cfg -> cfg) -> (cfg -> cfg) -> cfg -> cfg
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) cfg -> cfg
forall a. a -> a
id ([cfg -> cfg] -> [cfg -> cfg]
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 <- String -> String -> [FunOptDescr cfg] -> IO String
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' =
      String -> String -> [FunOptDescr cfg] -> [FunOptDescr cfg]
forall cfg.
String -> String -> [FunOptDescr cfg] -> [FunOptDescr cfg]
commonOptions String
prog String
usage [FunOptDescr cfg]
commandLineOptions [FunOptDescr cfg] -> [FunOptDescr cfg] -> [FunOptDescr cfg]
forall a. [a] -> [a] -> [a]
++ [FunOptDescr cfg]
commandLineOptions

helpStr :: String -> String -> [OptDescr a] -> IO String
helpStr :: String -> String -> [OptDescr a] -> IO String
helpStr String
prog String
usage [OptDescr a]
opts = do
  let header :: String
header = [String] -> String
unlines [String
"Usage: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prog String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
usage, String
"Options:"]
  String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> [OptDescr a] -> String
forall a. String -> [OptDescr a] -> String
usageInfo String
header [OptDescr a]
opts

badOptions :: String -> [String] -> [String] -> [String] -> IO ()
badOptions :: String -> [String] -> [String] -> [String] -> IO ()
badOptions String
usage [String]
nonopts [String]
errs [String]
unrecs = do
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
errput (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Junk argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++)) [String]
nonopts
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
errput (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Unrecognised argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++)) [String]
unrecs
  Handle -> String -> IO ()
hPutStr Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
errs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
usage
  ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1

-- | Short-hand for 'liftIO . hPutStrLn stderr'
errput :: MonadIO m => String -> m ()
errput :: String -> m ()
errput = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
stderr

-- | Common definitions for @-v@ and @-h@, given the list of all other
-- options.
commonOptions :: String -> String -> [FunOptDescr cfg] -> [FunOptDescr cfg]
commonOptions :: String -> String -> [FunOptDescr cfg] -> [FunOptDescr cfg]
commonOptions String
prog String
usage [FunOptDescr cfg]
options =
  [ String
-> [String]
-> ArgDescr (Either (IO ()) (cfg -> cfg))
-> String
-> FunOptDescr cfg
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"V"
      [String
"version"]
      ( Either (IO ()) (cfg -> cfg)
-> ArgDescr (Either (IO ()) (cfg -> cfg))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (cfg -> cfg)
 -> ArgDescr (Either (IO ()) (cfg -> cfg)))
-> Either (IO ()) (cfg -> cfg)
-> ArgDescr (Either (IO ()) (cfg -> cfg))
forall a b. (a -> b) -> a -> b
$
          IO () -> Either (IO ()) (cfg -> cfg)
forall a b. a -> Either a b
Left (IO () -> Either (IO ()) (cfg -> cfg))
-> IO () -> Either (IO ()) (cfg -> cfg)
forall a b. (a -> b) -> a -> b
$ do
            IO ()
header
            IO ()
forall a. IO a
exitSuccess
      )
      String
"Print version information and exit.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (cfg -> cfg))
-> String
-> FunOptDescr cfg
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"h"
      [String
"help"]
      ( Either (IO ()) (cfg -> cfg)
-> ArgDescr (Either (IO ()) (cfg -> cfg))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (cfg -> cfg)
 -> ArgDescr (Either (IO ()) (cfg -> cfg)))
-> Either (IO ()) (cfg -> cfg)
-> ArgDescr (Either (IO ()) (cfg -> cfg))
forall a b. (a -> b) -> a -> b
$
          IO () -> Either (IO ()) (cfg -> cfg)
forall a b. a -> Either a b
Left (IO () -> Either (IO ()) (cfg -> cfg))
-> IO () -> Either (IO ()) (cfg -> cfg)
forall a b. (a -> b) -> a -> b
$ do
            IO ()
header
            String -> IO ()
putStrLn String
""
            String -> IO ()
putStrLn (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> [FunOptDescr cfg] -> IO String
forall a. String -> String -> [OptDescr a] -> IO String
helpStr String
prog String
usage (String -> String -> [FunOptDescr cfg] -> [FunOptDescr cfg]
forall cfg.
String -> String -> [FunOptDescr cfg] -> [FunOptDescr cfg]
commonOptions String
prog String
usage [] [FunOptDescr cfg] -> [FunOptDescr cfg] -> [FunOptDescr cfg]
forall a. [a] -> [a] -> [a]
++ [FunOptDescr cfg]
options)
            IO ()
forall a. IO a
exitSuccess
      )
      String
"Print help and exit."
  ]
  where
    header :: IO ()
header = do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Futhark " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
versionString
      String -> IO ()
putStrLn String
"Copyright (C) DIKU, University of Copenhagen, released under the ISC license."
      String -> IO ()
putStrLn String
"This is free software: you are free to change and redistribute it."
      String -> IO ()
putStrLn String
"There is NO WARRANTY, to the extent permitted by law."