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