module System.Console.CmdArgs.Implicit.Step3(
step3,
CmdArgs(..), cmdArgsHasValue
) where
import System.Console.CmdArgs.Implicit.Step2
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Verbosity
import System.Console.CmdArgs.Text
import Control.Arrow
import Data.Data
import Data.Maybe
import Data.Monoid
import Data.List
import Data.Function
data CmdArgs a = CmdArgs
{cmdArgsValue :: a
,cmdArgsHelp :: Maybe String
,cmdArgsVersion :: Maybe String
,cmdArgsVerbosity :: Maybe Verbosity
,cmdArgsPrivate :: CmdArgsPrivate
}
deriving (Show,Data,Typeable)
instance Functor CmdArgs where
fmap f x = x{cmdArgsValue = f $ cmdArgsValue x}
cmdArgsHasValue :: CmdArgs a -> Bool
cmdArgsHasValue x = isNothing (cmdArgsHelp x) && isNothing (cmdArgsVersion x)
data CmdArgsPrivate = CmdArgsPrivate
Int
deriving (Data,Typeable)
instance Show CmdArgsPrivate where show _ = "CmdArgsPrivate"
incArgsSeen x = x{cmdArgsPrivate = CmdArgsPrivate $ getArgsSeen x + 1}
getArgsSeen CmdArgs{cmdArgsPrivate = CmdArgsPrivate i} = i
step3 :: Prog2 a -> Mode (CmdArgs a)
step3 p = common p $ transProg $ liftProg p
common :: Prog2 a -> Mode (CmdArgs a) -> Mode (CmdArgs a)
common p m
| null $ modeModes m = addNormal m $ commonFlags p $ addNormal m
| otherwise = addCommon m2 $ commonFlags p $ addCommon m2
where
add m xs = m{modeGroupFlags = xs `mappend` modeGroupFlags m}
addNormal m xs = add m $ toGroup xs
addCommon m xs = add m $ Group [] [] [("Common flags",xs)]
addHidden m xs = add m $ Group [] xs []
m2 = m{modeGroupModes = fmap f $ modeGroupModes m}
f m = addHidden m $ commonFlags p $ addCommon $ m{modeNames = map ((prog2Name p ++ " ") ++) $ modeNames m}
commonFlags :: Prog2 a -> ([Flag (CmdArgs a)] -> Mode (CmdArgs a)) -> [Flag (CmdArgs a)]
commonFlags Prog2{..} add = flags
where
help hlp txt = showText txt $ Line prog2Summary : Line "" : helpText hlp (add flags)
flags =
[flagHelpFormat $ \hlp txt x -> x{cmdArgsHelp = Just $ help hlp txt}
,flagVersion $ \x -> x{cmdArgsVersion = Just prog2Summary}] ++
if not prog2Verbosity then [] else flagsVerbosity $ \v x -> x{cmdArgsVerbosity=Just v}
transProg :: Prog2 (CmdArgs a) -> Mode (CmdArgs a)
transProg p = res{modeNames = [prog2Name p]}
where
res = if length ys == 1 then snd $ head ys else defMode{modeGroupModes = toGroups ys, modeHelp = prog2Help p}
defMode = maybe zeroMode (silentMode . snd . (ys!!)) $ prog2ModeDefault p
silentMode m = m{modeGroupFlags=Group [] (modeFlags m) [], modeArgs=fmap (\x -> x{argType=""}) (modeArgs m)}
ys = zip (map mode2Group $ prog2Modes p) $
zipWith transMode (map ((==) (prog2ModeDefault p) . Just) [0..]) $ prog2Modes p
zeroMode = Mode (toGroup []) [] (embed $ error msg) chk "" [] Nothing $ toGroup []
where msg = "System.Console.CmdArgs.Implicit: No default mode given (see cmdArgsHelp/cmdArgsVersion)"
chk x = if cmdArgsHasValue x then Left "No mode given and no default mode" else Right x
transMode :: Bool -> Mode2 (CmdArgs a) -> Mode (CmdArgs a)
transMode auto Mode2{..} = transArgs mode2Args $ Mode
(toGroup [])
(["[" ++ head mode2Names ++ "]" | auto] ++ mode2Names)
mode2Value
Right
mode2Help
mode2Suffix
Nothing
(toGroups $ map (flag2Group &&& transFlag) mode2Flags)
toGroups :: [(String,a)] -> Group a
toGroups xs = Group (f "") [] (map (id &&& f) names)
where names = filter (not . null) $ nub $ map fst xs
f x = map snd $ filter ((==) x . fst) xs
transFlag :: Flag2 (CmdArgs a) -> Flag (CmdArgs a)
transFlag Flag2{..} = case flag2Upd of
Flag2String upd -> (maybe flagReq flagOpt flag2Opt) flag2Names upd flag2FlagHelp flag2Help
Flag2Bool upd -> flagBool flag2Names upd flag2Help
Flag2Value upd -> flagNone flag2Names upd flag2Help
transArgs :: [Arg2 (CmdArgs a)] -> Mode (CmdArgs a) -> Mode (CmdArgs a)
transArgs [] x = x
transArgs xs x = x{modeCheck=chk, modeArgs = Just $ flagArg upd hlp}
where
(ord,rep) = orderArgs xs
mn = length $ dropWhile (isJust . arg2Opt) $ reverse ord
chk v | not $ cmdArgsHasValue v = Right v
| n < mn = Left $ "Requires at least " ++ show mn ++ " arguments, got " ++ show n
| otherwise = foldl f (addOptArgs n v) (drop n ord)
where n = getArgsSeen v
f (Right v) arg = arg2Upd arg (fromJust $ arg2Opt arg) v
f x _ = x
addOptArgs n v
| Just x <- rep, Just o <- arg2Opt x, Just n <= findIndex (isNothing . arg2Pos) (ord ++ [x]) = arg2Upd x o v
| otherwise = Right v
hlp = unwords $ a ++ map (\x -> "["++x++"]") b
where (a,b) = splitAt mn $ map arg2FlagHelp $ ord ++ maybeToList rep
upd s v | n < length ord = arg2Upd (ord !! n) s v2
| Just x <- rep = arg2Upd x s v2
| otherwise = Left $ "expected at most " ++ show (length ord)
where n = getArgsSeen v
v2 = incArgsSeen v
orderArgs :: [Arg2 a] -> ([Arg2 a], Maybe (Arg2 a))
orderArgs args = (f 0 ord, listToMaybe rep)
where
(rep,ord) = span (isNothing . arg2Pos) $ sortBy (compare `on` arg2Pos) args
f i [] = []
f i (x:xs) = case fromJust (arg2Pos x) `compare` i of
LT -> f i xs
EQ -> x : f (i+1) xs
GT -> take 1 rep ++ f (i+1) (x:xs)
embed x = CmdArgs x Nothing Nothing Nothing $ CmdArgsPrivate 0
proj x = (cmdArgsValue x, \y -> x{cmdArgsValue=y})
liftProg :: Prog2 a -> Prog2 (CmdArgs a)
liftProg x = x{prog2Modes = map liftMode $ prog2Modes x}
liftMode :: Mode2 a -> Mode2 (CmdArgs a)
liftMode x = x
{mode2Value = embed $ mode2Value x
,mode2Flags = map liftFlag $ mode2Flags x
,mode2Args = map liftArg $ mode2Args x}
liftFlag x = x{flag2Upd = liftType $ flag2Upd x}
liftArg x = x{arg2Upd = fromFlag2String $ liftType $ Flag2String $ arg2Upd x}
liftType (Flag2String upd) = Flag2String $ \s v -> let (a,b) = proj v in fmap b $ upd s a
liftType (Flag2Bool upd) = Flag2Bool $ \s v -> let (a,b) = proj v in b $ upd s a
liftType (Flag2Value upd) = Flag2Value $ \v -> let (a,b) = proj v in b $ upd a