-- 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 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 = integralReader
  getMetavar = "NATURAL NUMBER"

instance HasCLReader Word64 where
  getReader = 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 = "NATURAL NUMBER"

instance HasCLReader Word32 where
  getReader = integralReader
  getMetavar = "NATURAL NUMBER"

instance HasCLReader Word16 where
  getReader = integralReader
  getMetavar = "NATURAL NUMBER"

instance HasCLReader Word8 where
  getReader = integralReader
  getMetavar = "NATURAL NUMBER"

instance HasCLReader Word where
  getReader = integralReader
  getMetavar = "NATURAL NUMBER"

instance HasCLReader Integer where
  getReader = integralReader
  getMetavar = "INTEGER"

instance HasCLReader Int64 where
  getReader = integralReader
  getMetavar = "INTEGER"

instance HasCLReader Int32 where
  getReader = integralReader
  getMetavar = "INTEGER"

instance HasCLReader Int16 where
  getReader = integralReader
  getMetavar = "INTEGER"

instance HasCLReader Int8 where
  getReader = integralReader
  getMetavar = "INTEGER"

instance HasCLReader Int where
  getReader = integralReader
  getMetavar = "INTEGER"

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

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

-- | Parse a number, checking for overflows and other stuff.
integralReader :: (Integral a, Bits a) => Opt.ReadM a
integralReader = do
  int <- Opt.auto @Integer
  fromIntegralMaybe int
    & maybe (readerError errorMsg) pure
  where
    errorMsg = "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 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

-- | Parser for command options
mkCommandParser :: String -> Opt.Parser a -> String -> Opt.Mod Opt.CommandFields a
mkCommandParser commandName parser desc =
  Opt.command commandName $
  Opt.info (Opt.helper <*> parser) $
  Opt.progDesc 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 defValue hInfo =
  option (fromLabel @name <:!> getReader) $
    mconcat
    [ long (toString . toSpinal . toText $ name)
    , metavar (getMetavar @a)
    , help hInfo
    , maybeAddDefault pretty (fromLabel @name <:!> defValue)
    ]
  where
    name = symbolVal (Proxy @name)