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

-- | 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 printer = maybe mempty addDefault
  where
    addDefault v = value v <> showDefaultWith printer

-- | Parser for path to a file where output will be writen.
outputOption :: Opt.Parser (Maybe FilePath)
outputOption = optional . strOption $
  Opt.short 'o' <>
  long "output" <>
  metavar "FILEPATH" <>
  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 = Opt.auto
  getMetavar = "NATURAL NUMBER"

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

instance HasCLReader Word16 where
  getReader = Opt.auto
  -- ↓ Same as for 'Natural', the user usually does not care whether
  -- the number is bounded (reasonable values should fit anyway).
  getMetavar = "NATURAL NUMBER"

instance HasCLReader Integer where
  getReader = Opt.auto
  getMetavar = "INTEGER"

instance HasCLReader Int where
  getReader = Opt.auto
  getMetavar = "INTEGER"

instance HasCLReader Text where
  getReader = Opt.str
  getMetavar = "STRING"

instance HasCLReader String where
  getReader = Opt.str
  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 defValue name hInfo =
  mkCLOptionParserExt defValue name 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 defValue (arg #name -> name) (arg #help -> hInfo) mods =
  option getReader $ mconcat $
    metavar (getMetavar @a) :
    long name :
    help hInfo :
    maybeAddDefault pretty defValue :
    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 defValue hInfo = mkCLArgumentParserExt defValue 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 defValue (arg #help -> hInfo) mods =
  Opt.argument getReader $ mconcat $
    metavar (getMetavar @a) :
    help hInfo :
    maybeAddDefault pretty defValue :
    mods

-- | 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 :: Kind.Type) (name :: Symbol).
     (Buildable a, HasCLReader a, KnownSymbol name)
  => Maybe a
  -> String
  -> Opt.Parser (name :! a)
namedParser defValue hInfo =
  option ((Name @name) <.!> getReader) $
    mconcat
    [ long (toString . toSpinal . toText $ name)
    , metavar (getMetavar @a)
    , help hInfo
    , maybeAddDefault pretty (Name @name <.!> defValue)
    ]
  where
    name = symbolVal (Proxy @name)