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