1 2module System.Console.CmdArgs.Explicit.Type where 3 4import Control.Arrow 5import Control.Monad 6import Data.Char 7import Data.List 8import Data.Maybe 9import Data.Semigroup hiding (Arg) 10import Prelude 11 12 13-- | A name, either the name of a flag (@--/foo/@) or the name of a mode. 14type Name = String 15 16-- | A help message that goes with either a flag or a mode. 17type Help = String 18 19-- | The type of a flag, i.e. @--foo=/TYPE/@. 20type FlagHelp = String 21 22 23--------------------------------------------------------------------- 24-- UTILITY 25 26-- | Parse a boolean, accepts as True: true yes on enabled 1. 27parseBool :: String -> Maybe Bool 28parseBool s | ls `elem` true = Just True 29 | ls `elem` false = Just False 30 | otherwise = Nothing 31 where 32 ls = map toLower s 33 true = ["true","yes","on","enabled","1"] 34 false = ["false","no","off","disabled","0"] 35 36 37--------------------------------------------------------------------- 38-- GROUPS 39 40-- | A group of items (modes or flags). The items are treated as a list, but the 41-- group structure is used when displaying the help message. 42data Group a = Group 43 {groupUnnamed :: [a] -- ^ Normal items. 44 ,groupHidden :: [a] -- ^ Items that are hidden (not displayed in the help message). 45 ,groupNamed :: [(Help, [a])] -- ^ Items that have been grouped, along with a description of each group. 46 } deriving Show 47 48instance Functor Group where 49 fmap f (Group a b c) = Group (map f a) (map f b) (map (second $ map f) c) 50 51instance Semigroup (Group a) where 52 Group x1 x2 x3 <> Group y1 y2 y3 = Group (x1++y1) (x2++y2) (x3++y3) 53 54instance Monoid (Group a) where 55 mempty = Group [] [] [] 56 mappend = (<>) 57 58-- | Convert a group into a list. 59fromGroup :: Group a -> [a] 60fromGroup (Group x y z) = x ++ y ++ concatMap snd z 61 62-- | Convert a list into a group, placing all fields in 'groupUnnamed'. 63toGroup :: [a] -> Group a 64toGroup x = Group x [] [] 65 66 67--------------------------------------------------------------------- 68-- TYPES 69 70-- | A mode. Do not use the 'Mode' constructor directly, instead 71-- use 'mode' to construct the 'Mode' and then record updates. 72-- Each mode has three main features: 73-- 74-- * A list of submodes ('modeGroupModes') 75-- 76-- * A list of flags ('modeGroupFlags') 77-- 78-- * Optionally an unnamed argument ('modeArgs') 79-- 80-- To produce the help information for a mode, either use 'helpText' or 'show'. 81data Mode a = Mode 82 {modeGroupModes :: Group (Mode a) -- ^ The available sub-modes 83 ,modeNames :: [Name] -- ^ The names assigned to this mode (for the root mode, this name is used as the program name) 84 ,modeValue :: a -- ^ Value to start with 85 ,modeCheck :: a -> Either String a -- ^ Check the value reprsented by a mode is correct, after applying all flags 86 ,modeReform :: a -> Maybe [String] -- ^ Given a value, try to generate the input arguments. 87 ,modeExpandAt :: Bool -- ^ Expand @\@@ arguments with 'expandArgsAt', defaults to 'True', only applied if using an 'IO' processing function. 88 -- Only the root 'Mode's value will be used. 89 ,modeHelp :: Help -- ^ Help text 90 ,modeHelpSuffix :: [String] -- ^ A longer help suffix displayed after a mode 91 ,modeArgs :: ([Arg a], Maybe (Arg a)) -- ^ The unnamed arguments, a series of arguments, followed optionally by one for all remaining slots 92 ,modeGroupFlags :: Group (Flag a) -- ^ Groups of flags 93 } 94 95-- | Extract the modes from a 'Mode' 96modeModes :: Mode a -> [Mode a] 97modeModes = fromGroup . modeGroupModes 98 99-- | Extract the flags from a 'Mode' 100modeFlags :: Mode a -> [Flag a] 101modeFlags = fromGroup . modeGroupFlags 102 103-- | The 'FlagInfo' type has the following meaning: 104-- 105-- 106-- > FlagReq FlagOpt FlagOptRare/FlagNone 107-- > -xfoo -x=foo -x=foo -x -foo 108-- > -x foo -x=foo -x foo -x foo 109-- > -x=foo -x=foo -x=foo -x=foo 110-- > --xx foo --xx=foo --xx foo --xx foo 111-- > --xx=foo --xx=foo --xx=foo --xx=foo 112data FlagInfo 113 = FlagReq -- ^ Required argument 114 | FlagOpt String -- ^ Optional argument 115 | FlagOptRare String -- ^ Optional argument that requires an = before the value 116 | FlagNone -- ^ No argument 117 deriving (Eq,Ord,Show) 118 119-- | Extract the value from inside a 'FlagOpt' or 'FlagOptRare', or raises an error. 120fromFlagOpt :: FlagInfo -> String 121fromFlagOpt (FlagOpt x) = x 122fromFlagOpt (FlagOptRare x) = x 123 124-- | A function to take a string, and a value, and either produce an error message 125-- (@Left@), or a modified value (@Right@). 126type Update a = String -> a -> Either String a 127 128-- | A flag, consisting of a list of flag names and other information. 129data Flag a = Flag 130 {flagNames :: [Name] -- ^ The names for the flag. 131 ,flagInfo :: FlagInfo -- ^ Information about a flag's arguments. 132 ,flagValue :: Update a -- ^ The way of processing a flag. 133 ,flagType :: FlagHelp -- ^ The type of data for the flag argument, i.e. FILE\/DIR\/EXT 134 ,flagHelp :: Help -- ^ The help message associated with this flag. 135 } 136 137 138-- | An unnamed argument. Anything not starting with @-@ is considered an argument, 139-- apart from @\"-\"@ which is considered to be the argument @\"-\"@, and any arguments 140-- following @\"--\"@. For example: 141-- 142-- > programname arg1 -j - --foo arg3 -- -arg4 --arg5=1 arg6 143-- 144-- Would have the arguments: 145-- 146-- > ["arg1","-","arg3","-arg4","--arg5=1","arg6"] 147data Arg a = Arg 148 {argValue :: Update a -- ^ A way of processing the argument. 149 ,argType :: FlagHelp -- ^ The type of data for the argument, i.e. FILE\/DIR\/EXT 150 ,argRequire :: Bool -- ^ Is at least one of these arguments required, the command line will fail if none are set 151 } 152 153 154--------------------------------------------------------------------- 155-- CHECK FLAGS 156 157-- | Check that a mode is well formed. 158checkMode :: Mode a -> Maybe String 159checkMode x = msum 160 [checkNames "modes" $ concatMap modeNames $ modeModes x 161 ,msum $ map checkMode $ modeModes x 162 ,checkGroup $ modeGroupModes x 163 ,checkGroup $ modeGroupFlags x 164 ,checkNames "flag names" $ concatMap flagNames $ modeFlags x] 165 where 166 checkGroup :: Group a -> Maybe String 167 checkGroup x = msum 168 [check "Empty group name" $ all (not . null . fst) $ groupNamed x 169 ,check "Empty group contents" $ all (not . null . snd) $ groupNamed x] 170 171 checkNames :: String -> [Name] -> Maybe String 172 checkNames msg xs = check "Empty names" (all (not . null) xs) `mplus` do 173 bad <- listToMaybe $ xs \\ nub xs 174 let dupe = filter (== bad) xs 175 return $ "Sanity check failed, multiple " ++ msg ++ ": " ++ unwords (map show dupe) 176 177 check :: String -> Bool -> Maybe String 178 check msg True = Nothing 179 check msg False = Just msg 180 181 182--------------------------------------------------------------------- 183-- REMAP 184 185-- | Like functor, but where the the argument isn't just covariant. 186class Remap m where 187 -- | Convert between two values. 188 remap :: (a -> b) -- ^ Embed a value 189 -> (b -> (a, a -> b)) -- ^ Extract the mode and give a way of re-embedding 190 -> m a -> m b 191 192-- | Restricted version of 'remap' where the values are isomorphic. 193remap2 :: Remap m => (a -> b) -> (b -> a) -> m a -> m b 194remap2 f g = remap f (\x -> (g x, f)) 195 196instance Remap Mode where 197 remap f g x = x 198 {modeGroupModes = fmap (remap f g) $ modeGroupModes x 199 ,modeValue = f $ modeValue x 200 ,modeCheck = \v -> let (a,b) = g v in fmap b $ modeCheck x a 201 ,modeReform = modeReform x . fst . g 202 ,modeArgs = (fmap (remap f g) *** fmap (remap f g)) $ modeArgs x 203 ,modeGroupFlags = fmap (remap f g) $ modeGroupFlags x} 204 205instance Remap Flag where 206 remap f g x = x{flagValue = remapUpdate f g $ flagValue x} 207 208instance Remap Arg where 209 remap f g x = x{argValue = remapUpdate f g $ argValue x} 210 211-- | Version of 'remap' for the 'Update' type alias. 212remapUpdate :: (a -> b) -> (b -> (a, a -> b)) -> Update a -> Update b 213remapUpdate f g upd = \s v -> let (a,b) = g v in fmap b $ upd s a 214 215 216--------------------------------------------------------------------- 217-- MODE/MODES CREATORS 218 219-- | Create an empty mode specifying only 'modeValue'. All other fields will usually be populated 220-- using record updates. 221modeEmpty :: a -> Mode a 222modeEmpty x = Mode mempty [] x Right (const Nothing) True "" [] ([],Nothing) mempty 223 224-- | Create a mode with a name, an initial value, some help text, a way of processing arguments 225-- and a list of flags. 226mode :: Name -> a -> Help -> Arg a -> [Flag a] -> Mode a 227mode name value help arg flags = (modeEmpty value){modeNames=[name], modeHelp=help, modeArgs=([],Just arg), modeGroupFlags=toGroup flags} 228 229-- | Create a list of modes, with a program name, an initial value, some help text and the child modes. 230modes :: String -> a -> Help -> [Mode a] -> Mode a 231modes name value help xs = (modeEmpty value){modeNames=[name], modeHelp=help, modeGroupModes=toGroup xs} 232 233 234--------------------------------------------------------------------- 235-- FLAG CREATORS 236 237-- | Create a flag taking no argument value, with a list of flag names, an update function 238-- and some help text. 239flagNone :: [Name] -> (a -> a) -> Help -> Flag a 240flagNone names f help = Flag names FlagNone upd "" help 241 where upd _ x = Right $ f x 242 243-- | Create a flag taking an optional argument value, with an optional value, a list of flag names, 244-- an update function, the type of the argument and some help text. 245flagOpt :: String -> [Name] -> Update a -> FlagHelp -> Help -> Flag a 246flagOpt def names upd typ help = Flag names (FlagOpt def) upd typ help 247 248-- | Create a flag taking a required argument value, with a list of flag names, 249-- an update function, the type of the argument and some help text. 250flagReq :: [Name] -> Update a -> FlagHelp -> Help -> Flag a 251flagReq names upd typ help = Flag names FlagReq upd typ help 252 253-- | Create an argument flag, with an update function and the type of the argument. 254flagArg :: Update a -> FlagHelp -> Arg a 255flagArg upd typ = Arg upd typ False 256 257-- | Create a boolean flag, with a list of flag names, an update function and some help text. 258flagBool :: [Name] -> (Bool -> a -> a) -> Help -> Flag a 259flagBool names f help = Flag names (FlagOptRare "") upd "" help 260 where 261 upd s x = case if s == "" then Just True else parseBool s of 262 Just b -> Right $ f b x 263 Nothing -> Left "expected boolean value (true/false)" 264