-- 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
  , namedParser

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

import qualified Data.Kind as Kind
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

-- | 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 printer :: 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 v :: 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 '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 "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 "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 "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. Read a => ReadM a
Opt.auto
  getMetavar :: String
getMetavar = "NATURAL NUMBER"

instance HasCLReader Word64 where
  getReader :: ReadM Word64
getReader = ReadM Word64
forall a. Read a => ReadM a
Opt.auto
  -- ↓ Same as for 'Natural', the user usually does not care whether
  -- the number if bounded (reasonable values should fit anyway).
  getMetavar :: String
getMetavar = "NATURAL NUMBER"

instance HasCLReader Integer where
  getReader :: ReadM Integer
getReader = ReadM Integer
forall a. Read a => ReadM a
Opt.auto
  getMetavar :: String
getMetavar = "INTEGER"

instance HasCLReader Int where
  getReader :: ReadM Int
getReader = ReadM Int
forall a. Read a => ReadM a
Opt.auto
  getMetavar :: String
getMetavar = "INTEGER"

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

-- | 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 defValue :: Maybe a
defValue name :: "name" :! String
name hInfo :: "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 defValue :: 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) mods :: [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 defValue :: Maybe a
defValue hInfo :: "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 defValue :: 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) mods :: [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

-- | Create a 'Opt.Parser' for a value using its type-level name.
namedParser ::
     forall (a :: Kind.Type) (name :: Symbol).
     (Buildable a, HasCLReader a, KnownSymbol name)
  => Maybe a
  -> String
  -> Opt.Parser (name :! a)
namedParser :: Maybe a -> String -> Parser (name :! a)
namedParser defValue :: Maybe a
defValue hInfo :: 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 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)