{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
module Console.Options
(
defaultMain
, defaultMainWith
, parseOptions
, OptionRes(..)
, OptionDesc
, programName
, programVersion
, programDescription
, command
, FlagFrag(..)
, flag
, flagParam
, flagMany
, argument
, remainingArguments
, action
, description
, Action
, ValueParser
, FlagParser(..)
, Flag
, FlagLevel
, FlagParam
, FlagMany
, Arg
, ArgRemaining
, Params
, paramsFlags
, getParams
) where
import Foundation (toList, toCount, fromList)
import Console.Options.Flags hiding (Flag)
import qualified Console.Options.Flags as F
import Console.Options.Nid
import Console.Options.Utils
import Console.Options.Monad
import Console.Options.Types
import Console.Display (justify, Justify(..))
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Data.List
import Data.Maybe (fromMaybe)
import Data.Version
import Data.Functor.Identity
import System.Environment (getArgs, getProgName)
import System.Exit
setDescription :: String -> Command r -> Command r
setDescription desc (Command hier _ opts act) = Command hier desc opts act
setAction :: Action r -> Command r -> Command r
setAction act (Command hier desc opts _) = Command hier desc opts (ActionWrapped act)
addOption :: FlagDesc -> Command r -> Command r
addOption opt (Command hier desc opts act) = Command hier desc (opt : opts) act
tweakOption :: Nid -> (FlagDesc -> FlagDesc) -> Command r -> Command r
tweakOption nid mapFlagDesc (Command hier desc opts act) =
Command hier desc (modifyNid opts) act
where
modifyNid [] = []
modifyNid (f:fs)
| flagNid f == nid = mapFlagDesc f : fs
| otherwise = f : modifyNid fs
addArg :: Argument -> Command r -> Command r
addArg arg = modifyHier $ \hier ->
case hier of
CommandLeaf l -> CommandLeaf (arg:l)
CommandTree {} -> hier
data FlagParser a =
FlagRequired (ValueParser a)
| FlagOptional a (ValueParser a)
type ValueParser a = String -> Either String a
data OptionRes r =
OptionSuccess Params (Action r)
| OptionHelp
| OptionError String
| OptionInvalid String
defaultMain :: OptionDesc (IO ()) () -> IO ()
defaultMain dsl = getArgs >>= defaultMainWith dsl
defaultMainWith :: OptionDesc (IO ()) () -> [String] -> IO ()
defaultMainWith dsl args = do
progrName <- getProgName
let (programDesc, res) = parseOptions (programName progrName >> dsl) args
in case res of
OptionError s -> putStrLn s >> exitFailure
OptionHelp -> help (stMeta programDesc) (stCT programDesc) >> exitSuccess
OptionSuccess params r -> r (getParams params)
OptionInvalid s -> putStrLn s >> exitFailure
parseOptions :: OptionDesc r () -> [String] -> (ProgramDesc r, OptionRes r)
parseOptions dsl args =
let descState = gatherDesc dsl
in (descState, runOptions (stCT descState) args)
help :: ProgramMeta -> Command (IO ()) -> IO ()
help pmeta (Command hier _ commandOpts _) = do
tell (fromMaybe "<program>" (programMetaName pmeta) ++ " version " ++ fromMaybe "<undefined>" (programMetaVersion pmeta) ++ "\n")
tell "\n"
maybe (return ()) (\d -> tell d >> tell "\n\n") (programMetaDescription pmeta)
tell "Options:\n"
tell "\n"
mapM_ (tell . printOpt 0) commandOpts
case hier of
CommandTree subs -> do
tell "\n"
tell "Commands:\n"
let cmdLength = maximum (map (length . fst) subs) + 2
forM_ subs $ \(n, c) -> tell $ indent 2 (toList (justify JustifyRight (toCount cmdLength) (fromList n)) ++ getCommandDescription c ++ "\n")
tell "\n"
mapM_ (printSub 2) subs
CommandLeaf _ ->
return ()
where
tell = putStr
printSub iLevel (name, cmdOpt) = do
tell $ "\nCommand `" ++ name ++ "':\n\n"
tell $ indent iLevel "Options:\n\n"
mapM_ (tell . printOpt iLevel) (getCommandOptions cmdOpt)
case getCommandHier cmdOpt of
CommandTree subs -> do
tell $ indent iLevel "Commands:\n"
let cmdLength = maximum (map (length . fst) subs) + 2 + iLevel
forM_ subs $ \(n, c) -> tell $ indent (iLevel + 2) (toList (justify JustifyRight (toCount cmdLength) (fromList n)) ++ getCommandDescription c ++ "\n")
tell "\n"
mapM_ (printSub (iLevel + 2)) subs
CommandLeaf _ -> pure ()
printOpt iLevel fd =
let optShort = maybe (replicate 2 ' ') (\c -> "-" ++ [c]) $ flagShort ff
optLong = maybe (replicate 8 ' ') (\s -> "--" ++ s) $ flagLong ff
optDesc = maybe "" (" " ++) $ flagDescription ff
in indent (iLevel + 2) $ intercalate " " [optShort, optLong, optDesc] ++ "\n"
where
ff = flagFragments fd
runOptions :: Command r
-> [String]
-> OptionRes r
runOptions ct allArgs
| "--help" `elem` allArgs = OptionHelp
| "-h" `elem` allArgs = OptionHelp
| otherwise = go [] ct allArgs
where
go :: [[F.Flag]] -> Command r -> [String] -> OptionRes r
go parsedOpts (Command hier _ commandOpts act) unparsedArgs =
case parseFlags commandOpts unparsedArgs of
(opts, unparsed, []) -> do
case hier of
CommandTree subs -> do
case unparsed of
[] -> errorExpectingMode subs
(x:xs) -> case lookup x subs of
Nothing -> errorInvalidMode x subs
Just subTree -> go (opts:parsedOpts) subTree xs
CommandLeaf unnamedArgs ->
case validateUnnamedArgs (reverse unnamedArgs) unparsed of
Left err -> errorUnnamedArgument err
Right (pinnedArgs, remainingArgs) -> do
let flags = concat (opts:parsedOpts)
case act of
NoActionWrapped -> OptionInvalid "no action defined"
ActionWrapped a ->
let params = Params flags
pinnedArgs
remainingArgs
in OptionSuccess params a
(_, _, ers) -> do
OptionError $ mconcat $ map showOptionError ers
validateUnnamedArgs :: [Argument] -> [String] -> Either String ([String], [String])
validateUnnamedArgs argOpts l =
v [] argOpts >>= \(opts, _hasCatchall) -> do
let unnamedRequired = length opts
if length l < unnamedRequired
then Left "missing arguments"
else Right $ splitAt unnamedRequired l
where
v :: [Argument] -> [Argument] -> Either String ([Argument], Bool)
v acc [] = Right (reverse acc, False)
v acc (a@(Argument {}):as) = v (a:acc) as
v acc ((ArgumentCatchAll {}):[]) = Right (reverse acc, True)
v _ ((ArgumentCatchAll {}):_ ) = Left "arguments expected after remainingArguments"
showOptionError (FlagError opt i s) = do
let optName = (maybe "" (:[]) $ flagShort $ flagFragments opt) ++ " " ++ (maybe "" id $ flagLong $ flagFragments opt)
in ("error: " ++ show i ++ " option " ++ optName ++ " : " ++ s ++ "\n")
errorUnnamedArgument err =
OptionError $ mconcat
[ "error: " ++ err
, ""
]
errorExpectingMode subs =
OptionError $ mconcat (
[ "error: expecting one of the following mode:\n"
, "\n"
] ++ map (indent 4 . (++ "\n") . fst) subs)
errorInvalidMode got subs =
OptionError $ mconcat (
[ "error: invalid mode '" ++ got ++ "', expecting one of the following mode:\n"
, ""
] ++ map (indent 4 . (++ "\n") . fst) subs)
indent :: Int -> String -> String
indent n s = replicate n ' ' ++ s
programName :: String -> OptionDesc r ()
programName s = modify $ \st -> st { stMeta = (stMeta st) { programMetaName = Just s } }
programVersion :: Version -> OptionDesc r ()
programVersion s = modify $ \st -> st { stMeta = (stMeta st) { programMetaVersion = Just $ showVersion s } }
programDescription :: String -> OptionDesc r ()
programDescription s = modify $ \st -> st { stMeta = (stMeta st) { programMetaDescription = Just s } }
description :: String -> OptionDesc r ()
description doc = modify $ \st -> st { stCT = setDescription doc (stCT st) }
modifyHier :: (CommandHier r -> CommandHier r) -> Command r -> Command r
modifyHier f (Command hier desc opts act) = Command (f hier) desc opts act
modifyCT :: (Command r -> Command r) -> OptionDesc r ()
modifyCT f = modify $ \st -> st { stCT = f (stCT st) }
command :: String -> OptionDesc r () -> OptionDesc r ()
command name sub = do
let subSt = gatherDesc sub
modifyCT (addCommand (stCT subSt))
where addCommand subTree = modifyHier $ \hier ->
case hier of
CommandLeaf _ -> CommandTree [(name,subTree)]
CommandTree t -> CommandTree ((name, subTree) : t)
action :: Action r -> OptionDesc r ()
action ioAct = modify $ \st -> st { stCT = setAction ioAct (stCT st) }
flagParam :: FlagFrag -> FlagParser a -> OptionDesc r (FlagParam a)
flagParam frag fp = do
nid <- getNextID
let fragmentFlatten = flattenFragments frag
let opt = FlagDesc
{ flagFragments = fragmentFlatten
, flagNid = nid
, F.flagArg = argp
, flagArgValidate = validator
, flagArity = 1
}
modify $ \st -> st { stCT = addOption opt (stCT st) }
case mopt of
Just a -> return (FlagParamOpt nid a parser)
Nothing -> return (FlagParam nid parser)
where
(argp, parser, mopt, validator) = case fp of
FlagRequired p -> (FlagArgHave, toArg p, Nothing, isValid p)
FlagOptional a p -> (FlagArgMaybe, toArg p, Just a, isValid p)
toArg :: (String -> Either String a) -> String -> a
toArg p = either (error "internal error toArg") id . p
isValid f = either FlagArgInvalid (const FlagArgValid) . f
flagMany :: OptionDesc r (FlagParam a) -> OptionDesc r (FlagMany a)
flagMany fp = do
f <- fp
let nid = case f of
FlagParamOpt n _ _ -> n
FlagParam n _ -> n
modify $ \st -> st { stCT = tweakOption nid (\fd -> fd { flagArity = maxBound }) (stCT st) }
return $ FlagMany f
flag :: FlagFrag -> OptionDesc r (Flag Bool)
flag frag = do
nid <- getNextID
let fragmentFlatten = flattenFragments frag
let opt = FlagDesc
{ flagFragments = fragmentFlatten
, flagNid = nid
, F.flagArg = FlagArgNone
, flagArgValidate = error ""
, flagArity = 0
}
modify $ \st -> st { stCT = addOption opt (stCT st) }
return (Flag nid)
argument :: String -> ValueParser a -> OptionDesc r (Arg a)
argument name fp = do
idx <- getNextIndex
let a = Argument { argumentName = name
, argumentDescription = ""
, argumentValidate = either Just (const Nothing) . fp
}
modifyCT $ addArg a
return (Arg idx (either (error "internal error") id . fp))
remainingArguments :: String -> OptionDesc r (ArgRemaining [String])
remainingArguments name = do
let a = ArgumentCatchAll { argumentName = name
, argumentDescription = ""
}
modifyCT $ addArg a
return ArgsRemaining