    -- | Common code for parsing command line options based on getopt.
    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

    -- | 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 :: 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 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
          fs <- [m (cfg -> cfg)] -> m [cfg -> cfg]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence [m (cfg -> cfg)]
    opts
          pure $ foldl (.) id (reverse fs) emptyConfig

        invalid :: [String] -> [String] -> [String] -> IO ()
    invalid [String]
    nonopts [String]
    unrecs [String]
    errs = do
          help <- String -> String -> [FunOptDescr cfg] -> IO String
    forall a. String -> String -> [OptDescr a] -> IO String
    helpStr String
    prog String
    usage [FunOptDescr cfg]
    commandLineOptions'
          badOptions help nonopts errs 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 :: 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: " 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 a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (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] -> String) -> [OptDescr a] -> String
    forall a b. (a -> b) -> a -> b
    $ (OptDescr a -> OptDescr a -> Ordering)
    -> [OptDescr a] -> [OptDescr a]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy OptDescr a -> OptDescr a -> Ordering
    forall {a} {a}. OptDescr a -> OptDescr a -> Ordering
    cmp [OptDescr a]
    opts
      where
        -- Sort first by long option, then by short name, then by description.  Hopefully
        -- everything has a long option.
        cmp :: OptDescr a -> OptDescr a -> Ordering
    cmp (Option String
    _ (String
    a : [String]
    _) ArgDescr a
    _ String
    _) (Option String
    _ (String
    b : [String]
    _) ArgDescr a
    _ String
    _) = String -> String -> Ordering
    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
    _) = Char -> Char -> Ordering
    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) = String -> String -> Ordering
    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
      (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 :: forall (m :: * -> *). MonadIO m => String -> m ()
    errput = IO () -> m ()
    forall a. IO a -> m a
    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 :: forall cfg.
    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
          Text -> IO ()
    T.putStrLn (Text -> IO ()) -> Text -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "Futhark " Text -> Text -> Text
    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."

    -- | Terminate the program with this error message (but don't report
    -- it as an ICE, as happens with 'error').
    optionsError :: String -> IO ()
    optionsError :: String -> IO ()
    optionsError String
    s = do
      prog <- IO String
    getProgName
      hPutStrLn stderr $ prog <> ": " <> s
      exitWith $ ExitFailure 2