{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Example usage of this module:
--
-- > -- options.hs
-- >
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > import Turtle
-- >
-- > parser :: Parser (Text, Int)
-- > parser = (,) <$> optText "name" 'n' "Your first name"
-- >              <*> optInt  "age"  'a' "Your current age"
-- >
-- > main = do
-- >     (name, age) <- options "Greeting script" parser
-- >     echo (repr (format ("Hello there, "%s) name))
-- >     echo (repr (format ("You are "%d%" years old") age))
--
-- > $ ./options --name John --age 42
-- > Hello there, John
-- > You are 42 years old
--
-- > $ ./options --help
-- > Greeting script
-- >
-- > Usage: options (-n|--name NAME) (-a|--age AGE)
-- >
-- > Available options:
-- >  -h,--help                Show this help text
-- >  --name NAME              Your first name
-- >  --age AGE                Your current age
--
-- See the "Turtle.Tutorial" module which contains more examples on how to use
-- command-line parsing.

module Turtle.Options
    ( -- * Types
      Parser
    , ArgName(..)
    , CommandName(..)
    , ShortName
    , Description(..)
    , HelpMessage(..)

      -- * Flag-based option parsers
    , switch
    , optText
    , optLine
    , optInt
    , optInteger
    , optDouble
    , optPath
    , optRead
    , opt

    -- * Positional argument parsers
    , argText
    , argLine
    , argInt
    , argInteger
    , argDouble
    , argPath
    , argRead
    , arg

      -- * Consume parsers
    , subcommand
    , subcommandGroup
    , options
    , optionsExt

    ) where

import Data.Monoid
import Data.Foldable
import Data.String (IsString)
import Text.Read (readMaybe)
import Data.Text (Text)
import Data.Optional
import Control.Applicative
import Control.Monad.IO.Class
import Options.Applicative (Parser)
import Text.PrettyPrint.ANSI.Leijen (Doc, displayS, renderCompact)
import Turtle.Line (Line)

import qualified Data.Text as Text
import qualified Options.Applicative as Opts
import qualified Options.Applicative.Types as Opts
import qualified Turtle.Line

-- | Parse the given options from the command line
options :: MonadIO io => Description -> Parser a -> io a
options :: forall (io :: * -> *) a.
MonadIO io =>
Description -> Parser a -> io a
options Description
desc Parser a
parser = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    forall a b. (a -> b) -> a -> b
$ forall a. ParserPrefs -> ParserInfo a -> IO a
Opts.customExecParser (PrefsMod -> ParserPrefs
Opts.prefs PrefsMod
prefs)
    forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> InfoMod a -> ParserInfo a
Opts.info (forall a. Parser (a -> a)
Opts.helper forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
parser)
                (forall a. Maybe Doc -> InfoMod a
Opts.headerDoc (forall a. a -> Maybe a
Just (Description -> Doc
getDescription Description
desc)))
  where
    prefs :: Opts.PrefsMod
#if MIN_VERSION_optparse_applicative(0,13,0)
    prefs :: PrefsMod
prefs = PrefsMod
Opts.showHelpOnError forall a. Semigroup a => a -> a -> a
<> PrefsMod
Opts.showHelpOnEmpty
#else
    prefs = Opts.showHelpOnError
#endif

{-| Parse the given options from the command line and add additional information

    Extended version of @options@ with program version header and footer information
-}
optionsExt :: MonadIO io => Header -> Footer  -> Description ->  Version -> Parser a -> io a
optionsExt :: forall (io :: * -> *) a.
MonadIO io =>
Header -> Footer -> Description -> Version -> Parser a -> io a
optionsExt Header
header Footer
footer Description
desc Version
version Parser a
parser = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    forall a b. (a -> b) -> a -> b
$ forall a. ParserPrefs -> ParserInfo a -> IO a
Opts.customExecParser (PrefsMod -> ParserPrefs
Opts.prefs PrefsMod
prefs)
    forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> InfoMod a -> ParserInfo a
Opts.info (forall a. Parser (a -> a)
Opts.helper forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Parser (a -> a)
versionOption forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
parser)
                (forall a. Maybe Doc -> InfoMod a
Opts.headerDoc (forall a. a -> Maybe a
Just (Header -> Doc
getHeader Header
header)) forall a. Semigroup a => a -> a -> a
<>
                 forall a. Maybe Doc -> InfoMod a
Opts.footerDoc (forall a. a -> Maybe a
Just (Footer -> Doc
getFooter Footer
footer)) forall a. Semigroup a => a -> a -> a
<>
                 forall a. Maybe Doc -> InfoMod a
Opts.progDescDoc (forall a. a -> Maybe a
Just (Description -> Doc
getDescription Description
desc)))
  where
    versionOption :: Parser (a -> a)
versionOption =
      forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
Opts.infoOption
        (Version -> String
Text.unpack Version
version)
        (forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long String
"version" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
Opts.help String
"Show version")
    prefs :: Opts.PrefsMod
#if MIN_VERSION_optparse_applicative(0,13,0)
    prefs :: PrefsMod
prefs = PrefsMod
Opts.showHelpOnError forall a. Semigroup a => a -> a -> a
<> PrefsMod
Opts.showHelpOnEmpty
#else
    prefs = Opts.showHelpOnError
#endif


{-| The name of a command-line argument

    This is used to infer the long name and metavariable for the command line
    flag.  For example, an `ArgName` of @\"name\"@ will create a @--name@ flag
    with a @NAME@ metavariable
-}
newtype ArgName = ArgName { ArgName -> Version
getArgName :: Text }
    deriving (String -> ArgName
forall a. (String -> a) -> IsString a
fromString :: String -> ArgName
$cfromString :: String -> ArgName
IsString)

-- | The short one-character abbreviation for a flag (i.e. @-n@)
type ShortName = Char

{-| The name of a sub-command

    This is lower-cased to create a sub-command.  For example, a `CommandName` of
    @\"Name\"@ will parse `name` on the command line before parsing the
    remaining arguments using the command's subparser.
-}
newtype CommandName = CommandName { CommandName -> Version
getCommandName :: Text }
    deriving (String -> CommandName
forall a. (String -> a) -> IsString a
fromString :: String -> CommandName
$cfromString :: String -> CommandName
IsString)

{-| A brief description of what your program does

    This description will appear in the header of the @--help@ output
-}
newtype Description = Description { Description -> Doc
getDescription :: Doc }
    deriving (String -> Description
forall a. (String -> a) -> IsString a
fromString :: String -> Description
$cfromString :: String -> Description
IsString)

{-| Header of the program

    This description will appear in the header of the @--help@ output
-}
newtype Header = Header { Header -> Doc
getHeader :: Doc }
    deriving (String -> Header
forall a. (String -> a) -> IsString a
fromString :: String -> Header
$cfromString :: String -> Header
IsString)
{-| Footer of the program

    This description will appear in the footer of the @--help@ output
-}
newtype Footer = Fotter { Footer -> Doc
getFooter :: Doc }
    deriving (String -> Footer
forall a. (String -> a) -> IsString a
fromString :: String -> Footer
$cfromString :: String -> Footer
IsString)

-- | Program Version
type Version = Text
{-| A helpful message explaining what a flag does

    This will appear in the @--help@ output
-}
newtype HelpMessage = HelpMessage { HelpMessage -> Version
getHelpMessage :: Text }
    deriving (String -> HelpMessage
forall a. (String -> a) -> IsString a
fromString :: String -> HelpMessage
$cfromString :: String -> HelpMessage
IsString)

{-| This parser returns `True` if the given flag is set and `False` if the
    flag is absent
-}
switch
    :: ArgName
    -> ShortName
    -> Optional HelpMessage
    -> Parser Bool
switch :: ArgName -> ShortName -> Optional HelpMessage -> Parser Bool
switch ArgName
argName ShortName
c Optional HelpMessage
helpMessage
   = Mod FlagFields Bool -> Parser Bool
Opts.switch
   forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgName -> Version
getArgName) ArgName
argName
  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => ShortName -> Mod f a
Opts.short ShortName
c
  forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (f :: * -> *) a. String -> Mod f a
Opts.help forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. HelpMessage -> Version
getHelpMessage) Optional HelpMessage
helpMessage

{- | Build a flag-based option parser for any type by providing a `Text`-parsing
     function
-}
opt :: (Text -> Maybe a)
    -> ArgName
    -> ShortName
    -> Optional HelpMessage
    -> Parser a
opt :: forall a.
(Version -> Maybe a)
-> ArgName -> ShortName -> Optional HelpMessage -> Parser a
opt Version -> Maybe a
argParse ArgName
argName ShortName
c Optional HelpMessage
helpMessage
   = forall a. ReadM a -> Mod OptionFields a -> Parser a
Opts.option (forall a. (Version -> Maybe a) -> ReadM a
argParseToReadM Version -> Maybe a
argParse)
   forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar (Version -> String
Text.unpack (Version -> Version
Text.toUpper (ArgName -> Version
getArgName ArgName
argName)))
  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long (Version -> String
Text.unpack (ArgName -> Version
getArgName ArgName
argName))
  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => ShortName -> Mod f a
Opts.short ShortName
c
  forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (f :: * -> *) a. String -> Mod f a
Opts.help forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. HelpMessage -> Version
getHelpMessage) Optional HelpMessage
helpMessage

-- | Parse any type that implements `Read`
optRead :: Read a => ArgName -> ShortName -> Optional HelpMessage -> Parser a
optRead :: forall a.
Read a =>
ArgName -> ShortName -> Optional HelpMessage -> Parser a
optRead = forall a.
(Version -> Maybe a)
-> ArgName -> ShortName -> Optional HelpMessage -> Parser a
opt (forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
Text.unpack)

-- | Parse an `Int` as a flag-based option
optInt :: ArgName -> ShortName -> Optional HelpMessage -> Parser Int
optInt :: ArgName -> ShortName -> Optional HelpMessage -> Parser Int
optInt = forall a.
Read a =>
ArgName -> ShortName -> Optional HelpMessage -> Parser a
optRead

-- | Parse an `Integer` as a flag-based option
optInteger :: ArgName -> ShortName -> Optional HelpMessage -> Parser Integer
optInteger :: ArgName -> ShortName -> Optional HelpMessage -> Parser Integer
optInteger = forall a.
Read a =>
ArgName -> ShortName -> Optional HelpMessage -> Parser a
optRead

-- | Parse a `Double` as a flag-based option
optDouble :: ArgName -> ShortName -> Optional HelpMessage -> Parser Double
optDouble :: ArgName -> ShortName -> Optional HelpMessage -> Parser Double
optDouble = forall a.
Read a =>
ArgName -> ShortName -> Optional HelpMessage -> Parser a
optRead

-- | Parse a `Text` value as a flag-based option
optText :: ArgName -> ShortName -> Optional HelpMessage -> Parser Text
optText :: ArgName -> ShortName -> Optional HelpMessage -> Parser Version
optText = forall a.
(Version -> Maybe a)
-> ArgName -> ShortName -> Optional HelpMessage -> Parser a
opt forall a. a -> Maybe a
Just

-- | Parse a `Line` value as a flag-based option
optLine :: ArgName -> ShortName -> Optional HelpMessage -> Parser Line
optLine :: ArgName -> ShortName -> Optional HelpMessage -> Parser Line
optLine = forall a.
(Version -> Maybe a)
-> ArgName -> ShortName -> Optional HelpMessage -> Parser a
opt Version -> Maybe Line
Turtle.Line.textToLine

-- | Parse a `FilePath` value as a flag-based option
optPath :: ArgName -> ShortName -> Optional HelpMessage -> Parser FilePath
optPath :: ArgName -> ShortName -> Optional HelpMessage -> Parser String
optPath ArgName
argName ShortName
short Optional HelpMessage
msg = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Version -> String
Text.unpack (ArgName -> ShortName -> Optional HelpMessage -> Parser Version
optText ArgName
argName ShortName
short Optional HelpMessage
msg)

{- | Build a positional argument parser for any type by providing a
    `Text`-parsing function
-}
arg :: (Text -> Maybe a)
    -> ArgName
    -> Optional HelpMessage
    -> Parser a
arg :: forall a.
(Version -> Maybe a) -> ArgName -> Optional HelpMessage -> Parser a
arg Version -> Maybe a
argParse ArgName
argName Optional HelpMessage
helpMessage
   = forall a. ReadM a -> Mod ArgumentFields a -> Parser a
Opts.argument (forall a. (Version -> Maybe a) -> ReadM a
argParseToReadM Version -> Maybe a
argParse)
   forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar (Version -> String
Text.unpack (Version -> Version
Text.toUpper (ArgName -> Version
getArgName ArgName
argName)))
  forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (f :: * -> *) a. String -> Mod f a
Opts.help forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. HelpMessage -> Version
getHelpMessage) Optional HelpMessage
helpMessage

-- | Parse any type that implements `Read` as a positional argument
argRead :: Read a => ArgName -> Optional HelpMessage -> Parser a
argRead :: forall a. Read a => ArgName -> Optional HelpMessage -> Parser a
argRead = forall a.
(Version -> Maybe a) -> ArgName -> Optional HelpMessage -> Parser a
arg (forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
Text.unpack)

-- | Parse an `Int` as a positional argument
argInt :: ArgName -> Optional HelpMessage -> Parser Int
argInt :: ArgName -> Optional HelpMessage -> Parser Int
argInt = forall a. Read a => ArgName -> Optional HelpMessage -> Parser a
argRead

-- | Parse an `Integer` as a positional argument
argInteger :: ArgName -> Optional HelpMessage -> Parser Integer
argInteger :: ArgName -> Optional HelpMessage -> Parser Integer
argInteger = forall a. Read a => ArgName -> Optional HelpMessage -> Parser a
argRead

-- | Parse a `Double` as a positional argument
argDouble :: ArgName -> Optional HelpMessage -> Parser Double
argDouble :: ArgName -> Optional HelpMessage -> Parser Double
argDouble = forall a. Read a => ArgName -> Optional HelpMessage -> Parser a
argRead

-- | Parse a `Text` as a positional argument
argText :: ArgName -> Optional HelpMessage -> Parser Text
argText :: ArgName -> Optional HelpMessage -> Parser Version
argText = forall a.
(Version -> Maybe a) -> ArgName -> Optional HelpMessage -> Parser a
arg forall a. a -> Maybe a
Just

-- | Parse a `Line` as a positional argument
argLine :: ArgName -> Optional HelpMessage -> Parser Line
argLine :: ArgName -> Optional HelpMessage -> Parser Line
argLine = forall a.
(Version -> Maybe a) -> ArgName -> Optional HelpMessage -> Parser a
arg Version -> Maybe Line
Turtle.Line.textToLine

-- | Parse a `FilePath` as a positional argument
argPath :: ArgName -> Optional HelpMessage -> Parser FilePath
argPath :: ArgName -> Optional HelpMessage -> Parser String
argPath ArgName
argName Optional HelpMessage
msg = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Version -> String
Text.unpack (ArgName -> Optional HelpMessage -> Parser Version
argText ArgName
argName Optional HelpMessage
msg)

argParseToReadM :: (Text -> Maybe a) -> Opts.ReadM a
argParseToReadM :: forall a. (Version -> Maybe a) -> ReadM a
argParseToReadM Version -> Maybe a
f = do
    String
s <- ReadM String
Opts.readerAsk
    case Version -> Maybe a
f (String -> Version
Text.pack String
s) of
        Just a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
        Maybe a
Nothing -> forall a. ParseError -> ReadM a
Opts.readerAbort (Maybe String -> ParseError
Opts.ShowHelpText forall a. Maybe a
Nothing)

{-| Create a sub-command that parses `CommandName` and then parses the rest
    of the command-line arguments

    The sub-command will have its own `Description` and help text
-}
subcommand :: CommandName -> Description -> Parser a -> Parser a
subcommand :: forall a. CommandName -> Description -> Parser a -> Parser a
subcommand CommandName
cmdName Description
desc Parser a
p =
    forall a. Mod CommandFields a -> Parser a
Opts.hsubparser (forall a. String -> ParserInfo a -> Mod CommandFields a
Opts.command String
name ParserInfo a
info forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar String
name)
  where
    name :: String
name = Version -> String
Text.unpack (CommandName -> Version
getCommandName CommandName
cmdName)

    info :: ParserInfo a
info = forall a. Parser a -> InfoMod a -> ParserInfo a
Opts.info Parser a
p (forall a. Maybe Doc -> InfoMod a
Opts.progDescDoc (forall a. a -> Maybe a
Just (Description -> Doc
getDescription Description
desc)))

-- | Create a named group of sub-commands
subcommandGroup :: forall a. Description -> [(CommandName, Description, Parser a)] -> Parser a
subcommandGroup :: forall a.
Description -> [(CommandName, Description, Parser a)] -> Parser a
subcommandGroup Description
name [(CommandName, Description, Parser a)]
cmds =
    forall a. Mod CommandFields a -> Parser a
Opts.hsubparser (forall a. String -> Mod CommandFields a
Opts.commandGroup String
name' forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (CommandName, Description, Parser a) -> Mod CommandFields a
f [(CommandName, Description, Parser a)]
cmds forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar String
metavar)
  where
    f :: (CommandName, Description, Parser a) -> Opts.Mod Opts.CommandFields a
    f :: (CommandName, Description, Parser a) -> Mod CommandFields a
f (CommandName
cmdName, Description
desc, Parser a
p) =
        forall a. String -> ParserInfo a -> Mod CommandFields a
Opts.command
            (Version -> String
Text.unpack (CommandName -> Version
getCommandName CommandName
cmdName))
            (forall a. Parser a -> InfoMod a -> ParserInfo a
Opts.info Parser a
p (forall a. Maybe Doc -> InfoMod a
Opts.progDescDoc (forall a. a -> Maybe a
Just (Description -> Doc
getDescription Description
desc))))

    metavar :: String
    metavar :: String
metavar = Version -> String
Text.unpack (Version -> [Version] -> Version
Text.intercalate Version
" | " (forall a b. (a -> b) -> [a] -> [b]
map (CommandName, Description, Parser a) -> Version
g [(CommandName, Description, Parser a)]
cmds))
      where
        g :: (CommandName, Description, Parser a) -> Text
        g :: (CommandName, Description, Parser a) -> Version
g (CommandName
cmdName, Description
_, Parser a
_) = CommandName -> Version
getCommandName CommandName
cmdName

    name' :: String
    name' :: String
name' = SimpleDoc -> ShowS
displayS (Doc -> SimpleDoc
renderCompact (Description -> Doc
getDescription Description
name)) String
""