module System.Console.CmdArgs.UI(
mode, Mode, (&=), (&), Attrib,
text, typ, typFile, typDir, empty, flag, explicit, enum, args, argPos, unknownFlags,
prog, helpSuffix, defMode
) where
import System.Console.CmdArgs.Type
import System.IO.Unsafe
import Data.Dynamic
import Data.Data
import Data.List
import Data.Maybe
import Data.IORef
import Control.Exception
import Data.Char
import Control.Monad.State
import Data.Function
infix 1 &=
infixl 2 &
info :: IORef Attrib
info = unsafePerformIO $ newIORef $ Attrib []
(&=) :: a -> Attrib -> a
(&=) x is = unsafePerformIO $ do
writeIORef info is
return x
(&) :: Attrib -> Attrib -> Attrib
(&) (Attrib x) (Attrib y) = Attrib $ x ++ y
collect :: a -> IO [Info]
collect x = do
evaluate x
Attrib x <- readIORef info
writeIORef info $ Attrib []
return x
mode :: Data a => a -> Mode a
mode val = unsafePerformIO $ do
info <- collect val
let con = toConstr val
name = map toLower $ showConstr con
ref <- newIORef $ constrFields con
flags <- liftM concat $ sequence $ flip gmapQ val $ \i -> do
info <- collect i
n:ns <- readIORef ref
writeIORef ref ns
case toFlagType $ typeOf i of
_ | [FldEnum xs] <- info -> return [x{flagName=n} | x <- xs]
Nothing -> error $ "Can't handle a type of " ++ show (typeOf i)
Just x -> return [flagInfo flagDefault{flagName=n,flagKey=n,flagVal=toDyn i,flagType=x} info]
return $ modeInfo modeDefault{modeVal=val,modeName=name,modeFlags=flags} info
newtype Attrib = Attrib [Info]
data Info
= FldEmpty String
| FldArgs
| FldArgPos Int
| FldTyp String
| Text String
| FldFlag String
| FldExplicit
| HelpSuffix [String]
| FldUnknown
| FldEnum [Flag]
| ModDefault
| ModProg String
deriving Show
modeInfo :: Mode a -> [Info] -> Mode a
modeInfo = foldl $ \m x -> case x of
Text x -> m{modeText=x}
HelpSuffix x -> m{modeHelpSuffix=x}
ModDefault -> m{modeDef=True}
ModProg x -> m{modeProg=Just x}
x -> error $ "Invalid attribute at mode level: " ++ show x
flagInfo :: Flag -> [Info] -> Flag
flagInfo = foldl $ \m x -> case x of
Text x -> m{flagText=x}
FldExplicit -> m{flagExplicit=True}
FldTyp x -> m{flagTyp=x}
FldEmpty x -> m{flagOpt=Just x}
FldFlag x -> m{flagFlag=x:flagFlag m}
FldArgs -> m{flagArgs=Just Nothing}
FldArgPos i -> m{flagArgs=Just (Just i)}
FldUnknown -> m{flagUnknown=True}
x -> error $ "Invalid attribute at argument level: " ++ show x
empty :: (Show a, Typeable a) => a -> Attrib
empty x = Attrib $ return $ case cast x of
Just y -> FldEmpty y
_ -> FldEmpty $ show x
typ :: String -> Attrib
typ = Attrib . return . FldTyp
text :: String -> Attrib
text = Attrib . return . Text
flag :: String -> Attrib
flag = Attrib . return . FldFlag
args :: Attrib
args = Attrib [FldArgs]
argPos :: Int -> Attrib
argPos = Attrib . return . FldArgPos
typFile :: Attrib
typFile = typ "FILE"
typDir :: Attrib
typDir = typ "DIR"
helpSuffix :: [String] -> Attrib
helpSuffix = Attrib . return . HelpSuffix
unknownFlags :: Attrib
unknownFlags = Attrib [FldUnknown]
defMode :: Attrib
defMode = Attrib [ModDefault]
prog :: String -> Attrib
prog = Attrib . return . ModProg
enum :: (Typeable a, Eq a, Show a) => a -> [a] -> a
enum def xs = unsafePerformIO $ do
ys <- forM xs $ \x -> do
y <- collect x
return $ flagInfo flagDefault{flagKey=map toLower (show x), flagType=FlagBool (toDyn x), flagVal = toDyn False} y
return $ def &= Attrib [FldEnum ys]
explicit :: Attrib
explicit = Attrib [FldExplicit]