1{-# LANGUAGE PatternGuards, RecordWildCards #-}
2
3module System.Console.CmdArgs.Implicit.Global(global) where
4
5import System.Console.CmdArgs.Implicit.Local
6import System.Console.CmdArgs.Implicit.Reform
7import System.Console.CmdArgs.Implicit.Type
8import System.Console.CmdArgs.Explicit
9import System.Console.CmdArgs.Text
10import System.Console.CmdArgs.Default
11
12import Control.Arrow
13import Control.Monad
14import Data.Char
15import Data.Function
16import Data.Generics.Any
17import Data.List
18import Data.Maybe
19
20
21global :: Prog_ -> Mode (CmdArgs Any)
22global x = setReform (reform y) $ setHelp y $ setProgOpts x $ collapse $ assignGroups y
23    where y = assignNames $ extraFlags x
24
25
26setProgOpts :: Prog_ -> Mode a -> Mode a
27setProgOpts p m = m{modeExpandAt = not $ progNoAtExpand p
28                   ,modeGroupModes = fmap (setProgOpts p) $ modeGroupModes m}
29
30
31---------------------------------------------------------------------
32-- COLLAPSE THE FLAGS/MODES UPWARDS
33
34collapse :: Prog_ -> Mode (CmdArgs Any)
35collapse x | length ms == 1 = (snd $ head ms){modeNames=[progProgram x]}
36           | length auto > 1 = err "prog" "Multiple automatic modes"
37           | otherwise = (head $ map zeroMode auto ++ map (emptyMode . snd) ms)
38                {modeNames=[progProgram x], modeGroupModes=grouped, modeHelp=progHelp x}
39    where
40        grouped = Group (pick Nothing) [] [(g, pick $ Just g) | g <- nub $ mapMaybe (modeGroup . fst) ms]
41        pick x = [m | (m_,m) <- ms, modeGroup m_ == x]
42
43        ms = map (id &&& collapseMode) $ progModes x
44        auto = [m | (m_,m) <- ms, modeDefault m_]
45
46
47-- | A mode devoid of all it's contents
48emptyMode :: Mode (CmdArgs Any) -> Mode (CmdArgs Any)
49emptyMode x = x
50    {modeCheck = \x -> if cmdArgsHasValue x then Left "No mode given and no default mode" else Right x
51    ,modeGroupFlags = groupUncommonDelete $ modeGroupFlags x
52    ,modeArgs=([],Nothing), modeHelpSuffix=[]}
53
54-- | A mode whose help hides all it's contents
55zeroMode :: Mode (CmdArgs Any) -> Mode (CmdArgs Any)
56zeroMode x = x
57    {modeGroupFlags = groupUncommonHide $ modeGroupFlags x
58    ,modeArgs = let zeroArg x = x{argType=""} in map zeroArg *** fmap zeroArg $ modeArgs x
59    ,modeHelpSuffix=[]}
60
61
62collapseMode :: Mode_ -> Mode (CmdArgs Any)
63collapseMode x =
64    applyFixups (map flagFixup $ modeFlags_ x) $
65    collapseArgs [x | x@Arg_{} <- modeFlags_ x] $
66    collapseFlags [x | x@Flag_{} <- modeFlags_ x] $
67    modeMode x
68
69
70applyFixups :: [Fixup] -> Mode (CmdArgs Any) -> Mode (CmdArgs Any)
71applyFixups xs m = m{modeCheck = either Left (Right . fmap fix) . modeCheck m}
72    where fix a = foldr ($) a [x | Fixup x <- xs]
73
74
75collapseFlags :: [Flag_] -> Mode (CmdArgs Any) -> Mode (CmdArgs Any)
76collapseFlags xs x = x{modeGroupFlags = Group (pick Nothing) [] [(g, pick $ Just g) | g <- groups]}
77    where
78        pick x = map flagFlag $ filter ((==) x . flagGroup) xs
79        groups = nub $ mapMaybe flagGroup xs
80
81
82collapseArgs :: [Flag_] -> Mode (CmdArgs Any) -> Mode (CmdArgs Any)
83collapseArgs [] x = x
84collapseArgs xs x = x{modeCheck=chk, modeArgs = ([], Just $ flagArg upd hlp)}
85    where
86        argUpd = argValue . flagArg_
87
88        (ord,rep) = orderArgs xs
89        mn = length $ dropWhile (isJust . flagArgOpt) $ reverse ord
90
91        chk v | not $ cmdArgsHasValue v = Right v
92              | n < mn = Left $ "Requires at least " ++ show mn ++ " arguments, got " ++ show n
93              | otherwise = foldl f (addOptArgs n v) (drop n ord)
94            where n = getArgsSeen v
95                  f (Right v) arg = argUpd arg (fromJust $ flagArgOpt arg) v
96                  f x _ = x
97
98        -- if we have repeating args which is also opt, translate that here
99        addOptArgs n v
100            | Just x <- rep, Just o <- flagArgOpt x, Just n <= findIndex (isNothing . flagArgPos) (ord ++ [x]) = argUpd x o v
101            | otherwise = Right v
102
103        hlp = unwords $ a ++ map (\x -> "["++x++"]") b
104            where (a,b) = splitAt mn $ map (argType . flagArg_) $ ord ++ maybeToList rep
105
106        upd s v | n < length ord = argUpd (ord !! n) s v2
107                | Just x <- rep = argUpd x s v2
108                | otherwise = Left $ "expected at most " ++ show (length ord)
109            where n = getArgsSeen v
110                  v2 = incArgsSeen v
111
112
113-- return the arguments in order, plus those at the end
114orderArgs :: [Flag_] -> ([Flag_], Maybe Flag_)
115orderArgs args = (f 0 ord, listToMaybe rep)
116    where
117        (rep,ord) = span (isNothing . flagArgPos) $ sortBy (compare `on` flagArgPos) args
118        f i [] = []
119        f i (x:xs) = case fromJust (flagArgPos x) `compare` i of
120            LT -> f i xs
121            EQ -> x : f (i+1) xs
122            GT -> take 1 rep ++ f (i+1) (x:xs)
123
124
125---------------------------------------------------------------------
126-- DEAL WITH GROUPS
127
128assignGroups :: Prog_ -> Prog_
129assignGroups p = assignCommon $ p{progModes = map (\m -> m{modeFlags_ = f Nothing $ modeFlags_ m}) $ progModes p}
130    where
131        f grp [] = []
132        f grp (x@Flag_{}:xs) = x{flagGroup=grp2} : f grp2 xs
133            where grp2 = flagGroup x `mplus` grp
134        f grp (x:xs) = x : f grp xs
135
136
137assignCommon :: Prog_ -> Prog_
138assignCommon p =
139    p{progModes = [m{modeFlags_ =
140        [if isFlag_ f && show (flagFlag f) `elem` com then f{flagGroup = Just commonGroup} else f | f <- modeFlags_ m]}
141    | m <- progModes p]}
142    where
143        com = map head $ filter ((== length (progModes p)) . length) $ group $ sort
144              [show $ flagFlag f | m <- progModes p, f@Flag_{flagGroup=Nothing} <- modeFlags_ m]
145
146
147commonGroup = "Common flags"
148
149groupSplitCommon :: Group a -> ([a], Group a)
150groupSplitCommon (Group unnamed hidden named) = (concatMap snd com, Group unnamed hidden uni)
151    where (com,uni) = partition ((==) commonGroup . fst) named
152
153groupCommonHide x = let (a,b) = groupSplitCommon x in b{groupHidden = groupHidden b ++ a}
154groupUncommonHide x = let (a,b) = groupSplitCommon x in Group [] (fromGroup b) [(commonGroup,a) | not $ null a]
155groupUncommonDelete x = let a = fst $ groupSplitCommon x in Group [] [] [(commonGroup,a) | not $ null a]
156
157
158---------------------------------------------------------------------
159-- ADD EXTRA PIECES
160
161extraFlags :: Prog_ -> Prog_
162extraFlags p = p{progModes = map f $ progModes p}
163    where f m = m{modeFlags_ = modeFlags_ m ++ flags}
164          grp = if length (progModes p) > 1 then Just commonGroup else Nothing
165          wrap x = def{flagFlag=x, flagExplicit=True, flagGroup=grp}
166          flags = changeBuiltin_ (progHelpArg p) (wrap $ flagHelpFormat $ error "flagHelpFormat undefined") ++
167                  changeBuiltin_ (progVersionArg p) (wrap $ flagVersion vers) ++
168                  [wrap $ flagNumericVersion $ \x -> x{cmdArgsVersion = Just $ unlines v}
169                        | Just v <- [progNumericVersionOutput p]] ++
170                  changeBuiltin_ (fst $ progVerbosityArgs p) (wrap loud) ++
171                  changeBuiltin_ (snd $ progVerbosityArgs p) (wrap quiet)
172          [loud,quiet] = flagsVerbosity verb
173          vers x = x{cmdArgsVersion = Just $ unlines $ progVersionOutput p}
174          verb v x = x{cmdArgsVerbosity = Just v}
175
176
177changeBuiltin :: Maybe Builtin_ -> Flag a -> [Flag a]
178changeBuiltin Nothing _ = []
179changeBuiltin (Just Builtin_{..}) x = [x
180    {flagNames = builtinNames ++ if builtinExplicit then [] else flagNames x
181    ,flagHelp = fromMaybe (flagHelp x) builtinHelp}]
182
183changeBuiltin_ :: Maybe Builtin_ -> Flag_ -> [Flag_]
184changeBuiltin_ Nothing _ = []
185changeBuiltin_ (Just b) x = [x{flagFlag=y, flagGroup = builtinGroup b `mplus` flagGroup x}
186    | y <- changeBuiltin (Just b) $ flagFlag x]
187
188
189setHelp :: Prog_ -> Mode (CmdArgs Any) -> Mode (CmdArgs Any)
190setHelp p = mapModes0 add ""
191    where
192        mapModes0 f pre m = f pre $ mapModes1 f pre m
193        mapModes1 f pre m = m{modeGroupModes = fmap (mapModes0 f (pre ++ head (modeNames m) ++ " ")) $ modeGroupModes m}
194
195        add pre m = changeHelp p m $ \hlp txt x -> x{cmdArgsHelp=Just $ showText txt $ msg hlp}
196            where msg hlp = helpText (progHelpOutput p) hlp (prepare m{modeNames = map (pre++) $ modeNames m})
197
198        prepare = mapModes1 (\_ m -> m{modeGroupFlags = groupCommonHide $ modeGroupFlags m}) ""
199
200
201changeHelp :: Prog_ -> Mode a -> (HelpFormat -> TextFormat -> a -> a) -> Mode a
202changeHelp p m upd = m{modeGroupFlags = fmap f $ modeGroupFlags m}
203    where hlp = changeBuiltin (progHelpArg p) $ flagHelpFormat upd
204          f flg = if concatMap flagNames hlp == flagNames flg then head hlp else flg
205
206
207setReform :: (a -> Maybe [String]) -> Mode a -> Mode a
208setReform f m = m{modeReform = f, modeGroupModes = fmap (setReform f) $ modeGroupModes m}
209
210
211---------------------------------------------------------------------
212-- ASSIGN NAMES
213
214assignNames :: Prog_ -> Prog_
215assignNames x = x{progModes = map f $ namesOn fromMode toMode $ progModes x}
216    where
217        fromMode x = Names (modeNames $ modeMode x) [asName $ ctor $ cmdArgsValue $ modeValue $ modeMode x | not $ modeExplicit x]
218        toMode xs x = x{modeMode = (modeMode x){modeNames=["["++head xs++"]" | modeDefault x] ++ xs}}
219
220        fromFlagLong x = Names (flagNames $ flagFlag x) [asName $ fromMaybe (flagField x) (flagEnum x) | not $ flagExplicit x]
221        fromFlagShort x = Names ns $ nub [take 1 s | not $ flagExplicit x, all ((/=) 1 . length) ns, s <- ns]
222            where ns = flagNames $ flagFlag x
223        toFlag xs x = x{flagFlag = (flagFlag x){flagNames=xs}}
224
225        f x = x{modeFlags_ = rest ++ namesOn fromFlagShort toFlag (namesOn fromFlagLong toFlag flgs)}
226            where (flgs,rest) = partition isFlag_ $ modeFlags_ x
227
228        isFlag_ Flag_{} = True
229        isFlag_ _ = False
230
231
232asName s = map (\x -> if x == '_' then '-' else toLower x) $ if last s == '_' then init s else s
233
234-- have are already assigned, want are a list of ones I might want
235data Names = Names {have :: [String], want :: [String]}
236
237-- error out if any name is by multiple have's, or one item would get no names
238names :: [Names] -> [[String]]
239names xs | not $ null bad = err "repeated names" $ unwords bad
240    where bad = duplicates $ concatMap have xs
241
242names xs | any null res = err "no available name" "?"
243         | otherwise = res
244    where
245        bad = concatMap have xs ++ duplicates (concatMap want xs)
246        res = map (\x -> have x ++ (want x \\ bad)) xs
247
248
249duplicates :: Eq a => [a] -> [a]
250duplicates xs = nub $ xs \\ nub xs
251
252
253namesOn :: (a -> Names) -> ([String] -> a -> a) -> [a] -> [a]
254namesOn f g xs = zipWith g (names $ map f xs) xs
255