Internal.hs

module Options.Applicative.Builder.Internal (
  -- * Internals
  Mod(..),
  HasName(..),
  HasCompleter(..),
  OptionFields(..),
  FlagFields(..),
  CommandFields(..),
  ArgumentFields(..),
  DefaultProp(..),

  optionMod,
  fieldMod,

  baseProps,
  mkParser,
  mkOption,
  mkProps,

  internal
  ) where

import Control.Applicative (pure, (<*>), empty, (<|>))
import Control.Monad (mplus)
import Data.Monoid (Monoid(..))

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

data OptionFields a = OptionFields
  { optNames :: [OptName]
  , optCompleter :: Completer
  , optReader :: String -> Either ParseError a
  , optNoArgError :: ParseError }

data FlagFields a = FlagFields
  { flagNames :: [OptName]
  , flagActive :: a }

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

data ArgumentFields a = ArgumentFields
  { argCompleter :: Completer }

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

instance HasName OptionFields where
  name n fields = fields { optNames = n : optNames fields }

instance HasName FlagFields where
  name n fields = fields { flagNames = n : flagNames fields }

class HasCompleter f where
  modCompleter :: (Completer -> Completer) -> f a -> f a

instance HasCompleter OptionFields where
  modCompleter f p = p { optCompleter = f (optCompleter p) }

instance HasCompleter ArgumentFields where
  modCompleter f p = p { argCompleter = f (argCompleter p) }

-- mod --

data DefaultProp a = DefaultProp
  (Maybe a)
  (Maybe (a -> String))

instance Monoid (DefaultProp a) where
  mempty = DefaultProp Nothing Nothing
  mappend (DefaultProp d1 s1) (DefaultProp d2 s2) =
    DefaultProp (d1 `mplus` d2) (s1 `mplus` s2)

-- | An option modifier.
--
-- Option modifiers are values that represent a modification of the properties
-- of an option.
--
-- The type parameter @a@ is the return type of the option, while @f@ is a
-- record containing its properties (e.g. 'OptionFields' for regular options,
-- 'FlagFields' for flags, etc...).
--
-- An option modifier consists of 3 elements:
--
--  - A field modifier, of the form @f a -> f a@. These are essentially
--  (compositions of) setters for some of the properties supported by @f@.
--
--  - An optional default value and function to display it.
--
--  - A property modifier, of the form @OptProperties -> OptProperties@. This
--  is just like the field modifier, but for properties applicable to any
--  option.
--
-- Modifiers are instances of 'Monoid', and can be composed as such.
--
-- You rarely need to deal with modifiers directly, as most of the times it is
-- sufficient to pass them to builders (such as 'strOption' or 'flag') to
-- create options (see 'Options.Applicative.Builder').
data Mod f a = Mod (f a -> f a)
                   (DefaultProp a)
                   (OptProperties -> OptProperties)

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

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

instance Monoid (Mod f a) where
  mempty = Mod id mempty id
  Mod f1 d1 g1 `mappend` Mod f2 d2 g2
    = Mod (f2 . f1) (d2 `mappend` d1) (g2 . g1)

-- | Base default properties.
baseProps :: OptProperties
baseProps = OptProperties
  { propMetaVar = ""
  , propVisibility = Visible
  , propHelp = ""
  , propShowDefault = Nothing }

mkParser :: DefaultProp a
         -> (OptProperties -> OptProperties)
         -> OptReader a
         -> Parser a
mkParser d@(DefaultProp def _) g rdr = liftOpt opt <|> maybe empty pure def
  where
    opt = mkOption d g rdr

mkOption :: DefaultProp a
         -> (OptProperties -> OptProperties)
         -> OptReader a
         -> Option a
mkOption d g rdr = Option rdr (mkProps d g)

mkProps :: DefaultProp a
        -> (OptProperties -> OptProperties)
        -> OptProperties
mkProps (DefaultProp def sdef) g = props
  where
    props = (g baseProps)
      { propShowDefault = sdef <*> def }

-- | Hide this option from the help text
internal :: Mod f a
internal = optionMod $ \p -> p { propVisibility = Internal }