module System.Console.CmdArgs.Implicit.Step1(step1, Prog1(..), Mode1(..), Flag1(..)) where
import System.Console.CmdArgs.Implicit.Ann
import Data.Generics.Any
import System.Console.CmdArgs.Implicit.Capture
import Data.Char
import Data.List
import Data.Maybe
data Prog1 = Prog1 [Ann] [Mode1] deriving Show
data Mode1 = Mode1 [Ann] Any [Flag1] deriving Show
data Flag1 = Flag1 [Ann] String Any deriving Show
step1 :: Capture -> Prog1
step1 = expand . groupnames . inherit . flatten
err x = error $ "CmdArgs.Implicit.Step1: " ++ x
mapMode :: (Mode1 -> Mode1) -> Prog1 -> Prog1
mapMode f (Prog1 a b) = Prog1 a $ map f b
expand :: Prog1 -> Prog1
expand = mapMode (removeExplicit . assignShort . assignLong)
removeExplicit (Mode1 a b c) = Mode1 (del a) b $ map f c
where f (Flag1 a b c) = Flag1 (del a) b c
del = filter (/= Explicit)
assignShort (Mode1 a b c) = Mode1 a b [Flag1 ((s \\ dupe) ++ x) y z | (s,Flag1 x y z) <- zip poss c]
where seen = [x | Flag1 a _ _ <- c, Name [x] <- a]
dupe = concat poss \\ nub (concat poss)
poss = map f c
f (Flag1 a b c) = [Name [x] | Explicit `notElem` a, null [() | Name [_] <- a]
, x <- take 1 [head x | Name x <- a], x `notElem` seen]
assignLong (Mode1 a b c) = Mode1 (add (ctor b) a) b $ map f c
where f (Flag1 a b c) = Flag1 (add newname a) b c
where newname = if FlagEnum `elem` a then ctor c else b
add s xs = [Name ss | all g xs, Name ss `notElem` xs] ++ xs
where ss = map (\x -> if x == '_' then '-' else toLower x) $ if last s == '_' then init s else s
g Explicit = False
g FlagArgs = False
g FlagArgPos{} = False
g _ = True
groupnames :: Prog1 -> Prog1
groupnames (Prog1 a b) = Prog1 a $ f onmode "" [Mode1 c d $ f onflag "" e | Mode1 c d e <- b]
where
onmode (Mode1 a b c) = (a, \a -> Mode1 a b c)
onflag (Flag1 a b c) = (a, \a -> Flag1 a b c)
f on name [] = []
f on name (x:xs) = case [y | GroupName y <- c] of
[] -> g (GroupName name:c) : f on name xs
ys -> x : f on (last ys) xs
where (c,g) = on x
inherit :: Prog1 -> Prog1
inherit (Prog1 a b) = Prog1 a $ f ask0 b
where
ask0 s = err $ "Field missing and not specified previously: " ++ show s
f ask (x:xs) = x2 : f (\s -> fromMaybe (ask s) $ lookup s [(a,b) | b@(Flag1 _ a _) <- cs]) xs
where x2@(Mode1 _ _ cs) = inheritMode ask x
f ask [] = []
inheritMode :: (String -> Flag1) -> Mode1 -> Mode1
inheritMode ask (Mode1 a b c) = Mode1 a (foldr ($) b upd) c2
where (c2,upd) = unzip $ map (inheritFlag ask) c
inheritFlag :: (String -> Flag1) -> Flag1 -> (Flag1, Any -> Any)
inheritFlag ask (Flag1 a b c)
| FlagInherit `notElem` a = (Flag1 a b c, id)
| Flag1 a2 b2 c2 <- ask b, typeOf c == typeOf c2 = (Flag1 a2 b2 c2, setField (b2,c2))
| otherwise = err $ "Field missing and previous instance has a different type:" ++ show b
flatten :: Capture -> Prog1
flatten = moveAnn . flattenProg
moveAnn :: Prog1 -> Prog1
moveAnn (Prog1 as ms) = Prog1 prog [Mode1 (mode++a) b c | Mode1 a b c <- ms]
where (prog,mode) = partition (\x -> case x of Help{} -> length ms > 1; _ -> isProgAnn x) as
isProgAnn ProgSummary{} = True
isProgAnn ProgProgram{} = True
isProgAnn ProgVerbosity{} = True
isProgAnn _ = False
flattenProg :: Capture -> Prog1
flattenProg (Ann a b) = let Prog1 x y = flattenProg b in Prog1 (x++[a]) y
flattenProg (Many xs) = Prog1 [] $ map flattenMode xs
flattenProg x@Ctor{} = Prog1 [] [flattenMode x]
flattenProg x = err $ "Unexpected in a program: " ++ show x
flattenMode :: Capture -> Mode1
flattenMode (Ann a b) = let Mode1 x y z = flattenMode b in Mode1 (x++[a]) y z
flattenMode (Ctor x ys) = Mode1 [] x [Flag1 a n b | (y,n) <- zip ys $ fields x, Flag1 a _ b <- flattenFlag y]
flattenMode x = err $ "Unexpected in a mode: " ++ show x
flattenFlag :: Capture -> [Flag1]
flattenFlag (Ann a b) = [Flag1 (x++[a]) y z | Flag1 x y z <- flattenFlag b]
flattenFlag (Value x) = [Flag1 [] "" x]
flattenFlag (Missing x) = [Flag1 [FlagInherit] "" x]
flattenFlag x@Ctor{} = [Flag1 [] "" $ flattenValue x]
flattenFlag (Many xs) = concatMap flattenFlag $ map (Ann FlagEnum) xs
flattenFlag x = err $ "Unexpected in a flag: " ++ show x
flattenValue :: Capture -> Any
flattenValue (Ctor x _) = x
flattenValue (Value x) = x
flattenValue x = err $ "Unexpected in a value: " ++ show x