{-# LANGUAGE DeriveFunctor #-}
module Options.Applicative.Builder (
  -- * Parser builders
  --
  -- | This module contains utility functions and combinators to create parsers
  -- for individual options.
  --
  -- Each parser builder takes an option modifier, which can be specified by
  -- composing basic modifiers using '&' and 'idm' (which are just convenient
  -- synonyms for the 'Category' operations 'Control.Category.>>>' and
  -- 'Control.Category.id').
  --
  -- For example:
  --
  --
  -- > out = strOption
  -- >     ( long "output"
  -- >     & short 'o'
  -- >     & metavar "FILENAME" )
  --
  --
  -- creates a parser for an option called \"output\".
  subparser,
  argument,
  arguments,
  flag,
  flag',
  switch,
  nullOption,
  strOption,
  option,

  -- * Modifiers
  short,
  long,
  help,
  value,
  metavar,
  reader,
  hidden,
  internal,
  transform,
  command,
  idm,
  (&),

  -- * Readers
  --
  -- | A collection of basic 'Option' readers.
  auto,
  str,
  disabled,

  -- * Internals
  Mod,
  HasName,
  OptionFields,
  FlagFields,
  CommandFields,

  -- * Builder for 'ParserInfo'
  InfoMod,
  fullDesc,
  header,
  progDesc,
  footer,
  failureCode,
  info,

  -- * Builder for 'ParserPrefs'
  PrefsMod,
  multiSuffix,
  prefs
  ) where

import Control.Applicative
import Control.Category
import Control.Monad
import Data.Functor.Identity
import Data.Lens.Common

import Options.Applicative.Common
import Options.Applicative.Types

import Prelude hiding (id, (.))

data OptionFields a = OptionFields
  { _optNames :: [OptName]
  , _optReader :: String -> Maybe a }
  deriving Functor

data FlagFields a = FlagFields
  { _flagNames :: [OptName]
  , _flagActive :: a }
  deriving Functor

data CommandFields a = CommandFields
  { _cmdCommands :: [(String, ParserInfo a)] }
  deriving Functor

optNames :: Lens (OptionFields a) [OptName]
optNames = lens _optNames $ \x o -> o { _optNames = x }

optReader :: Lens (OptionFields a) (String -> Maybe a)
optReader = lens _optReader $ \x o -> o { _optReader = x }

flagNames :: Lens (FlagFields a) [OptName]
flagNames = lens _flagNames $ \x o -> o { _flagNames = x }

cmdCommands :: Lens (CommandFields a) [(String, ParserInfo a)]
cmdCommands = lens _cmdCommands $ \x o -> o { _cmdCommands = x }

class HasName f where
  name :: OptName -> f a -> f a

instance HasName OptionFields where
  name n = modL optNames (n:)

instance HasName FlagFields where
  name n = modL flagNames (n:)

-- mod --

data Mod f a b = Mod (f a -> f b) (OptProperties a -> OptProperties b)

optionMod :: (OptProperties a -> OptProperties a) -> Mod f a a
optionMod = Mod id

fieldMod :: (f a -> f a) -> Mod f a a
fieldMod f = Mod f id

instance Category (Mod f) where
  id = Mod id id
  Mod f1 g1 . Mod f2 g2 = Mod (f1 . f2) (g1 . g2)

-- readers --

-- | 'Option' reader based on the 'Read' type class.
auto :: Read a => String -> Maybe a
auto arg = case reads arg of
  [(r, "")] -> Just r
  _         -> Nothing

-- | String 'Option' reader.
str :: String -> Maybe String
str = Just

-- | Null 'Option' reader. All arguments will fail validation.
disabled :: String -> Maybe a
disabled = const Nothing

-- modifiers --

-- | Specify a short name for an option.
short :: HasName f => Char -> Mod f a a
short = fieldMod . name . OptShort

-- | Specify a long name for an option.
long :: HasName f => String -> Mod f a a
long = fieldMod . name . OptLong

-- | Specify a default value for an option.
value :: a -> Mod f a a
value = optionMod . setL propDefault . Just

-- | Specify the help text for an option.
help :: String -> Mod f a a
help = optionMod . setL propHelp

-- | Specify the 'Option' reader.
reader :: (String -> Maybe a) -> Mod OptionFields a a
reader = fieldMod . setL optReader

-- | Specify the metavariable.
metavar :: String -> Mod f a a
metavar = optionMod . setL propMetaVar

-- | Hide this option from the brief description.
hidden :: Mod f a a
hidden = optionMod $ propVisibility ^%= min Hidden

-- | Hide this option from the help text
internal :: Mod f a a
internal = optionMod $ propVisibility ^= Internal

-- | Apply a transformation to the return value of this option.
--
-- This can be used, for example, to provide a default value for
-- a required option, like:
--
-- >strOption
-- >( transform Just
-- >& value Nothing )
transform :: Functor f => (a -> b) -> Mod f a b
transform f = Mod (fmap f) (fmap f)

-- | Add a command to a subparser option.
command :: String -> ParserInfo a -> Mod CommandFields a a
command cmd pinfo = fieldMod $ cmdCommands^%=((cmd, pinfo):)

-- parsers --

-- | Base default properties.
baseProps :: OptProperties a
baseProps = OptProperties
  { _propMetaVar = ""
  , _propVisibility = Visible
  , _propHelp = ""
  , _propDefault = Nothing }

-- | Builder for a command parser. The 'command' modifier can be used to
-- specify individual commands.
subparser :: Mod CommandFields a b -> Parser b
subparser m = liftOpt $ Option rdr (g baseProps)
  where
    Mod f g = m . metavar "COMMAND"
    CommandFields cmds = f (CommandFields [])
    rdr = CmdReader (map fst cmds) (`lookup` cmds)

-- | Builder for an argument parser.
argument :: (String -> Maybe a) -> Mod Identity a b -> Parser b
argument p (Mod f g) = liftOpt $ Option (ArgReader p') (g baseProps)
  where p' s = fmap (runIdentity . f . Identity) (p s)

-- | Builder for an argument list parser. All arguments are collected and
-- returned as a list.
--
-- Note that arguments starting with @'-'@ are ignored.
--
-- This parser accepts a special argument: @--@. When a @--@ is found on the
-- command line, all following arguments are included in the result, even if
-- they start with @'-'@.
arguments :: (String -> Maybe a) -> Mod Identity a b -> Parser [b]
arguments p m = args
  where
    p' ('-':_) = Nothing
    p' s = p s

    args1 = ((Just <$> arg') <|> (ddash *> pure Nothing)) `BindP` \x -> case x of
      Nothing -> many arg
      Just a -> fmap (a:) args
    args = args1 <|> pure []

    arg' = argument p' m
    arg = argument p m

    ddash = argument (guard . (== "--")) internal

-- | Builder for a flag parser.
--
-- A flag that switches from a \"default value\" to an \"active value\" when
-- encountered. For a simple boolean value, use `switch` instead.
flag :: a                         -- ^ default value
     -> a                         -- ^ active value
     -> Mod FlagFields a b        -- ^ option modifier
     -> Parser b
flag defv actv m = flag' actv (m . value defv)

-- | Builder for a flag parser without a default value.
--
-- Same as 'flag', but with no default value. In particular, this flag will
-- never parse successfully by itself.
--
-- It still makes sense to use it as part of a composite parser. For example
--
-- > length <$> many (flag' () (short 't'))
--
-- is a parser that counts the number of "-t" arguments on the command line.
flag' :: a                         -- ^ active value
      -> Mod FlagFields a b        -- ^ option modifier
      -> Parser b
flag' actv (Mod f g) = liftOpt $ Option rdr (g baseProps)
  where
    rdr = let FlagFields ns actv' = f (FlagFields [] actv)
          in FlagReader ns actv'

-- | Builder for a boolean flag.
--
-- > switch = flag False True
switch :: Mod FlagFields Bool a -> Parser a
switch = flag False True

-- | Builder for an option with a null reader. A non-trivial reader can be
-- added using the 'reader' modifier.
nullOption :: Mod OptionFields a b -> Parser b
nullOption (Mod f g) = liftOpt $ Option rdr (g baseProps)
  where
    rdr = let fields = f (OptionFields [] disabled)
          in OptReader (fields^.optNames) (fields^.optReader)

-- | Builder for an option taking a 'String' argument.
strOption :: Mod OptionFields String a -> Parser a
strOption m = nullOption $ m . reader str

-- | Builder for an option using the 'auto' reader.
option :: Read a => Mod OptionFields a b -> Parser b
option m = nullOption $ m . reader auto

-- | Modifier for 'ParserInfo'.
newtype InfoMod a b = InfoMod
  { applyInfoMod :: ParserInfo a -> ParserInfo b }

instance Category InfoMod where
  id = InfoMod id
  m1 . m2 = InfoMod $ applyInfoMod m1 . applyInfoMod m2

-- | Specify a full description for this parser.
fullDesc :: InfoMod a a
fullDesc = InfoMod $ infoFullDesc^=True

-- | Specify a header for this parser.
header :: String -> InfoMod a a
header s = InfoMod $ infoHeader^=s

-- | Specify a footer for this parser.
footer :: String -> InfoMod a a
footer s = InfoMod $ infoFooter^=s

-- | Specify a short program description.
progDesc :: String -> InfoMod a a
progDesc s = InfoMod $ infoProgDesc^=s

-- | Specify an exit code if a parse error occurs.
failureCode :: Int -> InfoMod a a
failureCode n = InfoMod $ infoFailureCode^=n

-- | Create a 'ParserInfo' given a 'Parser' and a modifier.
info :: Parser a -> InfoMod a a -> ParserInfo a
info parser m = applyInfoMod m base
  where
    base = ParserInfo
      { _infoParser = parser
      , _infoDesc = ParserDesc
        { _descFull = True
        , _descProg = ""
        , _descHeader = ""
        , _descFooter = ""
        , _descFailureCode = 1
        }
      }

newtype PrefsModC a b = PrefsMod
  { applyPrefsMod :: a -> b }
  -- this newtype is just to define a Category instance, for consistency with
  -- the other modifiers; we're only going to use it with a = b = ParserPrefs

-- | Modifier for 'ParserPrefs'.
type PrefsMod = PrefsModC ParserPrefs ParserPrefs

instance Category PrefsModC where
  id = PrefsMod id
  m1 . m2 = PrefsMod $ applyPrefsMod m1 . applyPrefsMod m2

multiSuffix :: String -> PrefsMod
multiSuffix s = PrefsMod $ prefMultiSuffix ^= s

prefs :: PrefsMod -> ParserPrefs
prefs m = applyPrefsMod m base
  where
    base = ParserPrefs
      { _prefMultiSuffix = "" }

-- | Trivial option modifier.
idm :: Category hom => hom a a
idm = id

-- | Compose modifiers.
(&) :: Category hom => hom a b -> hom b c -> hom a c
(&) = flip (.)