{-# LANGUAGE QuasiQuotes #-}

-- | This module defines a generator for @getopt_long@ based command
-- line argument parsing.  Each option is associated with arbitrary C
-- code that will perform side effects, usually by setting some global
-- variables.
module Futhark.CodeGen.Backends.GenericC.Options
  ( Option (..),
    OptionArgument (..),
    generateOptionParser,
  )
where

import Data.Char (isSpace)
import Data.Function ((&))
import Data.List (intercalate)
import Data.Maybe
import qualified Language.C.Quote.C as C
import qualified Language.C.Syntax as C

-- | Specification if a single command line option.  The option must
-- have a long name, and may also have a short name.
--
-- In the action, the option argument (if any) is stored as in the
-- @char*@-typed variable @optarg@.
data Option = Option
  { Option -> String
optionLongName :: String,
    Option -> Maybe Char
optionShortName :: Maybe Char,
    Option -> OptionArgument
optionArgument :: OptionArgument,
    Option -> String
optionDescription :: String,
    Option -> Stm
optionAction :: C.Stm
  }

-- | Whether an option accepts an argument.
data OptionArgument
  = NoArgument
  | -- | The 'String' becomes part of the help text.
    RequiredArgument String
  | OptionalArgument

-- | Generate an option parser as a function of the given name, that
-- accepts the given command line options.  The result is a function
-- that should be called with @argc@ and @argv@.  The function returns
-- the number of @argv@ elements that have been processed.
--
-- If option parsing fails for any reason, the entire process will
-- terminate with error code 1.
generateOptionParser :: String -> [Option] -> C.Func
generateOptionParser :: String -> [Option] -> Func
generateOptionParser String
fname [Option]
options =
  [C.cfun|int $id:fname(struct futhark_context_config *cfg, int argc, char* const argv[]) {
       int $id:chosen_option;

       static struct option long_options[] = { $inits:option_fields, {0, 0, 0, 0} };

       static char* option_descriptions = $string:option_descriptions;

       while (($id:chosen_option =
                 getopt_long(argc, argv, $string:option_string, long_options, NULL)) != -1) {
         $stms:option_applications
         if ($id:chosen_option == ':') {
           futhark_panic(-1, "Missing argument for option %s\n", argv[optind-1]);
         }
         if ($id:chosen_option == '?') {
           fprintf(stderr, "Usage: %s [OPTIONS]...\nOptions:\n\n%s\n", fut_progname, $string:option_descriptions);
           futhark_panic(1, "Unknown option: %s\n", argv[optind-1]);
         }
       }
       return optind;
     }
         |]
  where
    chosen_option :: String
chosen_option = String
"ch"
    option_string :: String
option_string = Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: [Option] -> String
optionString [Option]
options
    option_applications :: [Stm]
option_applications = String -> [Option] -> [Stm]
optionApplications String
chosen_option [Option]
options
    option_fields :: [Initializer]
option_fields = [Option] -> [Initializer]
optionFields [Option]
options
    option_descriptions :: String
option_descriptions = [Option] -> String
describeOptions [Option]
options

trim :: String -> String
trim :: String -> String
trim = String -> String
f (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f
  where
    f :: String -> String
f = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace

describeOptions :: [Option] -> String
describeOptions :: [Option] -> String
describeOptions [Option]
opts =
  let
   in [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Option, String) -> String) -> [(Option, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Option, String) -> String
extendDesc [(Option, String)]
with_short_descs
  where
    with_short_descs :: [(Option, String)]
with_short_descs = (Option -> (Option, String)) -> [Option] -> [(Option, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Option
opt -> (Option
opt, Option -> String
shortDesc Option
opt)) [Option]
opts
    max_short_desc_len :: Int
max_short_desc_len = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((Option, String) -> Int) -> [(Option, String)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((Option, String) -> String) -> (Option, String) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Option, String) -> String
forall a b. (a, b) -> b
snd) [(Option, String)]
with_short_descs
    extendDesc :: (Option, String) -> String
    extendDesc :: (Option, String) -> String
extendDesc (Option
opt, String
short) =
      Int -> String -> String
forall a. Int -> [a] -> [a]
take (Int
max_short_desc_len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (String
short String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
repeat Char
' ')
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ ( Option -> String
optionDescription Option
opt
               String -> (String -> [String]) -> [String]
forall a b. a -> (a -> b) -> b
& String -> [String]
lines
               [String] -> ([String] -> [String]) -> [String]
forall a b. a -> (a -> b) -> b
& (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
trim
               [String] -> ([String] -> String) -> String
forall a b. a -> (a -> b) -> b
& String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate (Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
max_short_desc_len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Char
' ')
           )
    shortDesc :: Option -> String
    shortDesc :: Option -> String
shortDesc Option
opt =
      [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"  ",
          String -> (Char -> String) -> Maybe Char -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Char
c -> String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/") (Maybe Char -> String) -> Maybe Char -> String
forall a b. (a -> b) -> a -> b
$ Option -> Maybe Char
optionShortName Option
opt,
          String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Option -> String
optionLongName Option
opt,
          case Option -> OptionArgument
optionArgument Option
opt of
            OptionArgument
NoArgument -> String
""
            RequiredArgument String
what -> String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what
            OptionArgument
OptionalArgument -> String
" [ARG]"
        ]

optionFields :: [Option] -> [C.Initializer]
optionFields :: [Option] -> [Initializer]
optionFields = (Int -> Option -> Initializer)
-> [Int] -> [Option] -> [Initializer]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Option -> Initializer
forall a. (Show a, Integral a) => a -> Option -> Initializer
field [(Int
1 :: Int) ..]
  where
    field :: a -> Option -> Initializer
field a
i Option
option =
      [C.cinit| { $string:(optionLongName option), $id:arg, NULL, $int:i } |]
      where
        arg :: String
arg = case Option -> OptionArgument
optionArgument Option
option of
          OptionArgument
NoArgument -> String
"no_argument"
          RequiredArgument String
_ -> String
"required_argument"
          OptionArgument
OptionalArgument -> String
"optional_argument"

optionApplications :: String -> [Option] -> [C.Stm]
optionApplications :: String -> [Option] -> [Stm]
optionApplications String
chosen_option = (Int -> Option -> Stm) -> [Int] -> [Option] -> [Stm]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Option -> Stm
forall a. (Show a, Integral a) => a -> Option -> Stm
check [(Int
1 :: Int) ..]
  where
    check :: a -> Option -> Stm
check a
i Option
option =
      [C.cstm|if ($exp:cond) $stm:(optionAction option)|]
      where
        cond :: Exp
cond = case Option -> Maybe Char
optionShortName Option
option of
          Maybe Char
Nothing -> [C.cexp|$id:chosen_option == $int:i|]
          Just Char
c ->
            [C.cexp|($id:chosen_option == $int:i) ||
                                            ($id:chosen_option == $char:c)|]

optionString :: [Option] -> String
optionString :: [Option] -> String
optionString = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([Option] -> [String]) -> [Option] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Option -> Maybe String) -> [Option] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Option -> Maybe String
optionStringChunk
  where
    optionStringChunk :: Option -> Maybe String
optionStringChunk Option
option = do
      Char
short <- Option -> Maybe Char
optionShortName Option
option
      String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
        Char
short Char -> String -> String
forall a. a -> [a] -> [a]
:
        case Option -> OptionArgument
optionArgument Option
option of
          OptionArgument
NoArgument -> String
""
          RequiredArgument String
_ -> String
":"
          OptionArgument
OptionalArgument -> String
"::"