-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Utilities for command line options parsing
-- (we use @optparse-applicative@).
--
-- Some names exported from this module are quite general when if you
-- do not assume @optparse-applicative@ usage, so consider using
-- explicit imports for it.

module Util.CLI
  ( -- * General helpers
    maybeAddDefault
  , outputOption

  -- * Named and type class based parsing
  , HasCLReader (..)
  , mkCLOptionParser
  , mkCLOptionParserExt
  , mkCLArgumentParser
  , mkCLArgumentParserExt
  , mkCommandParser
  , namedParser

  -- ** Helpers for defining 'HasCLReader'
  , eitherReader
  , readerError
  , integralReader
  ) where

import Data.Text.Manipulate (toSpinal)
import Fmt (Buildable, pretty)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Named (Name(..), arg)
import Options.Applicative
  (eitherReader, help, long, metavar, option, readerError, showDefaultWith, strOption, value)
import qualified Options.Applicative as Opt

import Util.Instances ()
import Util.Named
import Util.Num

-- | Maybe add the default value and make sure it will be shown in
-- help message.
maybeAddDefault :: Opt.HasValue f => (a -> String) -> Maybe a -> Opt.Mod f a
maybeAddDefault :: (a -> String) -> Maybe a -> Mod f a
maybeAddDefault a -> String
printer = Mod f a -> (a -> Mod f a) -> Maybe a -> Mod f a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Mod f a
forall a. Monoid a => a
mempty a -> Mod f a
addDefault
  where
    addDefault :: a -> Mod f a
addDefault a
v = a -> Mod f a
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value a
v Mod f a -> Mod f a -> Mod f a
forall a. Semigroup a => a -> a -> a
<> (a -> String) -> Mod f a
forall a (f :: * -> *). (a -> String) -> Mod f a
showDefaultWith a -> String
printer

-- | Parser for path to a file where output will be writen.
outputOption :: Opt.Parser (Maybe FilePath)
outputOption :: Parser (Maybe String)
outputOption = Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> Parser (Maybe String))
-> (Mod OptionFields String -> Parser String)
-> Mod OptionFields String
-> Parser (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Mod OptionFields String -> Parser (Maybe String))
-> Mod OptionFields String -> Parser (Maybe String)
forall a b. (a -> b) -> a -> b
$
  Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opt.short Char
'o' Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
  String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"output" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
  String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"FILEPATH" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<>
  String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Write output to the given file. If not specified, stdout is used."

----------------------------------------------------------------------------
-- Named parsing
----------------------------------------------------------------------------

-- | Supporting typeclass for 'namedParser'.
-- It specifies how a value should be parsed from command line.
-- Even though the main purpose of this class is to implement
-- helpers below, feel free to use it for other goals.
class HasCLReader a where
  getReader :: Opt.ReadM a
  -- | This string will be passed to the 'metavar' function, hence we
  -- use 'String' type rather 'Text' (even though we use 'Text' almost
  -- everywhere).
  getMetavar :: String

-- Let's add instances when the need arises.
-- The downside of having 'getMetavar' is that there is no instance
-- 'HasCLReader' for 'String' (aka 'FilePath') because we want
-- different metavars for filepaths and other strings.  We can define
-- it as @FILEPATH@ because we normally use 'Text' for everything
-- else, but it still sounds a bit dangerous.

instance HasCLReader Natural where
  getReader :: ReadM Natural
getReader = ReadM Natural
forall a. Integral a => ReadM a
integralReader
  getMetavar :: String
getMetavar = String
"NATURAL NUMBER"

instance HasCLReader Word64 where
  getReader :: ReadM Word64
getReader = ReadM Word64
forall a. Integral a => ReadM a
integralReader
  -- ↓ Same as for 'Natural', the user usually does not care whether
  -- the number is bounded (reasonable values should fit anyway).
  -- We will apply the same rule for other numeric instances.
  getMetavar :: String
getMetavar = String
"NATURAL NUMBER"

instance HasCLReader Word32 where
  getReader :: ReadM Word32
getReader = ReadM Word32
forall a. Integral a => ReadM a
integralReader
  getMetavar :: String
getMetavar = String
"NATURAL NUMBER"

instance HasCLReader Word16 where
  getReader :: ReadM Word16
getReader = ReadM Word16
forall a. Integral a => ReadM a
integralReader
  getMetavar :: String
getMetavar = String
"NATURAL NUMBER"

instance HasCLReader Word8 where
  getReader :: ReadM Word8
getReader = ReadM Word8
forall a. Integral a => ReadM a
integralReader
  getMetavar :: String
getMetavar = String
"NATURAL NUMBER"

instance HasCLReader Word where
  getReader :: ReadM Word
getReader = ReadM Word
forall a. Integral a => ReadM a
integralReader
  getMetavar :: String
getMetavar = String
"NATURAL NUMBER"

instance HasCLReader Integer where
  getReader :: ReadM Integer
getReader = ReadM Integer
forall a. Integral a => ReadM a
integralReader
  getMetavar :: String
getMetavar = String
"INTEGER"

instance HasCLReader Int64 where
  getReader :: ReadM Int64
getReader = ReadM Int64
forall a. Integral a => ReadM a
integralReader
  getMetavar :: String
getMetavar = String
"INTEGER"

instance HasCLReader Int32 where
  getReader :: ReadM Int32
getReader = ReadM Int32
forall a. Integral a => ReadM a
integralReader
  getMetavar :: String
getMetavar = String
"INTEGER"

instance HasCLReader Int16 where
  getReader :: ReadM Int16
getReader = ReadM Int16
forall a. Integral a => ReadM a
integralReader
  getMetavar :: String
getMetavar = String
"INTEGER"

instance HasCLReader Int8 where
  getReader :: ReadM Int8
getReader = ReadM Int8
forall a. Integral a => ReadM a
integralReader
  getMetavar :: String
getMetavar = String
"INTEGER"

instance HasCLReader Int where
  getReader :: ReadM Int
getReader = ReadM Int
forall a. Integral a => ReadM a
integralReader
  getMetavar :: String
getMetavar = String
"INTEGER"

instance HasCLReader Text where
  getReader :: ReadM Text
getReader = ReadM Text
forall s. IsString s => ReadM s
Opt.str
  getMetavar :: String
getMetavar = String
"STRING"

instance HasCLReader String where
  getReader :: ReadM String
getReader = ReadM String
forall s. IsString s => ReadM s
Opt.str
  getMetavar :: String
getMetavar = String
"STRING"

-- | Parse a number, checking for overflows and other stuff.
integralReader :: Integral a => Opt.ReadM a
integralReader :: ReadM a
integralReader = do
  Integer
int <- Read Integer => ReadM Integer
forall a. Read a => ReadM a
Opt.auto @Integer
  Integer -> Either Text a
forall a b. (Integral a, Integral b) => a -> Either Text b
fromIntegralChecked Integer
int
    Either Text a -> (Either Text a -> ReadM a) -> ReadM a
forall a b. a -> (a -> b) -> b
& (Text -> ReadM a) -> (a -> ReadM a) -> Either Text a -> ReadM a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> ReadM a
forall a. String -> ReadM a
readerError (String -> ReadM a) -> (Text -> String) -> Text -> ReadM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
addPrefix (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString) a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    addPrefix :: String -> String
addPrefix = (String
"failed to parse command-line numeric argument: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)

-- | Create a 'Opt.Parser' for a value using 'HasCLReader' instance
-- (hence @CL@ in the name). It uses reader and metavar from that
-- class, the rest should be supplied as arguments.
--
-- We expect some common modifiers to be always provided, a list of
-- extra modifies can be provided as well.
mkCLOptionParser ::
     forall a. (Buildable a, HasCLReader a)
  => Maybe a
  -> "name" :! String
  -> "help" :! String
  -> Opt.Parser a
mkCLOptionParser :: Maybe a -> ("name" :! String) -> ("help" :! String) -> Parser a
mkCLOptionParser Maybe a
defValue "name" :! String
name "help" :! String
hInfo =
  Maybe a
-> ("name" :! String)
-> ("help" :! String)
-> [Mod OptionFields a]
-> Parser a
forall a.
(Buildable a, HasCLReader a) =>
Maybe a
-> ("name" :! String)
-> ("help" :! String)
-> [Mod OptionFields a]
-> Parser a
mkCLOptionParserExt Maybe a
defValue "name" :! String
name "help" :! String
hInfo []

-- | A more general version of 'mkCLOptionParser' which takes a list
-- of extra (not as widely used) modifiers.
mkCLOptionParserExt ::
     forall a. (Buildable a, HasCLReader a)
  => Maybe a
  -> "name" :! String
  -> "help" :! String
  -> [Opt.Mod Opt.OptionFields a]
  -> Opt.Parser a
mkCLOptionParserExt :: Maybe a
-> ("name" :! String)
-> ("help" :! String)
-> [Mod OptionFields a]
-> Parser a
mkCLOptionParserExt Maybe a
defValue (Name "name" -> ("name" :! String) -> String
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "name" (Name "name")
Name "name"
#name -> String
name) (Name "help" -> ("help" :! String) -> String
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "help" (Name "help")
Name "help"
#help -> String
hInfo) [Mod OptionFields a]
mods =
  ReadM a -> Mod OptionFields a -> Parser a
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM a
forall a. HasCLReader a => ReadM a
getReader (Mod OptionFields a -> Parser a) -> Mod OptionFields a -> Parser a
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields a] -> Mod OptionFields a
forall a. Monoid a => [a] -> a
mconcat ([Mod OptionFields a] -> Mod OptionFields a)
-> [Mod OptionFields a] -> Mod OptionFields a
forall a b. (a -> b) -> a -> b
$
    String -> Mod OptionFields a
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar (HasCLReader a => String
forall a. HasCLReader a => String
getMetavar @a) Mod OptionFields a -> [Mod OptionFields a] -> [Mod OptionFields a]
forall a. a -> [a] -> [a]
:
    String -> Mod OptionFields a
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
name Mod OptionFields a -> [Mod OptionFields a] -> [Mod OptionFields a]
forall a. a -> [a] -> [a]
:
    String -> Mod OptionFields a
forall (f :: * -> *) a. String -> Mod f a
help String
hInfo Mod OptionFields a -> [Mod OptionFields a] -> [Mod OptionFields a]
forall a. a -> [a] -> [a]
:
    (a -> String) -> Maybe a -> Mod OptionFields a
forall (f :: * -> *) a.
HasValue f =>
(a -> String) -> Maybe a -> Mod f a
maybeAddDefault a -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Maybe a
defValue Mod OptionFields a -> [Mod OptionFields a] -> [Mod OptionFields a]
forall a. a -> [a] -> [a]
:
    [Mod OptionFields a]
mods

-- | Akin to 'mkCLOptionParser', but for arguments rather than options.
mkCLArgumentParser ::
     forall a. (Buildable a, HasCLReader a)
  => Maybe a
  -> "help" :! String
  -> Opt.Parser a
mkCLArgumentParser :: Maybe a -> ("help" :! String) -> Parser a
mkCLArgumentParser Maybe a
defValue "help" :! String
hInfo = Maybe a -> ("help" :! String) -> [Mod ArgumentFields a] -> Parser a
forall a.
(Buildable a, HasCLReader a) =>
Maybe a -> ("help" :! String) -> [Mod ArgumentFields a] -> Parser a
mkCLArgumentParserExt Maybe a
defValue "help" :! String
hInfo []

-- | Akin to 'mkCLOptionParserExt', but for arguments rather than options.
mkCLArgumentParserExt ::
     forall a. (Buildable a, HasCLReader a)
  => Maybe a
  -> "help" :! String
  -> [Opt.Mod Opt.ArgumentFields a]
  -> Opt.Parser a
mkCLArgumentParserExt :: Maybe a -> ("help" :! String) -> [Mod ArgumentFields a] -> Parser a
mkCLArgumentParserExt Maybe a
defValue (Name "help" -> ("help" :! String) -> String
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "help" (Name "help")
Name "help"
#help -> String
hInfo) [Mod ArgumentFields a]
mods =
  ReadM a -> Mod ArgumentFields a -> Parser a
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
Opt.argument ReadM a
forall a. HasCLReader a => ReadM a
getReader (Mod ArgumentFields a -> Parser a)
-> Mod ArgumentFields a -> Parser a
forall a b. (a -> b) -> a -> b
$ [Mod ArgumentFields a] -> Mod ArgumentFields a
forall a. Monoid a => [a] -> a
mconcat ([Mod ArgumentFields a] -> Mod ArgumentFields a)
-> [Mod ArgumentFields a] -> Mod ArgumentFields a
forall a b. (a -> b) -> a -> b
$
    String -> Mod ArgumentFields a
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar (HasCLReader a => String
forall a. HasCLReader a => String
getMetavar @a) Mod ArgumentFields a
-> [Mod ArgumentFields a] -> [Mod ArgumentFields a]
forall a. a -> [a] -> [a]
:
    String -> Mod ArgumentFields a
forall (f :: * -> *) a. String -> Mod f a
help String
hInfo Mod ArgumentFields a
-> [Mod ArgumentFields a] -> [Mod ArgumentFields a]
forall a. a -> [a] -> [a]
:
    (a -> String) -> Maybe a -> Mod ArgumentFields a
forall (f :: * -> *) a.
HasValue f =>
(a -> String) -> Maybe a -> Mod f a
maybeAddDefault a -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Maybe a
defValue Mod ArgumentFields a
-> [Mod ArgumentFields a] -> [Mod ArgumentFields a]
forall a. a -> [a] -> [a]
:
    [Mod ArgumentFields a]
mods

-- | Parser for command options
mkCommandParser :: String -> Opt.Parser a -> String -> Opt.Mod Opt.CommandFields a
mkCommandParser :: String -> Parser a -> String -> Mod CommandFields a
mkCommandParser String
commandName Parser a
parser String
desc =
  String -> ParserInfo a -> Mod CommandFields a
forall a. String -> ParserInfo a -> Mod CommandFields a
Opt.command String
commandName (ParserInfo a -> Mod CommandFields a)
-> ParserInfo a -> Mod CommandFields a
forall a b. (a -> b) -> a -> b
$
  Parser a -> InfoMod a -> ParserInfo a
forall a. Parser a -> InfoMod a -> ParserInfo a
Opt.info (Parser (a -> a)
forall a. Parser (a -> a)
Opt.helper Parser (a -> a) -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
parser) (InfoMod a -> ParserInfo a) -> InfoMod a -> ParserInfo a
forall a b. (a -> b) -> a -> b
$
  String -> InfoMod a
forall a. String -> InfoMod a
Opt.progDesc String
desc

-- | Create a 'Opt.Parser' for a value using its type-level name.
--
-- This expects type-level name to be in camelCase as appropriate for Haskell
-- and transforms the variable inside.
namedParser ::
     forall (a :: Type) (name :: Symbol).
     (Buildable a, HasCLReader a, KnownSymbol name)
  => Maybe a
  -> String
  -> Opt.Parser (name :! a)
namedParser :: Maybe a -> String -> Parser (name :! a)
namedParser Maybe a
defValue String
hInfo =
  ReadM (name :! a)
-> Mod OptionFields (name :! a) -> Parser (name :! a)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((Name name
forall (name :: Symbol). Name name
Name @name) Name name -> ReadM a -> ReadM (name :! a)
forall (m :: * -> *) (name :: Symbol) a.
Functor m =>
Name name -> m a -> m (NamedF Identity a name)
<.!> ReadM a
forall a. HasCLReader a => ReadM a
getReader) (Mod OptionFields (name :! a) -> Parser (name :! a))
-> Mod OptionFields (name :! a) -> Parser (name :! a)
forall a b. (a -> b) -> a -> b
$
    [Mod OptionFields (name :! a)] -> Mod OptionFields (name :! a)
forall a. Monoid a => [a] -> a
mconcat
    [ String -> Mod OptionFields (name :! a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long (Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toSpinal (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
name)
    , String -> Mod OptionFields (name :! a)
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar (HasCLReader a => String
forall a. HasCLReader a => String
getMetavar @a)
    , String -> Mod OptionFields (name :! a)
forall (f :: * -> *) a. String -> Mod f a
help String
hInfo
    , ((name :! a) -> String)
-> Maybe (name :! a) -> Mod OptionFields (name :! a)
forall (f :: * -> *) a.
HasValue f =>
(a -> String) -> Maybe a -> Mod f a
maybeAddDefault (name :! a) -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Name name
forall (name :: Symbol). Name name
Name @name Name name -> Maybe a -> Maybe (name :! a)
forall (m :: * -> *) (name :: Symbol) a.
Functor m =>
Name name -> m a -> m (NamedF Identity a name)
<.!> Maybe a
defValue)
    ]
  where
    name :: String
name = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name)