module System.Console.CmdArgs.Explicit.Type where

import Control.Arrow
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import Data.Semigroup hiding (Arg)
import Prelude


-- | A name, either the name of a flag (@--/foo/@) or the name of a mode.
type Name = String

-- | A help message that goes with either a flag or a mode.
type Help = String

-- | The type of a flag, i.e. @--foo=/TYPE/@.
type FlagHelp = String


---------------------------------------------------------------------
-- UTILITY

-- | Parse a boolean, accepts as True: true yes on enabled 1.
parseBool :: String -> Maybe Bool
parseBool :: String -> Maybe Bool
parseBool String
s | String
ls String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
true  = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
            | String
ls String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
false = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
            | Bool
otherwise = Maybe Bool
forall a. Maybe a
Nothing
    where
        ls :: String
ls = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s
        true :: [String]
true = [String
"true",String
"yes",String
"on",String
"enabled",String
"1"]
        false :: [String]
false = [String
"false",String
"no",String
"off",String
"disabled",String
"0"]


---------------------------------------------------------------------
-- GROUPS

-- | A group of items (modes or flags). The items are treated as a list, but the
--   group structure is used when displaying the help message.
data Group a = Group
    {Group a -> [a]
groupUnnamed :: [a] -- ^ Normal items.
    ,Group a -> [a]
groupHidden :: [a] -- ^ Items that are hidden (not displayed in the help message).
    ,Group a -> [(String, [a])]
groupNamed :: [(Help, [a])] -- ^ Items that have been grouped, along with a description of each group.
    } deriving Int -> Group a -> String -> String
[Group a] -> String -> String
Group a -> String
(Int -> Group a -> String -> String)
-> (Group a -> String)
-> ([Group a] -> String -> String)
-> Show (Group a)
forall a. Show a => Int -> Group a -> String -> String
forall a. Show a => [Group a] -> String -> String
forall a. Show a => Group a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Group a] -> String -> String
$cshowList :: forall a. Show a => [Group a] -> String -> String
show :: Group a -> String
$cshow :: forall a. Show a => Group a -> String
showsPrec :: Int -> Group a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> Group a -> String -> String
Show

instance Functor Group where
    fmap :: (a -> b) -> Group a -> Group b
fmap a -> b
f (Group [a]
a [a]
b [(String, [a])]
c) = [b] -> [b] -> [(String, [b])] -> Group b
forall a. [a] -> [a] -> [(String, [a])] -> Group a
Group ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f [a]
a) ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f [a]
b) (((String, [a]) -> (String, [b]))
-> [(String, [a])] -> [(String, [b])]
forall a b. (a -> b) -> [a] -> [b]
map (([a] -> [b]) -> (String, [a]) -> (String, [b])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (([a] -> [b]) -> (String, [a]) -> (String, [b]))
-> ([a] -> [b]) -> (String, [a]) -> (String, [b])
forall a b. (a -> b) -> a -> b
$ (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f) [(String, [a])]
c)

instance Semigroup (Group a) where
    Group [a]
x1 [a]
x2 [(String, [a])]
x3 <> :: Group a -> Group a -> Group a
<> Group [a]
y1 [a]
y2 [(String, [a])]
y3 = [a] -> [a] -> [(String, [a])] -> Group a
forall a. [a] -> [a] -> [(String, [a])] -> Group a
Group ([a]
x1[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
y1) ([a]
x2[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
y2) ([(String, [a])]
x3[(String, [a])] -> [(String, [a])] -> [(String, [a])]
forall a. [a] -> [a] -> [a]
++[(String, [a])]
y3)

instance Monoid (Group a) where
    mempty :: Group a
mempty = [a] -> [a] -> [(String, [a])] -> Group a
forall a. [a] -> [a] -> [(String, [a])] -> Group a
Group [] [] []
    mappend :: Group a -> Group a -> Group a
mappend = Group a -> Group a -> Group a
forall a. Semigroup a => a -> a -> a
(<>)

-- | Convert a group into a list.
fromGroup :: Group a -> [a]
fromGroup :: Group a -> [a]
fromGroup (Group [a]
x [a]
y [(String, [a])]
z) = [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
y [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ ((String, [a]) -> [a]) -> [(String, [a])] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, [a]) -> [a]
forall a b. (a, b) -> b
snd [(String, [a])]
z

-- | Convert a list into a group, placing all fields in 'groupUnnamed'.
toGroup :: [a] -> Group a
toGroup :: [a] -> Group a
toGroup [a]
x = [a] -> [a] -> [(String, [a])] -> Group a
forall a. [a] -> [a] -> [(String, [a])] -> Group a
Group [a]
x [] []


---------------------------------------------------------------------
-- TYPES

-- | A mode. Do not use the 'Mode' constructor directly, instead
--   use 'mode' to construct the 'Mode' and then record updates.
--   Each mode has three main features:
--
--   * A list of submodes ('modeGroupModes')
--
--   * A list of flags ('modeGroupFlags')
--
--   * Optionally an unnamed argument ('modeArgs')
--
--  To produce the help information for a mode, either use 'helpText' or 'show'.
data Mode a = Mode
    {Mode a -> Group (Mode a)
modeGroupModes :: Group (Mode a) -- ^ The available sub-modes
    ,Mode a -> [String]
modeNames :: [Name] -- ^ The names assigned to this mode (for the root mode, this name is used as the program name)
    ,Mode a -> a
modeValue :: a -- ^ Value to start with
    ,Mode a -> a -> Either String a
modeCheck :: a -> Either String a -- ^ Check the value reprsented by a mode is correct, after applying all flags
    ,Mode a -> a -> Maybe [String]
modeReform :: a -> Maybe [String] -- ^ Given a value, try to generate the input arguments.
    ,Mode a -> Bool
modeExpandAt :: Bool -- ^ Expand @\@@ arguments with 'expandArgsAt', defaults to 'True', only applied if using an 'IO' processing function.
                          --   Only the root 'Mode's value will be used.
    ,Mode a -> String
modeHelp :: Help -- ^ Help text
    ,Mode a -> [String]
modeHelpSuffix :: [String] -- ^ A longer help suffix displayed after a mode
    ,Mode a -> ([Arg a], Maybe (Arg a))
modeArgs :: ([Arg a], Maybe (Arg a)) -- ^ The unnamed arguments, a series of arguments, followed optionally by one for all remaining slots
    ,Mode a -> Group (Flag a)
modeGroupFlags :: Group (Flag a) -- ^ Groups of flags
    }

-- | Extract the modes from a 'Mode'
modeModes :: Mode a -> [Mode a]
modeModes :: Mode a -> [Mode a]
modeModes = Group (Mode a) -> [Mode a]
forall a. Group a -> [a]
fromGroup (Group (Mode a) -> [Mode a])
-> (Mode a -> Group (Mode a)) -> Mode a -> [Mode a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mode a -> Group (Mode a)
forall a. Mode a -> Group (Mode a)
modeGroupModes

-- | Extract the flags from a 'Mode'
modeFlags :: Mode a -> [Flag a]
modeFlags :: Mode a -> [Flag a]
modeFlags = Group (Flag a) -> [Flag a]
forall a. Group a -> [a]
fromGroup (Group (Flag a) -> [Flag a])
-> (Mode a -> Group (Flag a)) -> Mode a -> [Flag a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mode a -> Group (Flag a)
forall a. Mode a -> Group (Flag a)
modeGroupFlags

-- | The 'FlagInfo' type has the following meaning:
--
--
-- >              FlagReq     FlagOpt      FlagOptRare/FlagNone
-- > -xfoo        -x=foo      -x=foo       -x -foo
-- > -x foo       -x=foo      -x foo       -x foo
-- > -x=foo       -x=foo      -x=foo       -x=foo
-- > --xx foo     --xx=foo    --xx foo     --xx foo
-- > --xx=foo     --xx=foo    --xx=foo     --xx=foo
data FlagInfo
    = FlagReq             -- ^ Required argument
    | FlagOpt String      -- ^ Optional argument
    | FlagOptRare String  -- ^ Optional argument that requires an = before the value
    | FlagNone            -- ^ No argument
      deriving (FlagInfo -> FlagInfo -> Bool
(FlagInfo -> FlagInfo -> Bool)
-> (FlagInfo -> FlagInfo -> Bool) -> Eq FlagInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FlagInfo -> FlagInfo -> Bool
$c/= :: FlagInfo -> FlagInfo -> Bool
== :: FlagInfo -> FlagInfo -> Bool
$c== :: FlagInfo -> FlagInfo -> Bool
Eq,Eq FlagInfo
Eq FlagInfo
-> (FlagInfo -> FlagInfo -> Ordering)
-> (FlagInfo -> FlagInfo -> Bool)
-> (FlagInfo -> FlagInfo -> Bool)
-> (FlagInfo -> FlagInfo -> Bool)
-> (FlagInfo -> FlagInfo -> Bool)
-> (FlagInfo -> FlagInfo -> FlagInfo)
-> (FlagInfo -> FlagInfo -> FlagInfo)
-> Ord FlagInfo
FlagInfo -> FlagInfo -> Bool
FlagInfo -> FlagInfo -> Ordering
FlagInfo -> FlagInfo -> FlagInfo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FlagInfo -> FlagInfo -> FlagInfo
$cmin :: FlagInfo -> FlagInfo -> FlagInfo
max :: FlagInfo -> FlagInfo -> FlagInfo
$cmax :: FlagInfo -> FlagInfo -> FlagInfo
>= :: FlagInfo -> FlagInfo -> Bool
$c>= :: FlagInfo -> FlagInfo -> Bool
> :: FlagInfo -> FlagInfo -> Bool
$c> :: FlagInfo -> FlagInfo -> Bool
<= :: FlagInfo -> FlagInfo -> Bool
$c<= :: FlagInfo -> FlagInfo -> Bool
< :: FlagInfo -> FlagInfo -> Bool
$c< :: FlagInfo -> FlagInfo -> Bool
compare :: FlagInfo -> FlagInfo -> Ordering
$ccompare :: FlagInfo -> FlagInfo -> Ordering
$cp1Ord :: Eq FlagInfo
Ord,Int -> FlagInfo -> String -> String
[FlagInfo] -> String -> String
FlagInfo -> String
(Int -> FlagInfo -> String -> String)
-> (FlagInfo -> String)
-> ([FlagInfo] -> String -> String)
-> Show FlagInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [FlagInfo] -> String -> String
$cshowList :: [FlagInfo] -> String -> String
show :: FlagInfo -> String
$cshow :: FlagInfo -> String
showsPrec :: Int -> FlagInfo -> String -> String
$cshowsPrec :: Int -> FlagInfo -> String -> String
Show)

-- | Extract the value from inside a 'FlagOpt' or 'FlagOptRare', or raises an error.
fromFlagOpt :: FlagInfo -> String
fromFlagOpt :: FlagInfo -> String
fromFlagOpt (FlagOpt String
x) = String
x
fromFlagOpt (FlagOptRare String
x) = String
x

-- | A function to take a string, and a value, and either produce an error message
--   (@Left@), or a modified value (@Right@).
type Update a = String -> a -> Either String a

-- | A flag, consisting of a list of flag names and other information.
data Flag a = Flag
    {Flag a -> [String]
flagNames :: [Name] -- ^ The names for the flag.
    ,Flag a -> FlagInfo
flagInfo :: FlagInfo -- ^ Information about a flag's arguments.
    ,Flag a -> Update a
flagValue :: Update a -- ^ The way of processing a flag.
    ,Flag a -> String
flagType :: FlagHelp -- ^ The type of data for the flag argument, i.e. FILE\/DIR\/EXT
    ,Flag a -> String
flagHelp :: Help -- ^ The help message associated with this flag.
    }


-- | An unnamed argument. Anything not starting with @-@ is considered an argument,
--   apart from @\"-\"@ which is considered to be the argument @\"-\"@, and any arguments
--   following @\"--\"@. For example:
--
-- > programname arg1 -j - --foo arg3 -- -arg4 --arg5=1 arg6
--
--   Would have the arguments:
--
-- > ["arg1","-","arg3","-arg4","--arg5=1","arg6"]
data Arg a = Arg
    {Arg a -> Update a
argValue :: Update a -- ^ A way of processing the argument.
    ,Arg a -> String
argType :: FlagHelp -- ^ The type of data for the argument, i.e. FILE\/DIR\/EXT
    ,Arg a -> Bool
argRequire :: Bool -- ^ Is at least one of these arguments required, the command line will fail if none are set
    }


---------------------------------------------------------------------
-- CHECK FLAGS

-- | Check that a mode is well formed.
checkMode :: Mode a -> Maybe String
checkMode :: Mode a -> Maybe String
checkMode Mode a
x = [Maybe String] -> Maybe String
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
    [String -> [String] -> Maybe String
checkNames String
"modes" ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ (Mode a -> [String]) -> [Mode a] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Mode a -> [String]
forall a. Mode a -> [String]
modeNames ([Mode a] -> [String]) -> [Mode a] -> [String]
forall a b. (a -> b) -> a -> b
$ Mode a -> [Mode a]
forall a. Mode a -> [Mode a]
modeModes Mode a
x
    ,[Maybe String] -> Maybe String
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe String] -> Maybe String) -> [Maybe String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ (Mode a -> Maybe String) -> [Mode a] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map Mode a -> Maybe String
forall a. Mode a -> Maybe String
checkMode ([Mode a] -> [Maybe String]) -> [Mode a] -> [Maybe String]
forall a b. (a -> b) -> a -> b
$ Mode a -> [Mode a]
forall a. Mode a -> [Mode a]
modeModes Mode a
x
    ,Group (Mode a) -> Maybe String
forall a. Group a -> Maybe String
checkGroup (Group (Mode a) -> Maybe String) -> Group (Mode a) -> Maybe String
forall a b. (a -> b) -> a -> b
$ Mode a -> Group (Mode a)
forall a. Mode a -> Group (Mode a)
modeGroupModes Mode a
x
    ,Group (Flag a) -> Maybe String
forall a. Group a -> Maybe String
checkGroup (Group (Flag a) -> Maybe String) -> Group (Flag a) -> Maybe String
forall a b. (a -> b) -> a -> b
$ Mode a -> Group (Flag a)
forall a. Mode a -> Group (Flag a)
modeGroupFlags Mode a
x
    ,String -> [String] -> Maybe String
checkNames String
"flag names" ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ (Flag a -> [String]) -> [Flag a] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Flag a -> [String]
forall a. Flag a -> [String]
flagNames ([Flag a] -> [String]) -> [Flag a] -> [String]
forall a b. (a -> b) -> a -> b
$ Mode a -> [Flag a]
forall a. Mode a -> [Flag a]
modeFlags Mode a
x]
    where
        checkGroup :: Group a -> Maybe String
        checkGroup :: Group a -> Maybe String
checkGroup Group a
x = [Maybe String] -> Maybe String
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
            [String -> Bool -> Maybe String
check String
"Empty group name" (Bool -> Maybe String) -> Bool -> Maybe String
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ((String, [a]) -> Bool) -> [(String, [a])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool)
-> ((String, [a]) -> String) -> (String, [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [a]) -> String
forall a b. (a, b) -> a
fst) ([(String, [a])] -> Bool) -> [(String, [a])] -> Bool
forall a b. (a -> b) -> a -> b
$ Group a -> [(String, [a])]
forall a. Group a -> [(String, [a])]
groupNamed Group a
x
            ,String -> Bool -> Maybe String
check String
"Empty group contents" (Bool -> Maybe String) -> Bool -> Maybe String
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ((String, [a]) -> Bool) -> [(String, [a])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> ((String, [a]) -> [a]) -> (String, [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [a]) -> [a]
forall a b. (a, b) -> b
snd) ([(String, [a])] -> Bool) -> [(String, [a])] -> Bool
forall a b. (a -> b) -> a -> b
$ Group a -> [(String, [a])]
forall a. Group a -> [(String, [a])]
groupNamed Group a
x]

        checkNames :: String -> [Name] -> Maybe String
        checkNames :: String -> [String] -> Maybe String
checkNames String
msg [String]
xs = String -> Bool -> Maybe String
check String
"Empty names" (Bool -> Bool
not ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
xs)) Maybe String -> Maybe String -> Maybe String
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` do
            String
bad <- [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String]
xs [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
xs
            let dupe :: [String]
dupe = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
bad) [String]
xs
            String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Sanity check failed, multiple " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. Show a => a -> String
show [String]
dupe)

        check :: String -> Bool -> Maybe String
        check :: String -> Bool -> Maybe String
check String
msg Bool
True = Maybe String
forall a. Maybe a
Nothing
        check String
msg Bool
False = String -> Maybe String
forall a. a -> Maybe a
Just String
msg


---------------------------------------------------------------------
-- REMAP

-- | Like functor, but where the the argument isn't just covariant.
class Remap m where
    -- | Convert between two values.
    remap :: (a -> b) -- ^ Embed a value
          -> (b -> (a, a -> b)) -- ^ Extract the mode and give a way of re-embedding
          -> m a -> m b

-- | Restricted version of 'remap' where the values are isomorphic.
remap2 :: Remap m => (a -> b) -> (b -> a) -> m a -> m b
remap2 :: (a -> b) -> (b -> a) -> m a -> m b
remap2 a -> b
f b -> a
g = (a -> b) -> (b -> (a, a -> b)) -> m a -> m b
forall (m :: * -> *) a b.
Remap m =>
(a -> b) -> (b -> (a, a -> b)) -> m a -> m b
remap a -> b
f (\b
x -> (b -> a
g b
x, a -> b
f))

instance Remap Mode where
    remap :: (a -> b) -> (b -> (a, a -> b)) -> Mode a -> Mode b
remap a -> b
f b -> (a, a -> b)
g Mode a
x = Mode a
x
        {modeGroupModes :: Group (Mode b)
modeGroupModes = (Mode a -> Mode b) -> Group (Mode a) -> Group (Mode b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (b -> (a, a -> b)) -> Mode a -> Mode b
forall (m :: * -> *) a b.
Remap m =>
(a -> b) -> (b -> (a, a -> b)) -> m a -> m b
remap a -> b
f b -> (a, a -> b)
g) (Group (Mode a) -> Group (Mode b))
-> Group (Mode a) -> Group (Mode b)
forall a b. (a -> b) -> a -> b
$ Mode a -> Group (Mode a)
forall a. Mode a -> Group (Mode a)
modeGroupModes Mode a
x
        ,modeValue :: b
modeValue = a -> b
f (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ Mode a -> a
forall a. Mode a -> a
modeValue Mode a
x
        ,modeCheck :: b -> Either String b
modeCheck = \b
v -> let (a
a,a -> b
b) = b -> (a, a -> b)
g b
v in (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
b (Either String a -> Either String b)
-> Either String a -> Either String b
forall a b. (a -> b) -> a -> b
$ Mode a -> a -> Either String a
forall a. Mode a -> a -> Either String a
modeCheck Mode a
x a
a
        ,modeReform :: b -> Maybe [String]
modeReform = Mode a -> a -> Maybe [String]
forall a. Mode a -> a -> Maybe [String]
modeReform Mode a
x (a -> Maybe [String]) -> (b -> a) -> b -> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a -> b) -> a
forall a b. (a, b) -> a
fst ((a, a -> b) -> a) -> (b -> (a, a -> b)) -> b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> (a, a -> b)
g
        ,modeArgs :: ([Arg b], Maybe (Arg b))
modeArgs = ((Arg a -> Arg b) -> [Arg a] -> [Arg b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (b -> (a, a -> b)) -> Arg a -> Arg b
forall (m :: * -> *) a b.
Remap m =>
(a -> b) -> (b -> (a, a -> b)) -> m a -> m b
remap a -> b
f b -> (a, a -> b)
g) ([Arg a] -> [Arg b])
-> (Maybe (Arg a) -> Maybe (Arg b))
-> ([Arg a], Maybe (Arg a))
-> ([Arg b], Maybe (Arg b))
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Arg a -> Arg b) -> Maybe (Arg a) -> Maybe (Arg b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (b -> (a, a -> b)) -> Arg a -> Arg b
forall (m :: * -> *) a b.
Remap m =>
(a -> b) -> (b -> (a, a -> b)) -> m a -> m b
remap a -> b
f b -> (a, a -> b)
g)) (([Arg a], Maybe (Arg a)) -> ([Arg b], Maybe (Arg b)))
-> ([Arg a], Maybe (Arg a)) -> ([Arg b], Maybe (Arg b))
forall a b. (a -> b) -> a -> b
$ Mode a -> ([Arg a], Maybe (Arg a))
forall a. Mode a -> ([Arg a], Maybe (Arg a))
modeArgs Mode a
x
        ,modeGroupFlags :: Group (Flag b)
modeGroupFlags = (Flag a -> Flag b) -> Group (Flag a) -> Group (Flag b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (b -> (a, a -> b)) -> Flag a -> Flag b
forall (m :: * -> *) a b.
Remap m =>
(a -> b) -> (b -> (a, a -> b)) -> m a -> m b
remap a -> b
f b -> (a, a -> b)
g) (Group (Flag a) -> Group (Flag b))
-> Group (Flag a) -> Group (Flag b)
forall a b. (a -> b) -> a -> b
$ Mode a -> Group (Flag a)
forall a. Mode a -> Group (Flag a)
modeGroupFlags Mode a
x}

instance Remap Flag where
    remap :: (a -> b) -> (b -> (a, a -> b)) -> Flag a -> Flag b
remap a -> b
f b -> (a, a -> b)
g Flag a
x = Flag a
x{flagValue :: Update b
flagValue = (a -> b) -> (b -> (a, a -> b)) -> Update a -> Update b
forall a b. (a -> b) -> (b -> (a, a -> b)) -> Update a -> Update b
remapUpdate a -> b
f b -> (a, a -> b)
g (Update a -> Update b) -> Update a -> Update b
forall a b. (a -> b) -> a -> b
$ Flag a -> Update a
forall a. Flag a -> Update a
flagValue Flag a
x}

instance Remap Arg where
    remap :: (a -> b) -> (b -> (a, a -> b)) -> Arg a -> Arg b
remap a -> b
f b -> (a, a -> b)
g Arg a
x = Arg a
x{argValue :: Update b
argValue = (a -> b) -> (b -> (a, a -> b)) -> Update a -> Update b
forall a b. (a -> b) -> (b -> (a, a -> b)) -> Update a -> Update b
remapUpdate a -> b
f b -> (a, a -> b)
g (Update a -> Update b) -> Update a -> Update b
forall a b. (a -> b) -> a -> b
$ Arg a -> Update a
forall a. Arg a -> Update a
argValue Arg a
x}

-- | Version of 'remap' for the 'Update' type alias.
remapUpdate :: (a -> b) -> (b -> (a, a -> b)) -> Update a -> Update b
remapUpdate :: (a -> b) -> (b -> (a, a -> b)) -> Update a -> Update b
remapUpdate a -> b
f b -> (a, a -> b)
g Update a
upd = \String
s b
v -> let (a
a,a -> b
b) = b -> (a, a -> b)
g b
v in (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
b (Either String a -> Either String b)
-> Either String a -> Either String b
forall a b. (a -> b) -> a -> b
$ Update a
upd String
s a
a


---------------------------------------------------------------------
-- MODE/MODES CREATORS

-- | Create an empty mode specifying only 'modeValue'. All other fields will usually be populated
--   using record updates.
modeEmpty :: a -> Mode a
modeEmpty :: a -> Mode a
modeEmpty a
x = Group (Mode a)
-> [String]
-> a
-> (a -> Either String a)
-> (a -> Maybe [String])
-> Bool
-> String
-> [String]
-> ([Arg a], Maybe (Arg a))
-> Group (Flag a)
-> Mode a
forall a.
Group (Mode a)
-> [String]
-> a
-> (a -> Either String a)
-> (a -> Maybe [String])
-> Bool
-> String
-> [String]
-> ([Arg a], Maybe (Arg a))
-> Group (Flag a)
-> Mode a
Mode Group (Mode a)
forall a. Monoid a => a
mempty [] a
x a -> Either String a
forall a b. b -> Either a b
Right (Maybe [String] -> a -> Maybe [String]
forall a b. a -> b -> a
const Maybe [String]
forall a. Maybe a
Nothing) Bool
True String
"" [] ([],Maybe (Arg a)
forall a. Maybe a
Nothing) Group (Flag a)
forall a. Monoid a => a
mempty

-- | Create a mode with a name, an initial value, some help text, a way of processing arguments
--   and a list of flags.
mode :: Name -> a -> Help -> Arg a -> [Flag a] -> Mode a
mode :: String -> a -> String -> Arg a -> [Flag a] -> Mode a
mode String
name a
value String
help Arg a
arg [Flag a]
flags = (a -> Mode a
forall a. a -> Mode a
modeEmpty a
value){modeNames :: [String]
modeNames=[String
name], modeHelp :: String
modeHelp=String
help, modeArgs :: ([Arg a], Maybe (Arg a))
modeArgs=([],Arg a -> Maybe (Arg a)
forall a. a -> Maybe a
Just Arg a
arg), modeGroupFlags :: Group (Flag a)
modeGroupFlags=[Flag a] -> Group (Flag a)
forall a. [a] -> Group a
toGroup [Flag a]
flags}

-- | Create a list of modes, with a program name, an initial value, some help text and the child modes.
modes :: String -> a -> Help -> [Mode a] -> Mode a
modes :: String -> a -> String -> [Mode a] -> Mode a
modes String
name a
value String
help [Mode a]
xs = (a -> Mode a
forall a. a -> Mode a
modeEmpty a
value){modeNames :: [String]
modeNames=[String
name], modeHelp :: String
modeHelp=String
help, modeGroupModes :: Group (Mode a)
modeGroupModes=[Mode a] -> Group (Mode a)
forall a. [a] -> Group a
toGroup [Mode a]
xs}


---------------------------------------------------------------------
-- FLAG CREATORS

-- | Create a flag taking no argument value, with a list of flag names, an update function
--   and some help text.
flagNone :: [Name] -> (a -> a) -> Help -> Flag a
flagNone :: [String] -> (a -> a) -> String -> Flag a
flagNone [String]
names a -> a
f String
help = [String] -> FlagInfo -> Update a -> String -> String -> Flag a
forall a.
[String] -> FlagInfo -> Update a -> String -> String -> Flag a
Flag [String]
names FlagInfo
FlagNone Update a
forall p a. p -> a -> Either a a
upd String
"" String
help
    where upd :: p -> a -> Either a a
upd p
_ a
x = a -> Either a a
forall a b. b -> Either a b
Right (a -> Either a a) -> a -> Either a a
forall a b. (a -> b) -> a -> b
$ a -> a
f a
x

-- | Create a flag taking an optional argument value, with an optional value, a list of flag names,
--   an update function, the type of the argument and some help text.
flagOpt :: String -> [Name] -> Update a -> FlagHelp -> Help -> Flag a
flagOpt :: String -> [String] -> Update a -> String -> String -> Flag a
flagOpt String
def [String]
names Update a
upd String
typ String
help = [String] -> FlagInfo -> Update a -> String -> String -> Flag a
forall a.
[String] -> FlagInfo -> Update a -> String -> String -> Flag a
Flag [String]
names (String -> FlagInfo
FlagOpt String
def) Update a
upd String
typ String
help

-- | Create a flag taking a required argument value, with a list of flag names,
--   an update function, the type of the argument and some help text.
flagReq :: [Name] -> Update a -> FlagHelp -> Help -> Flag a
flagReq :: [String] -> Update a -> String -> String -> Flag a
flagReq [String]
names Update a
upd String
typ String
help = [String] -> FlagInfo -> Update a -> String -> String -> Flag a
forall a.
[String] -> FlagInfo -> Update a -> String -> String -> Flag a
Flag [String]
names FlagInfo
FlagReq Update a
upd String
typ String
help

-- | Create an argument flag, with an update function and the type of the argument.
flagArg :: Update a -> FlagHelp -> Arg a
flagArg :: Update a -> String -> Arg a
flagArg Update a
upd String
typ = Update a -> String -> Bool -> Arg a
forall a. Update a -> String -> Bool -> Arg a
Arg Update a
upd String
typ Bool
False

-- | Create a boolean flag, with a list of flag names, an update function and some help text.
flagBool :: [Name] -> (Bool -> a -> a) -> Help -> Flag a
flagBool :: [String] -> (Bool -> a -> a) -> String -> Flag a
flagBool [String]
names Bool -> a -> a
f String
help = [String] -> FlagInfo -> Update a -> String -> String -> Flag a
forall a.
[String] -> FlagInfo -> Update a -> String -> String -> Flag a
Flag [String]
names (String -> FlagInfo
FlagOptRare String
"") Update a
upd String
"" String
help
    where
        upd :: Update a
upd String
s a
x = case if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True else String -> Maybe Bool
parseBool String
s of
            Just Bool
b -> a -> Either String a
forall a b. b -> Either a b
Right (a -> Either String a) -> a -> Either String a
forall a b. (a -> b) -> a -> b
$ Bool -> a -> a
f Bool
b a
x
            Maybe Bool
Nothing -> String -> Either String a
forall a b. a -> Either a b
Left String
"expected boolean value (true/false)"