    module System.Console.CmdArgs.Explicit.Type where

    import Control.Arrow
    import Control.Monad
    import Data.Char
    import Data.List
    import Data.Maybe
    import Data.Monoid

    -- | 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 s | ls `elem` true  = Just True
                | ls `elem` false = Just False
                | otherwise = Nothing
        where
            ls = map toLower s
            true = ["true","yes","on","enabled","1"]
            false = ["false","no","off","disabled","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
        {groupUnnamed :: [a] -- ^ Normal items.
        ,groupHidden :: [a] -- ^ Items that are hidden (not displayed in the help message).
        ,groupNamed :: [(Help, [a])] -- ^ Items that have been grouped, along with a description of each group.
        } deriving Show

    instance Functor Group where
        fmap f (Group a b c) = Group (map f a) (map f b) (map (second $ map f) c)

    instance Monoid (Group a) where
        mempty = Group [] [] []
        mappend (Group x1 x2 x3) (Group y1 y2 y3) = Group (x1++y1) (x2++y2) (x3++y3)

    -- | Convert a group into a list.
    fromGroup :: Group a -> [a]
    fromGroup (Group x y z) = x ++ y ++ concatMap snd z

    -- | Convert a list into a group, placing all fields in 'groupUnnamed'.
    toGroup :: [a] -> Group a
    toGroup x = Group 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
        {modeGroupModes :: Group (Mode a) -- ^ The available sub-modes
        ,modeNames :: [Name] -- ^ The names assigned to this mode (for the root mode, this name is used as the program name)
        ,modeValue :: a -- ^ Value to start with
        ,modeCheck :: a -> Either String a -- ^ Check the value reprsented by a mode is correct, after applying all flags
        ,modeReform :: a -> Maybe [String] -- ^ Given a value, try to generate the input arguments.
        ,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.
        ,modeHelp :: Help -- ^ Help text
        ,modeHelpSuffix :: [String] -- ^ A longer help suffix displayed after a mode
        ,modeArgs :: ([Arg a], Maybe (Arg a)) -- ^ The unnamed arguments, a series of arguments, followed optionally by one for all remaining slots
        ,modeGroupFlags :: Group (Flag a) -- ^ Groups of flags
        }

    -- | Extract the modes from a 'Mode'
    modeModes :: Mode a -> [Mode a]
    modeModes = fromGroup . modeGroupModes

    -- | Extract the flags from a 'Mode'
    modeFlags :: Mode a -> [Flag a]
    modeFlags = fromGroup . 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 (Eq,Ord,Show)

    -- | Extract the value from inside a 'FlagOpt' or 'FlagOptRare', or raises an error.
    fromFlagOpt :: FlagInfo -> String
    fromFlagOpt (FlagOpt x) = x
    fromFlagOpt (FlagOptRare x) = 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
        {flagNames :: [Name] -- ^ The names for the flag.
        ,flagInfo :: FlagInfo -- ^ Information about a flag's arguments.
        ,flagValue :: Update a -- ^ The way of processing a flag.
        ,flagType :: FlagHelp -- ^ The type of data for the flag argument, i.e. FILE\/DIR\/EXT
        ,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
        {argValue :: Update a -- ^ A way of processing the argument.
        ,argType :: FlagHelp -- ^ The type of data for the argument, i.e. FILE\/DIR\/EXT
        ,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 x = msum
        [checkNames "modes" $ concatMap modeNames $ modeModes x
        ,msum $ map checkMode $ modeModes x
        ,checkGroup $ modeGroupModes x
        ,checkGroup $ modeGroupFlags x
        ,checkNames "flag names" $ concatMap flagNames $ modeFlags x]
        where
            checkGroup :: Group a -> Maybe String
            checkGroup x = msum
                [check "Empty group name" $ all (not . null . fst) $ groupNamed x
                ,check "Empty group contents" $ all (not . null . snd) $ groupNamed x]

            checkNames :: String -> [Name] -> Maybe String
            checkNames msg xs = check "Empty names" (all (not . null) xs) `mplus` do
                bad <- listToMaybe $ xs \\ nub xs
                let dupe = filter (== bad) xs
                return $ "Sanity check failed, multiple " ++ msg ++ ": " ++ unwords (map show dupe)

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

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

    class Remap m where
        remap :: (a -> b) -- ^ Embed a value
              -> (b -> (a, a -> b)) -- ^ Extract the mode and give a way of re-embedding
              -> m a -> m b

    remap2 :: Remap m => (a -> b) -> (b -> a) -> m a -> m b
    remap2 f g = remap f (\x -> (g x, f))

    instance Remap Mode where
        remap f g x = x
            {modeGroupModes = fmap (remap f g) $ modeGroupModes x
            ,modeValue = f $ modeValue x
            ,modeCheck = \v -> let (a,b) = g v in fmap b $ modeCheck x a
            ,modeReform = modeReform x . fst . g
            ,modeArgs = (fmap (remap f g) *** fmap (remap f g)) $ modeArgs x
            ,modeGroupFlags = fmap (remap f g) $ modeGroupFlags x}

    instance Remap Flag where
        remap f g x = x{flagValue = remapUpdate f g $ flagValue x}

    instance Remap Arg where
        remap f g x = x{argValue = remapUpdate f g $ argValue x}

    remapUpdate f g upd = \s v -> let (a,b) = g v in fmap b $ upd s 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 x = Mode mempty [] x Right (const Nothing) True "" [] ([],Nothing) 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 name value help arg flags = (modeEmpty value){modeNames=[name], modeHelp=help, modeArgs=([],Just arg), modeGroupFlags=toGroup 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 name value help xs = (modeEmpty value){modeNames=[name], modeHelp=help, modeGroupModes=toGroup 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 names f help = Flag names FlagNone upd "" help
        where upd _ x = Right $ f 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 def names upd typ help = Flag names (FlagOpt def) upd typ 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 names upd typ help = Flag names FlagReq upd typ help

    -- | Create an argument flag, with an update function and the type of the argument.
    flagArg :: Update a -> FlagHelp -> Arg a
    flagArg upd typ = Arg upd typ 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 names f help = Flag names (FlagOptRare "") upd "" help
        where
            upd s x = case if s == "" then Just True else parseBool s of
                Just b -> Right $ f b x
                Nothing -> Left "expected boolean value (true/false)"