{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
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,
  switch,
  nullOption,
  strOption,
  option,

  -- * Modifiers
  short,
  long,
  help,
  value,
  metavar,
  reader,
  hide,
  multi,
  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
  ) where

import Control.Applicative
import Control.Category
import Control.Monad
import Data.Lens.Common
import Data.Lens.Template

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

import Prelude hiding (id, (.))

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

data FlagFields a = FlagFields
  { _flagNames :: [OptName] }

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

$( makeLenses [ ''OptionFields
              , ''FlagFields
              , ''CommandFields ] )

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 r a b = Mod (f r -> f r) (Option r a -> Option r b)

optionMod :: (Option r a -> Option r b) -> Mod f r a b
optionMod = Mod id

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

instance Category (Mod f r) 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 r a a
short = fieldMod . name . OptShort

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

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

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

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

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

-- | Hide this option.
hide :: Mod f r a a
hide = optionMod $ optShow^=False

-- | Create a multi-valued option.
multi :: Mod f r a [a]
multi = optionMod f
  where
    f opt = mkOptGroup []
      where
        mkOptGroup xs = opt
          { _optDefault = Just xs
          , _optCont = mkCont xs }
        mkCont xs r = do
          p' <- getL optCont opt r
          x <- evalParser p'
          return $ liftOpt (mkOptGroup (x:xs))

-- | 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 :: (a -> b) -> Mod f r a b
transform f = optionMod $ fmap f

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

-- parsers --

-- | Base default option.
baseOpts :: OptReader a -> Option a a
baseOpts opt = Option
  { _optMain = opt
  , _optMetaVar = ""
  , _optShow = True
  , _optCont = Just . pure
  , _optHelp = ""
  , _optDefault = Nothing }

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

-- | Builder for an argument parser.
argument :: (String -> Maybe a) -> Mod f a a b -> Parser b
argument p (Mod _ g) = liftOpt . g . baseOpts $ ArgReader p

-- | Builder for an argument list parser. All arguments are collected and
-- returned as a list.
arguments :: (String -> Maybe a) -> Mod f a [a] b -> Parser b
arguments p m = argument p (m . multi)

-- | 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 a b      -- ^ option modifier
     -> Parser b
flag defv actv (Mod f g) = liftOpt . g . set_default . baseOpts $ rdr
  where
    rdr = let fields = f (FlagFields [])
          in FlagReader (fields^.flagNames) actv
    set_default = optDefault ^= Just defv

-- | Builder for a boolean flag.
--
-- > switch = flag False True
switch :: Mod FlagFields Bool 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 a b -> Parser b
nullOption (Mod f g) = liftOpt . g . baseOpts $ rdr
  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 String a -> Parser a
strOption m = nullOption $ m . reader str

-- | Builder for an option using the 'auto' reader.
option :: Read a => Mod OptionFields a 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
      , _infoFullDesc = True
      , _infoHeader = ""
      , _infoProgDesc = ""
      , _infoFooter = ""
      , _infoFailureCode = 1 }

-- | 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 (.)