Type.hs

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

showRecord x ys = x ++ " {" ++ intercalate ", " ys ++ "}"
a *= b = a ++ " = " ++ show b


-- | A mode. Each mode has three main features:
--
--   * A list of submodes ('modeGroupModes')
--
--   * A list of flags ('modeGroupFlags')
--
--   * Optionally an unnamed argument ('modeArgs')
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.
    ,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) "" [] ([],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)"