module Options
(
Options
, defaultOptions
, runCommand
, Subcommand
, subcommand
, runSubcommand
, defineOptions
, boolOption
, stringOption
, stringsOption
, textOption
, textsOption
, pathOption
, intOption
, integerOption
, floatOption
, doubleOption
, ImportedOptions
, importedOptions
, options
, Option
, option
, optionShortFlags
, optionLongFlags
, optionDefault
, optionType
, optionDescription
, optionGroup
, OptionType
, optionTypeBool
, optionTypeString
, optionTypeText
, optionTypeFilePath
, optionTypeInt
, optionTypeInt8
, optionTypeInt16
, optionTypeInt32
, optionTypeInt64
, optionTypeWord
, optionTypeWord8
, optionTypeWord16
, optionTypeWord32
, optionTypeWord64
, optionTypeInteger
, optionTypeFloat
, optionTypeDouble
, optionTypeMaybe
, optionTypeList
, optionTypeSet
, optionTypeMap
, optionTypeEnum
, Group
, group
, groupTitle
, groupDescription
, Parsed
, parsedError
, parsedHelp
, ParsedOptions
, parsedOptions
, parsedArguments
, parseOptions
, ParsedSubcommand
, parsedSubcommand
, parseSubcommand
) where
import Control.Monad (forM, unless, when)
import Control.Monad.Error (ErrorT, runErrorT, throwError)
import Control.Monad.IO.Class
import Control.Monad.Reader (Reader, runReader, ask)
import Control.Monad.State (StateT, execStateT, get, modify)
import Data.List (foldl', intercalate)
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified System.Environment
import System.Exit (exitFailure, exitSuccess)
import System.IO
import qualified Filesystem.Path as Path
import qualified Filesystem.Path.Rules as Path
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (mkNameG_tc)
import Options.Help
import Options.OptionTypes
import Options.Tokenize
import Options.Types
import Options.Util
class Options a where
optionsDefs :: OptionDefinitions a
optionsParse' :: TokensFor a -> Either String a
optionsMeta :: OptionsMeta a
optionsParse :: Options a => TokensFor a -> Either String (a, [String])
optionsParse tokens@(TokensFor _ args) = case optionsParse' tokens of
Left err -> Left err
Right opts -> Right (opts, args)
data OptionsMeta a = OptionsMeta
{ optionsMetaName :: Name
, optionsMetaKeys :: Set.Set String
, optionsMetaShortFlags :: Set.Set Char
, optionsMetaLongFlags :: Set.Set String
}
defaultOptions :: Options a => a
defaultOptions = opts where
parsed = parseOptions []
opts = case parsedOptions parsed of
Just v -> v
Nothing -> error ("Internal error while parsing default options: " ++ (case parsedError parsed of
Just err -> err
Nothing -> "(no error provided)"))
newtype OptionsM a = OptionsM { unOptionsM :: StateT OptionsDeclState (ErrorT String (Reader Loc)) a }
data OptionsDeclState = OptionsDeclState
{ stDecls :: [(Name, Type, Q Exp, Q Exp)]
, stSeenFieldNames :: Set.Set String
, stSeenKeys :: Set.Set String
, stSeenShortFlags :: Set.Set Char
, stSeenLongFlags :: Set.Set String
}
instance Monad OptionsM where
return = OptionsM . return
m >>= f = OptionsM (unOptionsM m >>= (unOptionsM . f))
runOptionsM :: Loc -> OptionsM () -> Either String OptionsDeclState
runOptionsM loc (OptionsM m) = runReader (runErrorT (execStateT m initState)) loc where
initState = OptionsDeclState [] Set.empty Set.empty Set.empty Set.empty
defineOptions :: String -> OptionsM () -> Q [Dec]
defineOptions rawName optionsM = do
loc <- location
let dataName = mkName rawName
declState <- case runOptionsM loc optionsM of
Left err -> fail err
Right st -> return st
let fields = stDecls declState
let dataDec = DataD [] dataName [] [RecC dataName
[(fName, NotStrict, t) | (fName, t, _, _) <- fields]
][]
exp_optionsDefs <- getOptionsDefs fields
exp_optionsParse <- getOptionsParse dataName fields
exp_optionsMeta <- getOptionsMeta loc rawName declState
let instanceDec = InstanceD [] (AppT (ConT ''Options) (ConT dataName))
[ ValD (VarP 'optionsDefs) (NormalB exp_optionsDefs) []
, ValD (VarP 'optionsParse') (NormalB exp_optionsParse) []
, ValD (VarP 'optionsMeta) (NormalB exp_optionsMeta) []
]
return [dataDec, instanceDec]
getOptionsDefs :: [(Name, Type, Q Exp, Q Exp)] -> Q Exp
getOptionsDefs fields = do
infoExps <- forM fields (\(_, _, infoExp, _) -> infoExp)
[| OptionDefinitions (concat $(return (ListE infoExps))) [] |]
getOptionsParse :: Name -> [(Name, Type, Q Exp, Q Exp)] -> Q Exp
getOptionsParse dataName fields = do
let genBind (_, _, _, qParseExp) = do
varName <- newName "_val"
parseExp <- qParseExp
return (varName, BindS (VarP varName) parseExp)
names_and_binds <- mapM genBind fields
let names = [n | (n, _) <- names_and_binds]
let binds = [b | (_, b) <- names_and_binds]
returnExp <- [| return |]
let consExp = foldl' AppE (ConE dataName) (map VarE names)
let parserM = return (DoE (binds ++ [NoBindS (AppE returnExp consExp)]))
[| unParserM $parserM |]
getOptionsMeta :: Loc -> String -> OptionsDeclState -> Q Exp
getOptionsMeta loc typeName st = do
let pkg = loc_package loc
let mod' = loc_module loc
let keys = Set.toList (stSeenKeys st)
let shorts = Set.toList (stSeenShortFlags st)
let longs = Set.toList (stSeenLongFlags st)
[| OptionsMeta (mkNameG_tc pkg mod' typeName) (Set.fromList keys) (Set.fromList shorts) (Set.fromList longs) |]
newtype ParserM optType a = ParserM { unParserM :: TokensFor optType -> Either String a }
instance Monad (ParserM optType) where
return x = ParserM (\_ -> Right x)
m >>= f = ParserM (\env -> case unParserM m env of
Left err -> Left err
Right x -> unParserM (f x) env)
putOptionDecl :: Name -> Type -> Q Exp -> Q Exp -> OptionsM ()
putOptionDecl name qtype infoExp parseExp = OptionsM (modify (\st -> st
{ stDecls = stDecls st ++ [(name, qtype, infoExp, parseExp)]
}))
option :: String
-> (Option String -> Option a)
-> OptionsM ()
option fieldName f = do
let emptyGroup = Group
{ groupName = Nothing
, groupTitle = ""
, groupDescription = ""
}
let opt = f (Option
{ optionShortFlags = []
, optionLongFlags = []
, optionDefault = ""
, optionType = optionTypeString
, optionDescription = ""
, optionGroup = emptyGroup
})
loc <- OptionsM ask
let key = loc_package loc ++ ":" ++ loc_module loc ++ ":" ++ fieldName
let shorts = optionShortFlags opt
let longs = optionLongFlags opt
let def = optionDefault opt
let desc = optionDescription opt
let optGroup = optionGroup opt
let optGroupDesc = groupTitle optGroup
let optGroupHelpDesc = groupDescription optGroup
let groupInfoExp = case groupName optGroup of
Nothing -> [| Nothing |]
Just n -> [| Just (GroupInfo n optGroupDesc optGroupHelpDesc) |]
let OptionType thType unary parseOptType parseExp = optionType opt
checkFieldName fieldName
checkValidFlags fieldName shorts longs
checkUniqueKey key
checkUniqueFlags fieldName shorts longs
case parseOptType def of
Right _ -> return ()
Left err -> OptionsM (throwError ("Invalid default value for option " ++ show fieldName ++ ": " ++ err))
OptionsM (modify (\st -> st
{ stSeenFieldNames = Set.insert fieldName (stSeenFieldNames st)
, stSeenKeys = Set.insert key (stSeenKeys st)
, stSeenShortFlags = Set.union (Set.fromList shorts) (stSeenShortFlags st)
, stSeenLongFlags = Set.union (Set.fromList longs) (stSeenLongFlags st)
}))
putOptionDecl
(mkName fieldName)
thType
[| [OptionInfo key shorts longs def unary desc $groupInfoExp] |]
[| parseOptionTok key $parseExp def |]
parseOptionTok :: String -> (String -> Either String a) -> String -> ParserM optType a
parseOptionTok key p def = do
TokensFor tokens _ <- ParserM (\t -> Right t)
case lookup key tokens of
Nothing -> case p def of
Left err -> ParserM (\_ -> Left ("Internal error while parsing default options: " ++ err))
Right a -> return a
Just (flagName, val) -> case p val of
Left err -> ParserM (\_ -> Left ("Value for flag " ++ flagName ++ " is invalid: " ++ err))
Right a -> return a
checkFieldName :: String -> OptionsM ()
checkFieldName name = do
unless (validFieldName name)
(OptionsM (throwError ("Option field name " ++ show name ++ " is invalid.")))
st <- OptionsM get
when (Set.member name (stSeenFieldNames st))
(OptionsM (throwError ("Duplicate definitions of field " ++ show name ++ ".")))
checkUniqueKey :: String -> OptionsM ()
checkUniqueKey key = do
st <- OptionsM get
when (Set.member key (stSeenKeys st))
(OptionsM (throwError ("Option key " ++ show key ++ " has already been defined. This should never happen; please send an error report to the maintainer of the 'options' package.")))
checkValidFlags :: String -> [Char] -> [String] -> OptionsM ()
checkValidFlags fieldName shorts longs = do
when (length shorts == 0 && length longs == 0)
(OptionsM (throwError ("Option " ++ show fieldName ++ " does not define any flags.")))
when (hasDuplicates shorts)
(OptionsM (throwError ("Option " ++ show fieldName ++ " has duplicate short flags.")))
case filter (not . validShortFlag) shorts of
[] -> return ()
invalid -> OptionsM (throwError ("Option " ++ show fieldName ++ " has invalid short flags " ++ show invalid ++ "."))
when (hasDuplicates longs)
(OptionsM (throwError ("Option " ++ show fieldName ++ " has duplicate long flags.")))
case filter (not . validLongFlag) longs of
[] -> return ()
invalid -> OptionsM (throwError ("Option " ++ show fieldName ++ " has invalid long flags " ++ show invalid ++ "."))
checkUniqueFlags :: String -> [Char] -> [String] -> OptionsM ()
checkUniqueFlags fieldName shorts longs = do
st <- OptionsM get
let dupShort = do
f <- Set.toList (Set.intersection (stSeenShortFlags st) (Set.fromList shorts))
return ('-' : [f])
let dupLong = do
f <- Set.toList (Set.intersection (stSeenLongFlags st) (Set.fromList longs))
return ("--" ++ f)
let dups = dupShort ++ dupLong
unless (null dups)
(OptionsM (throwError ("Option " ++ show fieldName ++ " uses already-defined flags " ++ show dups ++ ".")))
options :: String -> ImportedOptions a -> OptionsM ()
options fieldName (ImportedOptions meta) = do
checkFieldName fieldName
let typeName = optionsMetaName meta
st <- OptionsM get
let dupKeys = Set.intersection (stSeenKeys st) (optionsMetaKeys meta)
unless (Set.null dupKeys)
(OptionsM (throwError ("Imported options type " ++ show typeName ++ " contains duplicate keys " ++ show (Set.toList dupKeys) ++ ". This should never happen; please send an error report to the maintainer of the 'options' package.")))
let dupShort = do
f <- Set.toList (Set.intersection (stSeenShortFlags st) (optionsMetaShortFlags meta))
return ('-' : [f])
let dupLong = do
f <- Set.toList (Set.intersection (stSeenLongFlags st) (optionsMetaLongFlags meta))
return ("--" ++ f)
let dups = dupShort ++ dupLong
unless (null dups)
(OptionsM (throwError ("Imported options type " ++ show typeName ++ " contains conflicting definitions for flags " ++ show dups ++ ".")))
OptionsM (modify (\st' -> st'
{ stSeenFieldNames = Set.insert fieldName (stSeenFieldNames st)
, stSeenShortFlags = Set.union (optionsMetaShortFlags meta) (stSeenShortFlags st)
, stSeenLongFlags = Set.union (optionsMetaLongFlags meta) (stSeenLongFlags st)
}))
putOptionDecl
(mkName fieldName)
(ConT typeName)
[| suboptsDefs $(varE (mkName fieldName)) |]
[| parseSubOptions |]
newtype ImportedOptions a = ImportedOptions (OptionsMeta a)
importedOptions :: Options a => ImportedOptions a
importedOptions = ImportedOptions optionsMeta
castTokens :: TokensFor a -> TokensFor b
castTokens (TokensFor tokens args) = TokensFor tokens args
parseSubOptions :: Options a => ParserM optType a
parseSubOptions = do
tokens <- ParserM (\t -> Right t)
case optionsParse' (castTokens tokens) of
Left err -> ParserM (\_ -> Left err)
Right x -> return x
suboptsDefs :: Options a => (b -> a) -> [OptionInfo]
suboptsDefs rec = defsB where
defsB = case defsA rec of
OptionDefinitions opts _ -> opts
defsA :: Options a => (b -> a) -> OptionDefinitions a
defsA _ = optionsDefs
boolOption :: String
-> String
-> Bool
-> String
-> OptionsM ()
boolOption name flag def desc = option name (\o -> o
{ optionLongFlags = [flag]
, optionDefault = if def then "true" else "false"
, optionType = optionTypeBool
, optionDescription = desc
})
stringOption :: String
-> String
-> String
-> String
-> OptionsM ()
stringOption name flag def desc = option name (\o -> o
{ optionLongFlags = [flag]
, optionDefault = def
, optionDescription = desc
})
stringsOption :: String
-> String
-> [String]
-> String
-> OptionsM ()
stringsOption name flag def desc = option name (\o -> o
{ optionLongFlags = [flag]
, optionDefault = intercalate "," def
, optionType = optionTypeList ',' optionTypeString
, optionDescription = desc
})
textOption :: String
-> String
-> Text.Text
-> String
-> OptionsM ()
textOption name flag def desc = option name (\o -> o
{ optionLongFlags = [flag]
, optionDefault = Text.unpack def
, optionType = optionTypeText
, optionDescription = desc
})
textsOption :: String
-> String
-> [Text.Text]
-> String
-> OptionsM ()
textsOption name flag def desc = option name (\o -> o
{ optionLongFlags = [flag]
, optionDefault = Text.unpack (Text.intercalate (Text.pack ",") def)
, optionType = optionTypeList ',' optionTypeText
, optionDescription = desc
})
pathOption :: String
-> String
-> Path.FilePath
-> String
-> OptionsM ()
pathOption name flag def desc = option name (\o -> o
{ optionLongFlags = [flag]
#if defined(CABAL_OS_WINDOWS)
, optionDefault = Path.encodeString Path.windows def
#else
, optionDefault = Path.encodeString Path.posix_ghc704 def
#endif
, optionType = optionTypeFilePath
, optionDescription = desc
})
intOption :: String
-> String
-> Int
-> String
-> OptionsM ()
intOption name flag def desc = option name (\o -> o
{ optionLongFlags = [flag]
, optionDefault = show def
, optionType = optionTypeInt
, optionDescription = desc
})
integerOption :: String
-> String
-> Integer
-> String
-> OptionsM ()
integerOption name flag def desc = option name (\o -> o
{ optionLongFlags = [flag]
, optionDefault = show def
, optionType = optionTypeInteger
, optionDescription = desc
})
floatOption :: String
-> String
-> Float
-> String
-> OptionsM ()
floatOption name flag def desc = option name (\o -> o
{ optionLongFlags = [flag]
, optionDefault = show def
, optionType = optionTypeFloat
, optionDescription = desc
})
doubleOption :: String
-> String
-> Double
-> String
-> OptionsM ()
doubleOption name flag def desc = option name (\o -> o
{ optionLongFlags = [flag]
, optionDefault = show def
, optionType = optionTypeDouble
, optionDescription = desc
})
group :: String
-> (Group -> Group)
-> Group
group name f = f (Group
{ groupName = Just name
, groupTitle = ""
, groupDescription = ""
})
class Parsed a where
parsedError_ :: a -> Maybe String
parsedHelp_ :: a -> String
data ParsedOptions opts = ParsedOptions (Maybe opts) (Maybe String) String [String]
data ParsedSubcommand action = ParsedSubcommand (Maybe action) (Maybe String) String
instance Parsed (ParsedOptions a) where
parsedError_ (ParsedOptions _ x _ _) = x
parsedHelp_ (ParsedOptions _ _ x _) = x
instance Parsed (ParsedSubcommand a) where
parsedError_ (ParsedSubcommand _ x _) = x
parsedHelp_ (ParsedSubcommand _ _ x) = x
parsedOptions :: ParsedOptions opts -> Maybe opts
parsedOptions (ParsedOptions x _ _ _) = x
parsedArguments :: ParsedOptions opts -> [String]
parsedArguments (ParsedOptions _ _ _ x) = x
parsedSubcommand :: ParsedSubcommand action -> Maybe action
parsedSubcommand (ParsedSubcommand x _ _) = x
parsedError :: Parsed a => a -> Maybe String
parsedError = parsedError_
parsedHelp :: Parsed a => a -> String
parsedHelp = parsedHelp_
parseOptions :: Options opts => [String] -> ParsedOptions opts
parseOptions argv = parsed where
defs = addHelpFlags optionsDefs
help flag = helpFor flag defs Nothing
parsed = case tokenize defs argv of
(_, Left err) -> ParsedOptions Nothing (Just err) (help HelpSummary) []
(_, Right tokens) -> case checkHelpFlag tokens of
Just helpFlag -> ParsedOptions Nothing Nothing (help helpFlag) []
Nothing -> case optionsParse tokens of
Left err -> ParsedOptions Nothing (Just err) (help HelpSummary) []
Right (opts, args) -> ParsedOptions (Just opts) Nothing (help HelpSummary) args
runCommand :: (MonadIO m, Options opts) => (opts -> [String] -> m a) -> m a
runCommand io = do
argv <- liftIO System.Environment.getArgs
let parsed = parseOptions argv
case parsedOptions parsed of
Just opts -> io opts (parsedArguments parsed)
Nothing -> liftIO $ case parsedError parsed of
Just err -> do
hPutStrLn stderr (parsedHelp parsed)
hPutStrLn stderr err
exitFailure
Nothing -> do
hPutStr stdout (parsedHelp parsed)
exitSuccess
data Subcommand cmdOpts action = Subcommand String [OptionInfo] (TokensFor cmdOpts -> Either String action)
subcommand :: (Options cmdOpts, Options subcmdOpts)
=> String
-> (cmdOpts -> subcmdOpts -> [String] -> action)
-> Subcommand cmdOpts action
subcommand name fn = Subcommand name opts checkTokens where
opts = optInfosFromOptType fn optionsDefs
optInfosFromOptType :: Options subcmdOpts => (cmdOpts -> subcmdOpts -> [String] -> action) -> OptionDefinitions subcmdOpts -> [OptionInfo]
optInfosFromOptType _ (OptionDefinitions infos _) = infos
checkTokens tokens = case optionsParse' tokens of
Left err -> Left err
Right cmdOpts -> case optionsParse (castTokens tokens) of
Left err -> Left err
Right (subcmdOpts, args) -> Right (fn cmdOpts subcmdOpts args)
subcommandInfo :: Subcommand cmdOpts action -> (String, [OptionInfo])
subcommandInfo (Subcommand name opts _) = (name, opts)
addSubcommands :: [Subcommand cmdOpts action] -> OptionDefinitions cmdOpts -> OptionDefinitions cmdOpts
addSubcommands subcommands defs = case defs of
OptionDefinitions mainOpts subcmdOpts -> OptionDefinitions mainOpts (subcmdOpts ++ map subcommandInfo subcommands)
findSubcmd :: [Subcommand cmdOpts action] -> String -> TokensFor cmdOpts -> Either String action
findSubcmd subcommands name tokens = subcmd where
asoc = [(n, cmd) | cmd@(Subcommand n _ _) <- subcommands]
subcmd = case lookup name asoc of
Nothing -> Left ("Unknown subcommand " ++ show name ++ ".")
Just (Subcommand _ _ checkTokens) -> checkTokens tokens
parseSubcommand :: Options cmdOpts => [Subcommand cmdOpts action] -> [String] -> ParsedSubcommand action
parseSubcommand subcommands argv = parsed where
defs = addHelpFlags (addSubcommands subcommands optionsDefs)
help flag = helpFor flag defs
parsed = case tokenize defs argv of
(subcmd, Left err) -> ParsedSubcommand Nothing (Just err) (help HelpSummary subcmd)
(Nothing, Right tokens) -> case checkHelpFlag tokens of
Just helpFlag -> ParsedSubcommand Nothing Nothing (help helpFlag Nothing)
Nothing -> ParsedSubcommand Nothing (Just "No subcommand specified") (help HelpSummary Nothing)
(Just subcmdName, Right tokens) -> case findSubcmd subcommands subcmdName tokens of
Left err -> ParsedSubcommand Nothing (Just err) (help HelpSummary (Just subcmdName))
Right io -> case checkHelpFlag tokens of
Just helpFlag -> ParsedSubcommand Nothing Nothing (help helpFlag (Just subcmdName))
Nothing -> ParsedSubcommand (Just io) Nothing (help HelpSummary (Just subcmdName))
runSubcommand :: (Options opts, MonadIO m) => [Subcommand opts (m a)] -> m a
runSubcommand subcommands = do
argv <- liftIO System.Environment.getArgs
let parsed = parseSubcommand subcommands argv
case parsedSubcommand parsed of
Just cmd -> cmd
Nothing -> liftIO $ case parsedError parsed of
Just err -> do
hPutStrLn stderr (parsedHelp parsed)
hPutStrLn stderr err
exitFailure
Nothing -> do
hPutStr stdout (parsedHelp parsed)
exitSuccess