-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | 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 Morley.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.Bits (Bits)
import Fmt (Buildable, pretty)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Options.Applicative
  (eitherReader, help, long, metavar, option, readerError, showDefaultWith, strOption, value)
import Options.Applicative qualified as Opt

import Morley.Util.Instances ()
import Morley.Util.Named
import Morley.Util.Text (toSpinal)

-- | 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 :: forall (f :: * -> *) a.
HasValue f =>
(a -> FilePath) -> Maybe a -> Mod f a
maybeAddDefault a -> FilePath
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 -> FilePath) -> Mod f a
forall a (f :: * -> *). (a -> FilePath) -> Mod f a
showDefaultWith a -> FilePath
printer

-- | Parser for path to a file where output will be writen.
outputOption :: Opt.Parser (Maybe FilePath)
outputOption :: Parser (Maybe FilePath)
outputOption = Parser FilePath -> Parser (Maybe FilePath)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser FilePath -> Parser (Maybe FilePath))
-> (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath
-> Parser (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Mod OptionFields FilePath -> Parser (Maybe FilePath))
-> Mod OptionFields FilePath -> Parser (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$
  Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opt.short Char
'o' Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<>
  FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"output" Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<>
  FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"FILEPATH" Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<>
  FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"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, Bits a) => ReadM a
integralReader
  getMetavar :: FilePath
getMetavar = FilePath
"NATURAL NUMBER"

instance HasCLReader Word64 where
  getReader :: ReadM Word64
getReader = ReadM Word64
forall a. (Integral a, Bits 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 :: FilePath
getMetavar = FilePath
"NATURAL NUMBER"

instance HasCLReader Word32 where
  getReader :: ReadM Word32
getReader = ReadM Word32
forall a. (Integral a, Bits a) => ReadM a
integralReader
  getMetavar :: FilePath
getMetavar = FilePath
"NATURAL NUMBER"

instance HasCLReader Word16 where
  getReader :: ReadM Word16
getReader = ReadM Word16
forall a. (Integral a, Bits a) => ReadM a
integralReader
  getMetavar :: FilePath
getMetavar = FilePath
"NATURAL NUMBER"

instance HasCLReader Word8 where
  getReader :: ReadM Word8
getReader = ReadM Word8
forall a. (Integral a, Bits a) => ReadM a
integralReader
  getMetavar :: FilePath
getMetavar = FilePath
"NATURAL NUMBER"

instance HasCLReader Word where
  getReader :: ReadM Word
getReader = ReadM Word
forall a. (Integral a, Bits a) => ReadM a
integralReader
  getMetavar :: FilePath
getMetavar = FilePath
"NATURAL NUMBER"

instance HasCLReader Integer where
  getReader :: ReadM Integer
getReader = ReadM Integer
forall a. (Integral a, Bits a) => ReadM a
integralReader
  getMetavar :: FilePath
getMetavar = FilePath
"INTEGER"

instance HasCLReader Int64 where
  getReader :: ReadM Int64
getReader = ReadM Int64
forall a. (Integral a, Bits a) => ReadM a
integralReader
  getMetavar :: FilePath
getMetavar = FilePath
"INTEGER"

instance HasCLReader Int32 where
  getReader :: ReadM Int32
getReader = ReadM Int32
forall a. (Integral a, Bits a) => ReadM a
integralReader
  getMetavar :: FilePath
getMetavar = FilePath
"INTEGER"

instance HasCLReader Int16 where
  getReader :: ReadM Int16
getReader = ReadM Int16
forall a. (Integral a, Bits a) => ReadM a
integralReader
  getMetavar :: FilePath
getMetavar = FilePath
"INTEGER"

instance HasCLReader Int8 where
  getReader :: ReadM Int8
getReader = ReadM Int8
forall a. (Integral a, Bits a) => ReadM a
integralReader
  getMetavar :: FilePath
getMetavar = FilePath
"INTEGER"

instance HasCLReader Int where
  getReader :: ReadM Int
getReader = ReadM Int
forall a. (Integral a, Bits a) => ReadM a
integralReader
  getMetavar :: FilePath
getMetavar = FilePath
"INTEGER"

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

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

-- | Parse a number, checking for overflows and other stuff.
integralReader :: (Integral a, Bits a) => Opt.ReadM a
integralReader :: forall a. (Integral a, Bits a) => ReadM a
integralReader = do
  Integer
int <- forall a. Read a => ReadM a
Opt.auto @Integer
  Integer -> Maybe a
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
fromIntegralMaybe Integer
int
    Maybe a -> (Maybe a -> ReadM a) -> ReadM a
forall a b. a -> (a -> b) -> b
& ReadM a -> (a -> ReadM a) -> Maybe a -> ReadM a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> ReadM a
forall a. FilePath -> ReadM a
readerError FilePath
errorMsg) a -> ReadM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    errorMsg :: FilePath
errorMsg = FilePath
"failed to parse command-line numeric argument due to overflow/underflow"

-- | 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 :: forall a.
(Buildable a, HasCLReader a) =>
Maybe a -> ("name" :! FilePath) -> ("help" :! FilePath) -> Parser a
mkCLOptionParser Maybe a
defValue "name" :! FilePath
name "help" :! FilePath
hInfo =
  Maybe a
-> ("name" :! FilePath)
-> ("help" :! FilePath)
-> [Mod OptionFields a]
-> Parser a
forall a.
(Buildable a, HasCLReader a) =>
Maybe a
-> ("name" :! FilePath)
-> ("help" :! FilePath)
-> [Mod OptionFields a]
-> Parser a
mkCLOptionParserExt Maybe a
defValue "name" :! FilePath
name "help" :! FilePath
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 :: forall a.
(Buildable a, HasCLReader a) =>
Maybe a
-> ("name" :! FilePath)
-> ("help" :! FilePath)
-> [Mod OptionFields a]
-> Parser a
mkCLOptionParserExt Maybe a
defValue (Name "name" -> ("name" :! FilePath) -> FilePath
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "name" (Name "name")
Name "name"
#name -> FilePath
name) (Name "help" -> ("help" :! FilePath) -> FilePath
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "help" (Name "help")
Name "help"
#help -> FilePath
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
$
    FilePath -> Mod OptionFields a
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar (forall a. HasCLReader a => FilePath
getMetavar @a) Mod OptionFields a -> [Mod OptionFields a] -> [Mod OptionFields a]
forall a. a -> [a] -> [a]
:
    FilePath -> Mod OptionFields a
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
name Mod OptionFields a -> [Mod OptionFields a] -> [Mod OptionFields a]
forall a. a -> [a] -> [a]
:
    FilePath -> Mod OptionFields a
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
hInfo Mod OptionFields a -> [Mod OptionFields a] -> [Mod OptionFields a]
forall a. a -> [a] -> [a]
:
    (a -> FilePath) -> Maybe a -> Mod OptionFields a
forall (f :: * -> *) a.
HasValue f =>
(a -> FilePath) -> Maybe a -> Mod f a
maybeAddDefault a -> FilePath
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 :: forall a.
(Buildable a, HasCLReader a) =>
Maybe a -> ("help" :! FilePath) -> Parser a
mkCLArgumentParser Maybe a
defValue "help" :! FilePath
hInfo = Maybe a
-> ("help" :! FilePath) -> [Mod ArgumentFields a] -> Parser a
forall a.
(Buildable a, HasCLReader a) =>
Maybe a
-> ("help" :! FilePath) -> [Mod ArgumentFields a] -> Parser a
mkCLArgumentParserExt Maybe a
defValue "help" :! FilePath
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 :: forall a.
(Buildable a, HasCLReader a) =>
Maybe a
-> ("help" :! FilePath) -> [Mod ArgumentFields a] -> Parser a
mkCLArgumentParserExt Maybe a
defValue (Name "help" -> ("help" :! FilePath) -> FilePath
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "help" (Name "help")
Name "help"
#help -> FilePath
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
$
    FilePath -> Mod ArgumentFields a
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar (forall a. HasCLReader a => FilePath
getMetavar @a) Mod ArgumentFields a
-> [Mod ArgumentFields a] -> [Mod ArgumentFields a]
forall a. a -> [a] -> [a]
:
    FilePath -> Mod ArgumentFields a
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
hInfo Mod ArgumentFields a
-> [Mod ArgumentFields a] -> [Mod ArgumentFields a]
forall a. a -> [a] -> [a]
:
    (a -> FilePath) -> Maybe a -> Mod ArgumentFields a
forall (f :: * -> *) a.
HasValue f =>
(a -> FilePath) -> Maybe a -> Mod f a
maybeAddDefault a -> FilePath
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 :: forall a. FilePath -> Parser a -> FilePath -> Mod CommandFields a
mkCommandParser FilePath
commandName Parser a
parser FilePath
desc =
  FilePath -> ParserInfo a -> Mod CommandFields a
forall a. FilePath -> ParserInfo a -> Mod CommandFields a
Opt.command FilePath
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
$
  FilePath -> InfoMod a
forall a. FilePath -> InfoMod a
Opt.progDesc FilePath
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 :: forall a (name :: Symbol).
(Buildable a, HasCLReader a, KnownSymbol name) =>
Maybe a -> FilePath -> Parser (name :! a)
namedParser Maybe a
defValue FilePath
hInfo =
  ReadM (NamedF Identity a name)
-> Mod OptionFields (NamedF Identity a name)
-> Parser (NamedF Identity a name)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option (forall (x :: Symbol) a. IsLabel x a => a
fromLabel @name Name name -> ReadM a -> ReadM (NamedF Identity a name)
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 (NamedF Identity a name)
 -> Parser (NamedF Identity a name))
-> Mod OptionFields (NamedF Identity a name)
-> Parser (NamedF Identity a name)
forall a b. (a -> b) -> a -> b
$
    [Mod OptionFields (NamedF Identity a name)]
-> Mod OptionFields (NamedF Identity a name)
forall a. Monoid a => [a] -> a
mconcat
    [ FilePath -> Mod OptionFields (NamedF Identity a name)
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long (Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> FilePath) -> (FilePath -> Text) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toSpinal (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
name)
    , FilePath -> Mod OptionFields (NamedF Identity a name)
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar (forall a. HasCLReader a => FilePath
getMetavar @a)
    , FilePath -> Mod OptionFields (NamedF Identity a name)
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
hInfo
    , (NamedF Identity a name -> FilePath)
-> Maybe (NamedF Identity a name)
-> Mod OptionFields (NamedF Identity a name)
forall (f :: * -> *) a.
HasValue f =>
(a -> FilePath) -> Maybe a -> Mod f a
maybeAddDefault NamedF Identity a name -> FilePath
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (forall (x :: Symbol) a. IsLabel x a => a
fromLabel @name Name name -> Maybe a -> Maybe (NamedF Identity a name)
forall (m :: * -> *) (name :: Symbol) a.
Functor m =>
Name name -> m a -> m (NamedF Identity a name)
<:!> Maybe a
defValue)
    ]
  where
    name :: FilePath
name = Proxy name -> FilePath
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @name)