diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/hoehrmann_utf8.c b/cbits/hoehrmann_utf8.c new file mode 100644 --- /dev/null +++ b/cbits/hoehrmann_utf8.c @@ -0,0 +1,60 @@ +/** + * Copyright (c) 2008-2010 Björn Höhrmann + * + * Permission is hereby granted, free of charge, to any person obtaining + * a copy of this software and associated documentation files (the + * "Software"), to deal in the Software without restriction, including + * without limitation the rights to use, copy, modify, merge, publish, + * distribute, sublicense, and/or sell copies of the Software, and to + * permit persons to whom the Software is furnished to do so, subject to + * the following conditions: + * + * The above copyright notice and this permission notice shall be included + * in all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY + * CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, + * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE + * SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +**/ + +#define UTF8_ACCEPT 0 +#define UTF8_REJECT 12 + +static const uint8_t utf8d[] = { + /* The first part of the table maps bytes to character classes that + * to reduce the size of the transition table and create bitmasks. + */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, + 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, + 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, + 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8, + + /* The second part is a transition table that maps a combination + * of a state of the automaton and a character class to a state. + */ + 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12, + 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12, + 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12, + 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12, + 12,36,12,12,12,12,12,12,12,12,12,12, +}; + +static inline uint32_t +decode(uint32_t* state, uint32_t* codep, uint32_t byte) { + uint32_t type = utf8d[byte]; + + *codep = (*state != UTF8_ACCEPT) ? + (byte & 0x3fu) | (*codep << 6) : + (0xff >> type) & (byte); + + *state = utf8d[256 + *state + type]; + return *state; +} diff --git a/cbits/utf8.c b/cbits/utf8.c new file mode 100644 --- /dev/null +++ b/cbits/utf8.c @@ -0,0 +1,102 @@ +#include +#include "hoehrmann_utf8.c" + +#include + +/* Decode a UTF8-encoded string to UCS4 using the Höhrmann decoder. Any + * invalid bytes are stored using GHC 7.4's encoding for mixed-use strings. + * + * 'len' is the length of both 'utf8' and 'out'. + * + * Returns the number of items written to *out. + */ +int hsoptions_decode_string(uint8_t *utf8, uint32_t *out, int len) +{ + uint32_t state = UTF8_ACCEPT; + uint8_t *utf8_end = utf8 + len; + uint32_t codepoint = 0; + uint32_t *out_orig = out; + uint8_t *started_accept = utf8; + + while (utf8 < utf8_end) + { +#if defined(__i386__) || defined(__x86_64__) + /* Performance improvement from Bryan O'Sullivan. + * + * If some chunk of bytes is ASCII, it can be quickly pushed + * off into the output buffer without going through the UTF8 + * decoder. On little-endian systems, pure-ASCII text will + * have a mask of 0x80808080. + */ + if (state == UTF8_ACCEPT) + { + while (utf8 < utf8_end - 4) + { + codepoint = *((uint32_t *) utf8); + if ((codepoint & 0x80808080) != 0) + { break; } + + utf8 += 4; + *out++ = codepoint & 0xFF; + *out++ = (codepoint >> 8) & 0xFF; + *out++ = (codepoint >> 16) & 0xFF; + *out++ = (codepoint >> 24) & 0xFF; + } + started_accept = utf8; + } +#endif + switch (decode(&state, &codepoint, *utf8)) + { + case UTF8_ACCEPT: + /* Read a codepoint succesfully. Copy it out and + * continue. + */ + *out++ = codepoint; + started_accept = utf8++; + break; + case UTF8_REJECT: + /* The first byte of a new character was invalid. + * Escape it and begin again. + */ + if (started_accept == utf8) + { + *out++ = (uint32_t) (*utf8++) + 0xDC00; + started_accept = utf8; + } + + /* The decoder consumed some bytes before failing. + * Backtrack to escape everything after the last + * successfully read codepoint. + */ + else while (started_accept < utf8) + { + *out++ = (uint32_t) (*started_accept++) + 0xDC00; + } + + /* Continue looking for valid UTF8 sequences in the + * input buffer. + */ + state = UTF8_ACCEPT; + break; + default: + /* Decoder needs more input */ + utf8++; + break; + } + } + + /* See comments in case UTF8_REJECT. */ + if (state != UTF8_ACCEPT) + { + if (started_accept == utf8) + { + *out++ = (uint32_t) (*utf8) + 0xDC00; + } + else while (started_accept < utf8) + { + *out++ = (uint32_t) (*started_accept++) + 0xDC00; + } + } + + return out - out_orig; +} diff --git a/lib/Options.hs b/lib/Options.hs new file mode 100644 --- /dev/null +++ b/lib/Options.hs @@ -0,0 +1,969 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module: Options +-- License: MIT +-- +-- The @options@ package lets library and application developers easily work +-- with command-line options. +-- +-- The following example is a full program that can accept two options, +-- @--message@ and @--quiet@: +-- +-- @ +--{-\# LANGUAGE TemplateHaskell \#-} +-- +--import Options +-- +--'defineOptions' \"MainOptions\" $ do +-- 'stringOption' \"optMessage\" \"message\" \"Hello world!\" +-- \"A message to show the user.\" +-- 'boolOption' \"optQuiet\" \"quiet\" False +-- \"Whether to be quiet.\" +-- +--main :: IO () +--main = 'runCommand' $ \\opts args -> do +-- if optQuiet opts +-- then return () +-- else putStrLn (optMessage opts) +-- @ +-- +-- >$ ./hello +-- >Hello world! +-- >$ ./hello --message='ciao mondo' +-- >ciao mondo +-- >$ ./hello --quiet +-- >$ +-- +-- In addition, this library will automatically create documentation options +-- such as @--help@ and @--help-all@: +-- +-- >$ ./hello --help +-- >Help Options: +-- > -h, --help Show option summary. +-- > --help-all Show all help options. +-- > +-- >Application Options: +-- > --message A message to show the user. +-- > --quiet Whether to be quiet. +-- +module Options + ( + -- * Options + Options + , defaultOptions + + -- * Commands + , runCommand + + -- ** Subcommands + , Subcommand + , subcommand + , runSubcommand + + -- * Defining options + , defineOptions + + -- ** Simple option definitions + , boolOption + , stringOption + , stringsOption + , textOption + , textsOption + , pathOption + , intOption + , integerOption + , floatOption + , doubleOption + + -- ** Using imported options + , ImportedOptions + , importedOptions + , options + + -- ** Advanted option definitions + , Option + , option + , optionShortFlags + , optionLongFlags + , optionDefault + , optionType + , optionDescription + , optionGroup + + -- ** Option types + , OptionType + + , optionTypeBool + + , optionTypeString + , optionTypeText + , optionTypeFilePath + + , optionTypeInt + , optionTypeInt8 + , optionTypeInt16 + , optionTypeInt32 + , optionTypeInt64 + , optionTypeWord + , optionTypeWord8 + , optionTypeWord16 + , optionTypeWord32 + , optionTypeWord64 + , optionTypeInteger + + , optionTypeFloat + , optionTypeDouble + + , optionTypeMaybe + , optionTypeList + , optionTypeSet + , optionTypeMap + , optionTypeEnum + + -- * Option groups + , Group + , group + , groupTitle + , groupDescription + + -- * Parsing argument lists + , Parsed + , parsedError + , parsedHelp + + -- ** Parsing options + , ParsedOptions + , parsedOptions + , parsedArguments + , parseOptions + + -- ** Parsing subcommands + , 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 + +-- | Options are defined together in a single data type, which will be an +-- instance of 'Options'. +-- +-- See 'defineOptions' for details on defining instances of 'Options'. +-- +-- See 'options' for details on including imported 'Options' types in locally +-- defined options. +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 + } + +-- | An options value containing only the default values for each option. +-- This is equivalent to the options value when parsing an empty argument +-- list. +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 + +-- | Defines a new data type, containing fields for application or library +-- options. The new type will be an instance of 'Options'. +-- +-- Example: this use of @defineOptions@: +-- +-- @ +--'defineOptions' \"MainOptions\" $ do +-- 'stringOption' \"optMessage\" \"message\" \"Hello world!\" \"\" +-- 'boolOption' \"optQuiet\" \"quiet\" False \"\" +-- @ +-- +-- expands to the following definition: +-- +-- >data MainOptions = MainOptions +-- > { optMessage :: String +-- > , optQuiet :: Bool +-- > } +-- > +-- >instance Options MainOptions +-- +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)] + })) + +-- | Defines a new option in the current options type. +-- +-- All options must have a /field name/ and one or more /flags/. Options may +-- also have a default value, a description, or a group. +-- +-- The field name is how the option will be accessed in Haskell, and is +-- typically prefixed with \"opt\". This is used to define a record field, +-- and must be a valid Haskell field name (see 'defineOptions' for details). +-- +-- The /flags/ are how the user specifies an option on the command line. Flags +-- may be /short/ or /long/. See 'optionShortFlags' and 'optionLongFlags' for +-- details. +-- +-- @ +--'option' \"optPort\" (\\o -> o +-- { 'optionLongFlags' = [\"port\"] +-- , 'optionDefault' = \"80\" +-- , 'optionType' = 'optionTypeWord16' +-- } +-- @ +option :: String -- ^ Field name + -> (Option String -> Option a) -- ^ Option definition + -> 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 + -- shouldn't happen + 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 + -- Check that at least one flag is defined (in either 'shorts' or 'longs'). + when (length shorts == 0 && length longs == 0) + (OptionsM (throwError ("Option " ++ show fieldName ++ " does not define any flags."))) + + -- Check that 'shorts' contains only non-repeated letters and digits + 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 ++ ".")) + + -- Check that 'longs' contains only non-repeated, non-empty strings + -- containing {LETTER,DIGIT,-,_} and starting with a letter. + 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 + + -- Check that none of this option's flags are already used. + 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 ++ "."))) + +-- | Include options defined elsewhere into the current options definition. +-- +-- This is typically used by application developers to include options defined +-- in third-party libraries. For example, the author of the \"foo\" library +-- would define and export @FooOptions@: +-- +-- @ +--module Foo (FooOptions, foo) where +-- +--import Options +-- +--'defineOptions' \"FooOptions\" $ do +-- 'boolOption' \"optFrob\" \"frob\" True \"Enable frobnication.\" +-- +--foo :: FooOptions -> IO () +-- @ +-- +-- and the author of an application would use @options@ to let users specify +-- @--frob@: +-- +-- @ +--module Main where +-- +--import Options +--import Foo +-- +--'defineOptions' \"MainOptions\" $ do +-- 'boolOption' \"optVerbose\" \"verbose\" False \"Be really loud.\" +-- 'options' \"optFoo\" ('importedOptions' :: 'ImportedOptions' FooOptions) +-- +--main :: IO () +--main = runCommand $ \\opts args -> do +-- foo (optFoo opts) +-- @ +-- +-- Use of 'options' may be arbitrarily nested. Library authors are encouraged +-- to aggregate their options into a single top-level type, so application +-- authors can include it easily in their own option definitions. +options :: String -> ImportedOptions a -> OptionsM () +options fieldName (ImportedOptions meta) = do + checkFieldName fieldName + + let typeName = optionsMetaName meta + st <- OptionsM get + + -- Check unique keys + 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."))) + + -- Check unique flags + 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 + +-- | Define an option of type @'Bool'@. This is a simple wrapper around +-- 'option'. +boolOption :: String -- ^ Field name + -> String -- ^ Long flag + -> Bool -- ^ Default value + -> String -- ^ Description in @--help@ + -> OptionsM () +boolOption name flag def desc = option name (\o -> o + { optionLongFlags = [flag] + , optionDefault = if def then "true" else "false" + , optionType = optionTypeBool + , optionDescription = desc + }) + +-- | Define an option of type @'String'@. This is a simple wrapper around +-- 'option'. +stringOption :: String -- ^ Field name + -> String -- ^ Long flag + -> String -- ^ Default value + -> String -- ^ Description in @--help@ + -> OptionsM () +stringOption name flag def desc = option name (\o -> o + { optionLongFlags = [flag] + , optionDefault = def + , optionDescription = desc + }) + +-- | Define an option of type @['String']@. This is a simple wrapper around +-- 'option'. Items are comma-separated. +stringsOption :: String -- ^ Field name + -> String -- ^ Long flag + -> [String] -- ^ Default value + -> String -- ^ Description in @--help@ + -> OptionsM () +stringsOption name flag def desc = option name (\o -> o + { optionLongFlags = [flag] + , optionDefault = intercalate "," def + , optionType = optionTypeList ',' optionTypeString + , optionDescription = desc + }) + +-- | Define an option of type @'Text.Text'@. This is a simple wrapper around +-- 'option'. +textOption :: String -- ^ Field name + -> String -- ^ Long flag + -> Text.Text -- ^ Default value + -> String -- ^ Description in @--help@ + -> OptionsM () +textOption name flag def desc = option name (\o -> o + { optionLongFlags = [flag] + , optionDefault = Text.unpack def + , optionType = optionTypeText + , optionDescription = desc + }) + +-- | Define an option of type @['Text.Text']@. This is a simple wrapper around +-- 'option'. Items are comma-separated. +textsOption :: String -- ^ Field name + -> String -- ^ Long flag + -> [Text.Text] -- ^ Default value + -> String -- ^ Description in @--help@ + -> 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 + }) + +-- | Define an option of type @'Path.FilePath'@. This is a simple wrapper +-- around 'option'. +pathOption :: String -- ^ Field name + -> String -- ^ Long flag + -> Path.FilePath -- ^ Default value + -> String -- ^ Description in @--help@ + -> 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 + }) + +-- | Define an option of type @'Int'@. This is a simple wrapper around +-- 'option'. +intOption :: String -- ^ Field name + -> String -- ^ Long flag + -> Int -- ^ Default value + -> String -- ^ Description in @--help@ + -> OptionsM () +intOption name flag def desc = option name (\o -> o + { optionLongFlags = [flag] + , optionDefault = show def + , optionType = optionTypeInt + , optionDescription = desc + }) + +-- | Define an option of type @'Integer'@. This is a simple wrapper around +-- 'option'. +integerOption :: String -- ^ Field name + -> String -- ^ Long flag + -> Integer -- ^ Default value + -> String -- ^ Description in @--help@ + -> OptionsM () +integerOption name flag def desc = option name (\o -> o + { optionLongFlags = [flag] + , optionDefault = show def + , optionType = optionTypeInteger + , optionDescription = desc + }) + +-- | Define an option of type @'Float'@. This is a simple wrapper around +-- 'option'. +floatOption :: String -- ^ Field name + -> String -- ^ Long flag + -> Float -- ^ Default value + -> String -- ^ Description in @--help@ + -> OptionsM () +floatOption name flag def desc = option name (\o -> o + { optionLongFlags = [flag] + , optionDefault = show def + , optionType = optionTypeFloat + , optionDescription = desc + }) + +-- | Define an option of type @'Double'@. This is a simple wrapper around +-- 'option'. +doubleOption :: String -- ^ Field name + -> String -- ^ Long flag + -> Double -- ^ Default value + -> String -- ^ Description in @--help@ + -> OptionsM () +doubleOption name flag def desc = option name (\o -> o + { optionLongFlags = [flag] + , optionDefault = show def + , optionType = optionTypeDouble + , optionDescription = desc + }) + +-- | Define an option group. +-- +-- Option groups are used to make long @--help@ output more readable, by +-- hiding obscure or rarely-used options from the main summary. +-- +-- If an option is in a group named @\"examples\"@, it will only be shown +-- in the help output if the user provides the flag @--help-examples@ or +-- @--help-all@. The flag @--help-all@ will show all options, in all groups. +group :: String -- ^ Group name + -> (Group -> Group) + -> Group +group name f = f (Group + { groupName = Just name + , groupTitle = "" + , groupDescription = "" + }) + +-- | See @'parseOptions'@ and @'parseSubcommand'@. +class Parsed a where + parsedError_ :: a -> Maybe String + parsedHelp_ :: a -> String + +-- | See @'parseOptions'@. +data ParsedOptions opts = ParsedOptions (Maybe opts) (Maybe String) String [String] + +-- | See @'parseSubcommand'@. +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 + +-- | Get the options value that was parsed from argv, or @Nothing@ if the +-- arguments could not be converted into options. +-- +-- Note: This function return @Nothing@ if the user provided a help flag. To +-- check whether an error occured during parsing, check the value of +-- @'parsedError'@. +parsedOptions :: ParsedOptions opts -> Maybe opts +parsedOptions (ParsedOptions x _ _ _) = x + +-- | Get command-line arguments remaining after parsing options. The arguments +-- are unchanged from the original argument list, and have not been decoded +-- or otherwise transformed. +parsedArguments :: ParsedOptions opts -> [String] +parsedArguments (ParsedOptions _ _ _ x) = x + +-- | Get the subcommand action that was parsed from argv, or @Nothing@ if the +-- arguments could not be converted into a valid action. +-- +-- Note: This function return @Nothing@ if the user provided a help flag. To +-- check whether an error occured during parsing, check the value of +-- @'parsedError'@. +parsedSubcommand :: ParsedSubcommand action -> Maybe action +parsedSubcommand (ParsedSubcommand x _ _) = x + +-- | Get the error that prevented options from being parsed from argv, +-- or @Nothing@ if no error was detected. +parsedError :: Parsed a => a -> Maybe String +parsedError = parsedError_ + +-- | Get a help message to show the user. If the arguments included +-- a help flag, this will be a message appropriate to that flag. +-- Otherwise, it is a summary (equivalent to @--help@). +-- +-- This is always a non-empty string, regardless of whether the parse +-- succeeded or failed. If you need to perform additional validation +-- on the options value, this message can be displayed if validation +-- fails. +parsedHelp :: Parsed a => a -> String +parsedHelp = parsedHelp_ + +-- | Attempt to convert a list of command-line arguments into an options +-- value. This can be used by application developers who want finer control +-- over error handling, or who want to perform additional validation on the +-- options value. +-- +-- The argument list must be in the same encoding as the result of +-- 'System.Environment.getArgs'. +-- +-- Use @'parsedOptions'@, @'parsedArguments'@, @'parsedError'@, and +-- @'parsedHelp'@ to inspect the result of @'parseOptions'@. +-- +-- Example: +-- +-- @ +--getOptionsOrDie :: Options a => IO a +--getOptionsOrDie = do +-- argv <- System.Environment.getArgs +-- let parsed = 'parseOptions' argv +-- case 'parsedOptions' parsed of +-- Just opts -> return opts +-- Nothing -> case 'parsedError' parsed of +-- Just err -> do +-- hPutStrLn stderr ('parsedHelp' parsed) +-- hPutStrLn stderr err +-- exitFailure +-- Nothing -> do +-- hPutStr stdout ('parsedHelp' parsed) +-- exitSuccess +-- @ +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 + +-- | Retrieve 'System.Environment.getArgs', and attempt to parse it into a +-- valid value of an 'Options' type plus a list of left-over arguments. The +-- options and arguments are then passed to the provided computation. +-- +-- If parsing fails, this computation will print an error and call +-- 'exitFailure'. +-- +-- If parsing succeeds, and the user has passed a @--help@ flag, and the +-- developer is using the default help flag definitions, then this computation +-- will print documentation and call 'exitSuccess'. +-- +-- See 'runSubcommand' for details on subcommand support. +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 -- ^ The subcommand name. + -> (cmdOpts -> subcmdOpts -> [String] -> action) -- ^ The action to run. + -> 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 + +-- | Attempt to convert a list of command-line arguments into a subcommand +-- action. This can be used by application developers who want finer control +-- over error handling, or who want subcommands that run in an unusual monad. +-- +-- The argument list must be in the same encoding as the result of +-- 'System.Environment.getArgs'. +-- +-- Use @'parsedSubcommand'@, @'parsedError'@, and @'parsedHelp'@ to inspect the +-- result of @'parseSubcommand'@. +-- +-- Example: +-- +-- @ +--runSubcommand :: Options cmdOpts => [Subcommand cmdOpts (IO a)] -> IO a +--runSubcommand subcommands = do +-- argv <- System.Environment.getArgs +-- let parsed = 'parseSubcommand' subcommands argv +-- case 'parsedSubcommand' parsed of +-- Just cmd -> cmd +-- Nothing -> case 'parsedError' parsed of +-- Just err -> do +-- hPutStrLn stderr ('parsedHelp' parsed) +-- hPutStrLn stderr err +-- exitFailure +-- Nothing -> do +-- hPutStr stdout ('parsedHelp' parsed) +-- exitSuccess +-- @ +-- +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)) + +-- | Used to run applications that are split into subcommands. +-- +-- Use 'subcommand' to define available commands and their actions, then pass +-- them to this computation to select one and run it. If the user specifies +-- an invalid subcommand, this computation will print an error and call +-- 'exitFailure'. In handling of invalid flags or @--help@, 'runSubcommand' +-- acts like 'runCommand'. +-- +-- @ +--{-\# LANGUAGE TemplateHaskell \#-} +-- +--import Control.Monad (unless) +--import Options +-- +--'defineOptions' \"MainOptions\" $ do +-- 'boolOption' \"optQuiet\" \"quiet\" False \"Whether to be quiet.\" +-- +--'defineOptions' \"HelloOpts\" $ do +-- 'stringOption' \"optHello\" \"hello\" \"Hello!\" \"How to say hello.\" +-- +--'defineOptions' \"ByeOpts\" $ do +-- 'stringOption' \"optName\" \"name\" \"\" \"The user's name.\" +-- +--hello :: MainOptions -> HelloOpts -> [String] -> IO () +--hello mainOpts opts args = unless (optQuiet mainOpts) $ do +-- putStrLn (optHello opts) +-- +--bye :: MainOptions -> ByeOpts -> [String] -> IO () +--bye mainOpts opts args = unless (optQuiet mainOpts) $ do +-- putStrLn (\"Good bye \" ++ optName opts) +-- +--main :: IO () +--main = 'runSubcommand' +-- [ 'subcommand' \"hello\" hello +-- , 'subcommand' \"bye\" bye +-- ] +-- @ +-- +-- >$ ./app hello +-- >Hello! +-- >$ ./app hello --hello='Allo!' +-- >Allo! +-- >$ ./app bye +-- >Good bye +-- >$ ./app bye --name='John' +-- >Good bye John +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 diff --git a/lib/Options/Help.hs b/lib/Options/Help.hs new file mode 100644 --- /dev/null +++ b/lib/Options/Help.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module: Options.Help +-- License: MIT +module Options.Help + ( addHelpFlags + , checkHelpFlag + , helpFor + , HelpFlag(..) + ) where + +import Control.Monad.Writer +import Data.List (intercalate, partition, stripPrefix) +import Data.Maybe (isNothing, listToMaybe, maybeToList) +import qualified Data.Set as Set +import qualified Data.Map as Map + +import Language.Haskell.TH (location, loc_package, loc_module) + +import Options.Types + +data HelpFlag = HelpSummary | HelpAll | HelpGroup String + deriving (Eq, Show) + +addHelpFlags :: OptionDefinitions a -> OptionDefinitions a +addHelpFlags (OptionDefinitions opts subcmds) = OptionDefinitions withHelp subcmdsWithHelp where + shortFlags = Set.fromList $ do + opt <- opts + optionInfoShortFlags opt + longFlags = Set.fromList $ do + opt <- opts + optionInfoLongFlags opt + + withHelp = optHelpSummary ++ optsGroupHelp ++ opts + + groupHelp = GroupInfo + { groupInfoName = "all" + , groupInfoTitle = "Help Options" + , groupInfoDescription = "Show all help options." + } + + optSummary = OptionInfo + { optionInfoKey = keyFor "optHelpSummary" + , optionInfoShortFlags = [] + , optionInfoLongFlags = [] + , optionInfoDefault = "false" + , optionInfoUnary = True + , optionInfoDescription = "Show option summary." + , optionInfoGroup = Just groupHelp + } + + optGroupHelp group flag = OptionInfo + { optionInfoKey = keyFor "optHelpGroup" ++ ":" ++ groupInfoName group + , optionInfoShortFlags = [] + , optionInfoLongFlags = [flag] + , optionInfoDefault = "false" + , optionInfoUnary = True + , optionInfoDescription = groupInfoDescription group + , optionInfoGroup = Just groupHelp + } + + optHelpSummary = if Set.member 'h' shortFlags + then if Set.member "help" longFlags + then [] + else [optSummary + { optionInfoLongFlags = ["help"] + }] + else if Set.member "help" longFlags + then [optSummary + { optionInfoShortFlags = ['h'] + }] + else [optSummary + { optionInfoShortFlags = ['h'] + , optionInfoLongFlags = ["help"] + }] + + optsGroupHelp = do + let (groupsAndOpts, _) = uniqueGroupInfos opts + let groups = [g | (g, _) <- groupsAndOpts] + group <- (groupHelp : groups) + let flag = "help-" ++ groupInfoName group + if Set.member flag longFlags + then [] + else [optGroupHelp group flag] + + subcmdsWithHelp = do + (subcmdName, subcmdOpts) <- subcmds + let subcmdLongFlags = Set.fromList $ do + opt <- subcmdOpts ++ optsGroupHelp + optionInfoLongFlags opt + + let (groupsAndOpts, _) = uniqueGroupInfos subcmdOpts + let groups = [g | (g, _) <- groupsAndOpts] + let newOpts = do + group <- groups + let flag = "help-" ++ groupInfoName group + if Set.member flag (Set.union longFlags subcmdLongFlags) + then [] + else [optGroupHelp group flag] + return (subcmdName, newOpts ++ subcmdOpts) + +checkHelpFlag :: TokensFor a -> Maybe HelpFlag +checkHelpFlag (TokensFor tokens _) = flag where + flag = listToMaybe helpKeys + helpKeys = do + (k, _) <- tokens + if k == keySummary + then return HelpSummary + else if k == keyAll + then return HelpAll + else do + groupName <- maybeToList (stripPrefix keyGroupPrefix k) + return (HelpGroup groupName) + keySummary = keyFor "optHelpSummary" + keyAll = keyFor "optHelpGroup:all" + keyGroupPrefix = keyFor "optHelpGroup:" + +helpFor :: HelpFlag -> OptionDefinitions a -> Maybe String -> String +helpFor flag defs subcmd = case flag of + HelpSummary -> execWriter (showHelpSummary defs subcmd) + HelpAll -> execWriter (showHelpAll defs subcmd) + HelpGroup groupName -> execWriter (showHelpOneGroup defs groupName subcmd) + +showOptionHelp :: OptionInfo -> Writer String () +showOptionHelp info = do + let safeHead xs = case xs of + [] -> [] + (x:_) -> [x] + let shorts = optionInfoShortFlags info + let longs = optionInfoLongFlags info + let optStrings = map (\x -> ['-', x]) (safeHead shorts) ++ map (\x -> "--" ++ x) (safeHead longs) + unless (null optStrings) $ do + let optStringCsv = intercalate ", " optStrings + tell " " + tell optStringCsv + + let desc = optionInfoDescription info + unless (null desc) $ do + if length optStringCsv > 27 + then do + tell "\n" + tell " " + tell (optionInfoDescription info) + else do + tell (replicate (28 - length optStringCsv) ' ') + tell (optionInfoDescription info) + + tell "\n" + +showHelpSummary :: OptionDefinitions a -> Maybe String -> Writer String () +showHelpSummary (OptionDefinitions mainOpts subcmds) subcmd = do + let subcmdOptions = do + subcmdName <- subcmd + opts <- lookup subcmdName subcmds + return (subcmdName, opts) + + let (groupInfos, ungroupedMainOptions) = uniqueGroupInfos mainOpts + + -- Always print --help group + let hasHelp = filter (\(g,_) -> groupInfoName g == "all") groupInfos + forM_ hasHelp showHelpGroup + + tell "Application Options:\n" + forM_ ungroupedMainOptions showOptionHelp + unless (null subcmds) (tell "\n") + + case subcmdOptions of + Nothing -> unless (null subcmds) $ do + tell "Subcommands:\n" + forM_ subcmds $ \(subcmdName, _) -> do + tell " " + tell subcmdName + -- TODO: subcommand help description + tell "\n" + tell "\n" + Just (n, subOpts) -> do + -- TODO: subcommand description + -- TODO: handle grouped options in subcommands? + tell ("Options for subcommand " ++ show n ++ ":\n") + forM_ subOpts showOptionHelp + tell "\n" + +showHelpAll :: OptionDefinitions a -> Maybe String -> Writer String () +showHelpAll (OptionDefinitions mainOpts subcmds) subcmd = do + let subcmdOptions = do + subcmdName <- subcmd + opts <- lookup subcmdName subcmds + return (subcmdName, opts) + + let (groupInfos, ungroupedMainOptions) = uniqueGroupInfos mainOpts + + -- Always print --help group first, if present + let (hasHelp, noHelp) = partition (\(g,_) -> groupInfoName g == "all") groupInfos + forM_ hasHelp showHelpGroup + forM_ noHelp showHelpGroup + + tell "Application Options:\n" + forM_ ungroupedMainOptions showOptionHelp + unless (null subcmds) (tell "\n") + + case subcmdOptions of + Nothing -> forM_ subcmds $ \(subcmdName, subcmdOpts) -> do + -- no subcommand description + tell ("Options for subcommand " ++ show subcmdName ++ ":\n") + forM_ subcmdOpts showOptionHelp + tell "\n" + Just (n, subOpts) -> do + -- TODO: subcommand description + -- TODO: handle grouped options in subcommands? + tell ("Options for subcommand " ++ show n ++ ":\n") + forM_ subOpts showOptionHelp + tell "\n" + +showHelpGroup :: (GroupInfo, [OptionInfo]) -> Writer String () +showHelpGroup (groupInfo, opts) = do + tell (groupInfoTitle groupInfo ++ ":\n") + forM_ opts showOptionHelp + tell "\n" + +showHelpOneGroup :: OptionDefinitions a -> String -> Maybe String -> Writer String () +showHelpOneGroup (OptionDefinitions mainOpts subcmds) groupName subcmd = do + let opts = case subcmd of + Nothing -> mainOpts + Just n -> case lookup n subcmds of + Just infos -> mainOpts ++ infos -- both + Nothing -> mainOpts + let (groupInfos, _) = uniqueGroupInfos opts + + -- Always print --help group + let group = filter (\(g,_) -> groupInfoName g == groupName) groupInfos + forM_ group showHelpGroup + +keyFor :: String -> String +keyFor fieldName = this_pkg ++ ":" ++ this_mod ++ ":" ++ fieldName where + (this_pkg, this_mod) = $(do + loc <- location + let pkg = loc_package loc + let mod' = loc_module loc + [| (pkg, mod') |]) + +uniqueGroupInfos :: [OptionInfo] -> ([(GroupInfo, [OptionInfo])], [OptionInfo]) +uniqueGroupInfos allOptions = (Map.elems infoMap, ungroupedOptions) where + infoMap = Map.fromListWith merge $ do + opt <- allOptions + case optionInfoGroup opt of + Nothing -> [] + Just g -> [(groupInfoName g, (g, [opt]))] + merge (g, opts1) (_, opts2) = (g, opts2 ++ opts1) + ungroupedOptions = [o | o <- allOptions, isNothing (optionInfoGroup o)] diff --git a/lib/Options/OptionTypes.hs b/lib/Options/OptionTypes.hs new file mode 100644 --- /dev/null +++ b/lib/Options/OptionTypes.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module: Options.OptionTypes +-- License: MIT +module Options.OptionTypes where + +import Data.Int +import Data.List (intercalate) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.Word + +import qualified Filesystem.Path as Path +import qualified Filesystem.Path.Rules as Path +import Language.Haskell.TH + +data Option a = Option + { + -- | Short flags are a single character. When entered by a user, + -- they are preceded by a dash and possibly other short flags. + -- + -- Short flags must be a letter or a number. + -- + -- Example: An option with @optionShortFlags = [\'p\']@ may be set using: + -- + -- >$ ./app -p 443 + -- >$ ./app -p443 + optionShortFlags :: [Char] + + -- | Long flags are multiple characters. When entered by a user, they + -- are preceded by two dashes. + -- + -- Long flags may contain letters, numbers, @\'-\'@, and @\'_\'@. + -- + -- Example: An option with @optionLongFlags = [\"port\"]@ may be set using: + -- + -- >$ ./app --port 443 + -- >$ ./app --port=443 + , optionLongFlags :: [String] + + -- | Options may have a default value. This will be parsed as if the + -- user had entered it on the command line. + , optionDefault :: String + + -- | There are many types which an application or library might want + -- to use when designing their options. By default, options are + -- strings, but 'optionType' may be set to any supported type. See + -- the \"Option types\" section for a list of supported types. + , optionType :: OptionType a + + -- | An option's description is used with the default implementation + -- of @--help@. It should be a short string describing what the option + -- does. + , optionDescription :: String + + -- | Which group the option is in. See the \"Option groups\" section + -- for details. + , optionGroup :: Group + } + +data Group = Group + { groupName :: Maybe String + + -- | A short title for the group, which is used when printing + -- @--help@ output. + , groupTitle :: String + + -- | A description of the group, which is used when printing + -- @--help@ output. + , groupDescription :: String + } + +-- | An option's type determines how the option will be parsed, and which +-- Haskell type the parsed value will be stored as. There are many types +-- available, covering most basic types and a few more advanced types. +data OptionType a = OptionType Type Bool (String -> Either String a) (Q Exp) + +-- | Store an option as a @'Bool'@. The option's value must be either +-- @\"true\"@ or @\"false\"@. +-- +-- Boolean options are unary, which means that their value is optional when +-- specified on the command line. If a flag is present, the option is set to +-- True. +-- +-- >$ ./app -q +-- >$ ./app --quiet +-- +-- Boolean options may still be specified explicitly by using long flags with +-- the @--flag=value@ format. This is the only way to set a unary flag to +-- @\"false\"@. +-- +-- >$ ./app --quiet=true +-- >$ ./app --quiet=false +optionTypeBool :: OptionType Bool +optionTypeBool = OptionType (ConT ''Bool) True parseBool [| parseBool |] + +parseBool :: String -> Either String Bool +parseBool s = case s of + "true" -> Right True + "false" -> Right False + -- TODO: include option flag + _ -> Left (show s ++ " is not in {\"true\", \"false\"}.") + +-- | Store an option value as a @'String'@. The value is decoded to Unicode +-- first, if needed. The value may contain non-Unicode bytes, in which case +-- they will be stored using GHC 7.4's encoding for mixed-use strings. +optionTypeString :: OptionType String +optionTypeString = OptionType (ConT ''String) False Right [| Right |] + +-- | Store an option value as a @'Text.Text'@. The value is decoded to Unicode +-- first, if needed. If the value cannot be decoded, the stored value may have +-- the Unicode substitution character @'\65533'@ in place of some of the +-- original input. +optionTypeText :: OptionType Text.Text +optionTypeText = OptionType (ConT ''Text.Text) False parseText [| parseText |] + +parseText :: String -> Either String Text.Text +parseText = Right . Text.pack + +-- | Store an option value as a @'Path.FilePath'@. +optionTypeFilePath :: OptionType Path.FilePath +optionTypeFilePath = OptionType (ConT ''Path.FilePath) False parsePath [| parsePath |] + +parsePath :: String -> Either String Path.FilePath +#if defined(CABAL_OS_WINDOWS) +parsePath s = Right (Path.decodeString Path.windows s) +#elif __GLASGOW_HASKELL__ == 702 +parsePath s = Right (Path.decodeString Path.posix_ghc702 s) +#else +parsePath s = Right (Path.decodeString Path.posix_ghc704 s) +#endif + +parseInteger :: String -> Either String Integer +parseInteger s = parsed where + parsed = if valid + then Right (read s) + else Left (show s ++ " is not an integer.") + valid = case s of + [] -> False + '-':s' -> allDigits s' + _ -> allDigits s + allDigits = all (\c -> c >= '0' && c <= '9') + +parseBoundedIntegral :: (Bounded a, Integral a) => String -> String -> Either String a +parseBoundedIntegral label = parse where + getBounds :: (Bounded a, Integral a) => (String -> Either String a) -> a -> a -> (Integer, Integer) + getBounds _ min' max' = (toInteger min', toInteger max') + + (minInt, maxInt) = getBounds parse minBound maxBound + + parse s = case parseInteger s of + Left err -> Left err + Right int -> if int < minInt || int > maxInt + then Left (show int ++ " is not within bounds [" ++ show minInt ++ ":" ++ show maxInt ++ "] of type " ++ label ++ ".") + else Right (fromInteger int) + +parseFloat :: Read a => String -> Either String a +parseFloat s = case reads s of + [(x, "")] -> Right x + _ -> Left (show s ++ " is not a number.") + +-- | Store an option as an @'Int'@. The option value must be an integer /n/ +-- such that @'minBound' <= n <= 'maxBound'@. +optionTypeInt :: OptionType Int +optionTypeInt = OptionType (ConT ''Int) False (parseBoundedIntegral "int") [| parseBoundedIntegral "int" |] + +-- | Store an option as an @'Int8'@. The option value must be an integer /n/ +-- such that @'minBound' <= n <= 'maxBound'@. +optionTypeInt8 :: OptionType Int8 +optionTypeInt8 = OptionType (ConT ''Int8) False (parseBoundedIntegral "int8") [| parseBoundedIntegral "int8" |] + +-- | Store an option as an @'Int16'@. The option value must be an integer /n/ +-- such that @'minBound' <= n <= 'maxBound'@. +optionTypeInt16 :: OptionType Int16 +optionTypeInt16 = OptionType (ConT ''Int16) False (parseBoundedIntegral "int16") [| parseBoundedIntegral "int16" |] + +-- | Store an option as an @'Int32'@. The option value must be an integer /n/ +-- such that @'minBound' <= n <= 'maxBound'@. +optionTypeInt32 :: OptionType Int32 +optionTypeInt32 = OptionType (ConT ''Int32) False (parseBoundedIntegral "int32") [| parseBoundedIntegral "int32" |] + +-- | Store an option as an @'Int64'@. The option value must be an integer /n/ +-- such that @'minBound' <= n <= 'maxBound'@. +optionTypeInt64 :: OptionType Int64 +optionTypeInt64 = OptionType (ConT ''Int64) False (parseBoundedIntegral "int64") [| parseBoundedIntegral "int64" |] + +-- | Store an option as a @'Word'@. The option value must be a positive +-- integer /n/ such that @0 <= n <= 'maxBound'@. +optionTypeWord :: OptionType Word +optionTypeWord = OptionType (ConT ''Word) False (parseBoundedIntegral "word") [| parseBoundedIntegral "word" |] + +-- | Store an option as a @'Word8'@. The option value must be a positive +-- integer /n/ such that @0 <= n <= 'maxBound'@. +optionTypeWord8 :: OptionType Word8 +optionTypeWord8 = OptionType (ConT ''Word8) False (parseBoundedIntegral "word8") [| parseBoundedIntegral "word8" |] + +-- | Store an option as a @'Word16'@. The option value must be a positive +-- integer /n/ such that @0 <= n <= 'maxBound'@. +optionTypeWord16 :: OptionType Word16 +optionTypeWord16 = OptionType (ConT ''Word16) False (parseBoundedIntegral "word16") [| parseBoundedIntegral "word16" |] + +-- | Store an option as a @'Word32'@. The option value must be a positive +-- integer /n/ such that @0 <= n <= 'maxBound'@. +optionTypeWord32 :: OptionType Word32 +optionTypeWord32 = OptionType (ConT ''Word32) False (parseBoundedIntegral "word32") [| parseBoundedIntegral "word32" |] + +-- | Store an option as a @'Word64'@. The option value must be a positive +-- integer /n/ such that @0 <= n <= 'maxBound'@. +optionTypeWord64 :: OptionType Word64 +optionTypeWord64 = OptionType (ConT ''Word64) False (parseBoundedIntegral "word64") [| parseBoundedIntegral "word64" |] + +-- | Store an option as an @'Integer'@. The option value must be an integer. +-- There is no minimum or maximum value. +optionTypeInteger :: OptionType Integer +optionTypeInteger = OptionType (ConT ''Integer) False parseInteger [| parseInteger |] + +-- | Store an option as a @'Float'@. The option value must be a number. Due to +-- the imprecision of floating-point math, the stored value might not exactly +-- match the user's input. If the user's input is out of range for the +-- @'Float'@ type, it will be stored as @Infinity@ or @-Infinity@. +optionTypeFloat :: OptionType Float +optionTypeFloat = OptionType (ConT ''Float) False parseFloat [| parseFloat |] + +-- | Store an option as a @'Double'@. The option value must be a number. Due to +-- the imprecision of floating-point math, the stored value might not exactly +-- match the user's input. If the user's input is out of range for the +-- @'Double'@ type, it will be stored as @Infinity@ or @-Infinity@. +optionTypeDouble :: OptionType Double +optionTypeDouble = OptionType (ConT ''Double) False parseFloat [| parseFloat |] + +-- | Store an option as a @'Maybe'@ of another type. The value will be +-- @Nothing@ if the option was not provided or is an empty string. +-- +-- @ +--'option' \"optTimeout\" (\\o -> o +-- { 'optionLongFlags' = [\"timeout\"] +-- , 'optionType' = 'optionTypeMaybe' 'optionTypeInt' +-- }) +-- @ +optionTypeMaybe :: OptionType a -> OptionType (Maybe a) +optionTypeMaybe (OptionType valType unary valParse valParseExp) = OptionType (AppT (ConT ''Maybe) valType) unary + (parseMaybe valParse) + [| parseMaybe $valParseExp |] + +parseMaybe :: (String -> Either String a) -> String -> Either String (Maybe a) +parseMaybe p s = case s of + "" -> Right (Nothing) + _ -> case p s of + Left err -> Left err + Right a -> Right (Just a) + +$([d| |]) + +-- | Store an option as a @'Set.Set'@, using another option type for the +-- elements. The separator should be a character that will not occur within +-- the values, such as a comma or semicolon. +-- +-- Duplicate elements in the input are permitted. +-- +-- @ +--'option' \"optNames\" (\\o -> o +-- { 'optionLongFlags' = [\"names\"] +-- , 'optionDefault' = \"Alice;Bob;Charles\" +-- , 'optionType' = 'optionTypeSet' \';\' 'optionTypeString' +-- }) +-- @ +optionTypeSet :: Ord a + => Char -- ^ Element separator + -> OptionType a -- ^ Element type + -> OptionType (Set.Set a) +optionTypeSet sep (OptionType valType _ valParse valParseExp) = OptionType (AppT (ConT ''Set.Set) valType) False + (\s -> parseSet valParse (split sep s)) + [| \s -> parseSet $valParseExp (split sep s) |] + +-- | Store an option as a 'Map.Map', using other option types for the keys and +-- values. +-- +-- The item separator is used to separate key/value pairs from eachother. It +-- should be a character that will not occur within either the keys or values. +-- +-- The value separator is used to separate the key from the value. It should +-- be a character that will not occur within the keys. It may occur within the +-- values. +-- +-- Duplicate keys in the input are permitted. The final value for each key is +-- stored. +-- +-- @ +--'option' \"optNames\" (\\o -> o +-- { 'optionLongFlags' = [\"names\"] +-- , 'optionDefault' = \"name=Alice;hometown=Bucharest\" +-- , 'optionType' = 'optionTypeMap' \';\' \'=\' 'optionTypeString' 'optionTypeString' +-- }) +-- @ +optionTypeMap :: Ord k + => Char -- ^ Item separator + -> Char -- ^ Key/Value separator + -> OptionType k -- ^ Key type + -> OptionType v -- ^ Value type + -> OptionType (Map.Map k v) +optionTypeMap itemSep keySep (OptionType keyType _ keyParse keyParseExp) (OptionType valType _ valParse valParseExp) = OptionType (AppT (AppT (ConT ''Map.Map) keyType) valType) False + (\s -> parseMap keySep keyParse valParse (split itemSep s)) + [| \s -> parseMap keySep $keyParseExp $valParseExp (split itemSep s) |] + +parseList :: (String -> Either String a) -> [String] -> Either String [a] +parseList p = loop where + loop [] = Right [] + loop (x:xs) = case p x of + Left err -> Left err + Right v -> case loop xs of + Left err -> Left err + Right vs -> Right (v:vs) + +parseSet :: Ord a => (String -> Either String a) -> [String] -> Either String (Set.Set a) +parseSet p strs = case parseList p strs of + Left err -> Left err + Right xs -> Right (Set.fromList xs) + +parseMap :: Ord k => Char -> (String -> Either String k) -> (String -> Either String v) -> [String] -> Either String (Map.Map k v) +parseMap keySep pKey pVal = parsed where + parsed strs = case parseList pItem strs of + Left err -> Left err + Right xs -> Right (Map.fromList xs) + pItem s = case break (== keySep) s of + (sKey, valAndSep) -> case valAndSep of + [] -> Left ("Map item " ++ show s ++ " has no value.") + _ : sVal -> case pKey sKey of + Left err -> Left err + Right key -> case pVal sVal of + Left err -> Left err + Right val -> Right (key, val) + +split :: Char -> String -> [String] +split _ [] = [] +split sep s0 = loop s0 where + loop s = let + (chunk, rest) = break (== sep) s + cont = chunk : loop (tail rest) + in if null rest then [chunk] else cont + +$([d| |]) + +-- | Store an option as a list, using another option type for the elements. +-- The separator should be a character that will not occur within the values, +-- such as a comma or semicolon. +-- +-- @ +--'option' \"optNames\" (\\o -> o +-- { 'optionLongFlags' = [\"names\"] +-- , 'optionDefault' = \"Alice;Bob;Charles\" +-- , 'optionType' = 'optionTypeList' \';\' 'optionTypeString' +-- }) +-- @ +optionTypeList :: Char -- ^ Element separator + -> OptionType a -- ^ Element type + -> OptionType [a] +optionTypeList sep (OptionType valType _ valParse valParseExp) = OptionType (AppT ListT valType) False + (\s -> parseList valParse (split sep s)) + [| \s -> parseList $valParseExp (split sep s) |] + +-- | Store an option as one of a set of enumerated values. The option +-- type must be defined in a separate file. +-- +-- >-- MyApp/Types.hs +-- >data Mode = ModeFoo | ModeBar +-- > deriving (Enum) +-- +-- @ +-- -- Main.hs +--import MyApp.Types +-- +--'defineOptions' \"MainOptions\" $ do +-- 'option' \"optMode\" (\\o -> o +-- { 'optionLongFlags' = [\"mode\"] +-- , 'optionDefault' = \"foo\" +-- , 'optionType' = 'optionTypeEnum' ''Mode +-- [ (\"foo\", ModeFoo) +-- , (\"bar\", ModeBar) +-- ] +-- }) +-- @ +-- +-- >$ ./app +-- >Running in mode ModeFoo +-- >$ ./app --mode=bar +-- >Running in mode ModeBar +optionTypeEnum :: Enum a => Name -> [(String, a)] -> OptionType a +optionTypeEnum typeName values = do + let intlist = [(k, fromEnum v) | (k, v) <- values] + let setString = "{" ++ intercalate ", " [show k | (k, _) <- values] ++ "}." + OptionType (ConT typeName) False + (\s -> case lookup s values of + Just v -> Right v + Nothing -> Left (show s ++ " is not in " ++ setString)) + [| \s -> case lookup s intlist of + Just v -> Right (toEnum v) + -- TODO: include option flag and available values + Nothing -> Left (show s ++ " is not in " ++ setString) |] diff --git a/lib/Options/Tokenize.hs b/lib/Options/Tokenize.hs new file mode 100644 --- /dev/null +++ b/lib/Options/Tokenize.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module: Options.Tokenize +-- License: MIT +module Options.Tokenize + ( tokenize + ) where + +import Control.Monad.Error hiding (throwError) +import qualified Control.Monad.Error +import Control.Monad.State +import Data.Functor.Identity +import qualified Data.Map + +import Options.Types +import Options.Util + +data TokState = TokState + { stArgv :: [String] + , stArgs :: [String] + , stOpts :: [(String, (String, String))] + , stShortKeys :: Data.Map.Map Char (String, Bool) + , stLongKeys :: Data.Map.Map String (String, Bool) + , stSubcommands :: [(String, [OptionInfo])] + , stSubCmd :: Maybe String + } + +newtype Tok a = Tok { unTok :: ErrorT String (StateT TokState Identity) a } + +instance Monad Tok where + return = Tok . return + m >>= f = Tok (unTok m >>= unTok . f) + +instance MonadState Tok where + type StateType Tok = TokState + get = Tok get + put = Tok . put + +tokenize :: OptionDefinitions a -> [String] -> (Maybe String, Either String (TokensFor a)) +tokenize (OptionDefinitions options subcommands) argv = runIdentity $ do + let st = TokState + { stArgv = argv + , stArgs = [] + , stOpts = [] + , stShortKeys = toShortKeys options + , stLongKeys = toLongKeys options + , stSubcommands = subcommands + , stSubCmd = Nothing + } + (err, st') <- runStateT (runErrorT (unTok loop)) st + return (stSubCmd st', case err of + Left err' -> Left err' + Right _ -> Right (TokensFor (stOpts st') (stArgs st'))) + +loop :: Tok () +loop = do + ms <- nextItem + st <- get + case ms of + Nothing -> return () + Just s -> (>> loop) $ case stringToGhc704 s of + '-':'-':[] -> put (st { stArgv = [], stArgs = stArgs st ++ stArgv st }) + '-':'-':opt -> parseLong opt + '-':optChar:optValue -> parseShort optChar optValue + '-':[] -> addArg s + decoded -> case (stSubcommands st, stSubCmd st) of + ([], _) -> addArg s + (_, Just _) -> addArg s + (_, Nothing) -> case lookup decoded (stSubcommands st) of + Nothing -> throwError ("Unknown subcommand " ++ show decoded ++ ".") + Just subOptions -> mergeSubcommand decoded subOptions + +nextItem :: Tok (Maybe String) +nextItem = do + st <- get + case stArgv st of + [] -> return Nothing + (x:xs) -> do + put (st { stArgv = xs }) + return (Just x) + +addArg :: String -> Tok () +addArg s = modify (\st -> st { stArgs = stArgs st ++ [s] }) + +addOpt :: String -> String -> String -> Tok () +addOpt flag key val = do + oldOpts <- gets stOpts + case lookup key oldOpts of + Nothing -> modify (\st -> st { stOpts = stOpts st ++ [(key, (flag, val))] }) + -- TODO: include old and new values? + Just _ -> throwError ("Multiple values for flag " ++ flag ++ " were provided.") + +mergeSubcommand :: String -> [OptionInfo] -> Tok () +mergeSubcommand name opts = modify $ \st -> st + { stSubCmd = Just name + , stShortKeys = Data.Map.union (stShortKeys st) (toShortKeys opts) + , stLongKeys = Data.Map.union (stLongKeys st) (toLongKeys opts) + } + +parseLong :: String -> Tok () +parseLong optName = do + longKeys <- gets stLongKeys + case break (== '=') optName of + (before, after) -> case after of + '=' : value -> case Data.Map.lookup before longKeys of + Nothing -> throwError ("Unknown flag --" ++ before) + Just (key, _) -> addOpt ("--" ++ before) key value + _ -> case Data.Map.lookup optName longKeys of + Nothing -> throwError ("Unknown flag --" ++ optName) + Just (key, unary) -> if unary + then addOpt ("--" ++ optName) key "true" + else do + next <- nextItem + case next of + Nothing -> throwError ("The flag --" ++ optName ++ " requires an argument.") + Just value -> addOpt ("--" ++ optName) key value + +parseShort :: Char -> String -> Tok () +parseShort optChar optValue = do + let optName = '-' : [optChar] + shortKeys <- gets stShortKeys + case Data.Map.lookup optChar shortKeys of + Nothing -> throwError ("Unknown flag " ++ optName) + Just (key, unary) -> if unary + then do + addOpt optName key "true" + case optValue of + [] -> return () + nextChar:nextValue -> parseShort nextChar nextValue + else case optValue of + "" -> do + next <- nextItem + case next of + Nothing -> throwError ("The flag " ++ optName ++ " requires an argument.") + Just value -> addOpt optName key value + _ -> addOpt optName key optValue + +toShortKeys :: [OptionInfo] -> Data.Map.Map Char (String, Bool) +toShortKeys opts = Data.Map.fromList $ do + opt <- opts + flag <- optionInfoShortFlags opt + return (flag, (optionInfoKey opt, optionInfoUnary opt)) + +toLongKeys :: [OptionInfo] -> Data.Map.Map String (String, Bool) +toLongKeys opts = Data.Map.fromList $ do + opt <- opts + flag <- optionInfoLongFlags opt + return (flag, (optionInfoKey opt, optionInfoUnary opt)) + +throwError :: String -> Tok a +throwError = Tok . Control.Monad.Error.throwError diff --git a/lib/Options/Types.hs b/lib/Options/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Options/Types.hs @@ -0,0 +1,31 @@ +-- | +-- Module: Options.Types +-- License: MIT +module Options.Types + ( OptionDefinitions(..) + , GroupInfo(..) + , OptionInfo(..) + , TokensFor(..) + ) where + +data OptionDefinitions a = OptionDefinitions [OptionInfo] [(String, [OptionInfo])] + +data GroupInfo = GroupInfo + { groupInfoName :: String + , groupInfoTitle :: String + , groupInfoDescription :: String + } + deriving (Eq, Show) + +data OptionInfo = OptionInfo + { optionInfoKey :: String + , optionInfoShortFlags :: [Char] + , optionInfoLongFlags :: [String] + , optionInfoDefault :: String + , optionInfoUnary :: Bool + , optionInfoDescription :: String + , optionInfoGroup :: Maybe GroupInfo + } + deriving (Eq, Show) + +data TokensFor a = TokensFor [(String, (String, String))] [String] diff --git a/lib/Options/Util.hs b/lib/Options/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Options/Util.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | +-- Module: Options.Util +-- License: MIT +module Options.Util where + +import Data.Char (isAlphaNum, isLetter, isUpper) +import qualified Data.Set as Set + +#if defined(OPTIONS_ENCODING_UTF8) +import Data.Char (chr) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import qualified Data.ByteString.Char8 as Char8 +import Foreign +import Foreign.C +#endif + +stringToGhc704 :: String -> String +#if defined(OPTIONS_ENCODING_UTF8) +stringToGhc704 = decodeUtf8 . Char8.pack + +decodeUtf8 :: Char8.ByteString -> String +decodeUtf8 bytes = map (chr . fromIntegral) word32s where + word32s = unsafePerformIO (unsafeUseAsCStringLen bytes io) + io (bytesPtr, len) = allocaArray len $ \wordsPtr -> do + nWords <- c_decodeString (castPtr bytesPtr) wordsPtr (fromIntegral len) + peekArray (fromIntegral nWords) wordsPtr + +foreign import ccall unsafe "hsoptions_decode_string" + c_decodeString :: Ptr Word8 -> Ptr Word32 -> CInt -> IO CInt +#else +stringToGhc704 = id +#endif + +validFieldName :: String -> Bool +validFieldName = valid where + valid s = case s of + [] -> False + c : cs -> validFirst c && all validGeneral cs + validFirst c = c == '_' || (isLetter c && not (isUpper c)) + validGeneral c = isAlphaNum c || c == '_' || c == '\'' + +validShortFlag :: Char -> Bool +validShortFlag = isAlphaNum + +validLongFlag :: String -> Bool +validLongFlag = valid where + valid s = case s of + [] -> False + c : cs -> validFirst c && all validGeneral cs + validFirst = isAlphaNum + validGeneral c = isAlphaNum c || c == '-' || c == '_' + +hasDuplicates :: Ord a => [a] -> Bool +hasDuplicates xs = Set.size (Set.fromList xs) /= length xs diff --git a/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -0,0 +1,22 @@ +Copyright (c) 2012 John Millikin + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/options.cabal b/options.cabal new file mode 100644 --- /dev/null +++ b/options.cabal @@ -0,0 +1,115 @@ +name: options +version: 0.1 +license: MIT +license-file: license.txt +author: John Millikin +maintainer: John Millikin +build-type: Simple +cabal-version: >= 1.6 +category: Console +stability: experimental +homepage: https://john-millikin.com/software/haskell-options/ +bug-reports: mailto:jmillikin@gmail.com + +synopsis: Parsing command-line options +description: + The @options@ package lets library and application developers easily work + with command-line options. + . + The following example is a full program that can accept two options, + @--message@ and @--quiet@: + . + @ + {-\# LANGUAGE TemplateHaskell \#-} + . + import Options + . + defineOptions \"MainOptions\" $ do + stringOption \"optMessage\" \"message\" \"Hello world!\" + \"A message to show the user.\" + boolOption \"optQuiet\" \"quiet\" False + \"Whether to be quiet.\" + + main :: IO () + main = runCommand $ \\opts args -> do + if optQuiet opts + then return () + else putStrLn (optMessage opts) + @ + . + >$ ./hello + >Hello world! + >$ ./hello --message='ciao mondo' + >ciao mondo + >$ ./hello --quiet + >$ + . + In addition, this library will automatically create documentation options + such as @--help@ and @--help-all@: + . + >$ ./hello --help + >Help Options: + > -h, --help Show option summary. + > --help-all Show all help options. + > + >Application Options: + > --message A message to show the user. + > --quiet Whether to be quiet. + +extra-source-files: + cbits/hoehrmann_utf8.c + cbits/utf8.c + -- + scripts/common.bash + scripts/run-coverage + scripts/run-tests + -- + tests/options-tests.cabal + tests/OptionsTests.hs + tests/OptionsTests/Defaults.hs + tests/OptionsTests/Help.hs + tests/OptionsTests/OptionTypes.hs + tests/OptionsTests/StringParsing.hs + tests/OptionsTests/Tokenize.hs + tests/OptionsTests/Util.hs + +source-repository head + type: bazaar + location: https://john-millikin.com/branches/haskell-options/0.1/ + +source-repository this + type: bazaar + location: https://john-millikin.com/branches/haskell-options/0.1/ + tag: haskell-options_0.1 + +library + ghc-options: -Wall -O2 + cc-options: -Wall -O2 + hs-source-dirs: lib + + if os(windows) + cpp-options: -DCABAL_OS_WINDOWS + + if !os(windows) && impl(ghc < 7.2) + cpp-options: -DOPTIONS_ENCODING_UTF8 + c-sources: cbits/utf8.c + + build-depends: + base >= 4.0 && < 5.0 + , transformers >= 0.2 && < 0.3 + , bytestring >= 0.9 && < 0.10 + , containers >= 0.1 && < 0.5 + , monads-tf + , system-filepath >= 0.4 && < 0.5 + , text >= 0.7 && < 0.12 + , template-haskell + + exposed-modules: + Options + + other-modules: + Options.Help + Options.OptionTypes + Options.Tokenize + Options.Types + Options.Util diff --git a/scripts/common.bash b/scripts/common.bash new file mode 100644 --- /dev/null +++ b/scripts/common.bash @@ -0,0 +1,23 @@ +PATH="$PATH:$PWD/cabal-dev/bin/" + +VERSION=$(awk '/^version:/{print $2}' options.cabal) + +CABAL_DEV=$(which cabal-dev) +XZ=$(which xz) + +require_cabal_dev() +{ + if [ -z "$CABAL_DEV" ]; then + echo "Can't find 'cabal-dev' executable; make sure it exists on your "'$PATH' + echo "Cowardly refusing to fuck with the global package database" + exit 1 + fi +} + +clean_dev_install() +{ + require_cabal_dev + + rm -rf dist + $CABAL_DEV install || exit 1 +} diff --git a/scripts/run-coverage b/scripts/run-coverage new file mode 100644 --- /dev/null +++ b/scripts/run-coverage @@ -0,0 +1,31 @@ +#!/bin/bash +if [ ! -f 'options.cabal' ]; then + echo -n "Can't find options.cabal; please run this script as" + echo -n " ./scripts/run-coverage from within the haskell-options source" + echo " directory" + exit 1 +fi + +. scripts/common.bash + +require_cabal_dev + +pushd tests +$CABAL_DEV -s ../cabal-dev install --flags="coverage" || exit 1 +popd + +rm -f options_tests.tix +cabal-dev/bin/options_tests $@ + +EXCLUDES="\ +--exclude=OptionsTests \ +--exclude=OptionsTests.Defaults \ +--exclude=OptionsTests.Help \ +--exclude=OptionsTests.OptionTypes \ +--exclude=OptionsTests.StringParsing \ +--exclude=OptionsTests.Tokenize \ +--exclude=OptionsTests.Util \ +--exclude=Main" + +hpc markup --srcdir=lib/ --srcdir=tests/ options_tests.tix --destdir=hpc-markup $EXCLUDES > /dev/null +hpc report --srcdir=lib/ --srcdir=tests/ options_tests.tix $EXCLUDES diff --git a/scripts/run-tests b/scripts/run-tests new file mode 100644 --- /dev/null +++ b/scripts/run-tests @@ -0,0 +1,20 @@ +#!/bin/bash +if [ ! -f 'options.cabal' ]; then + echo -n "Can't find options.cabal; please run this script as" + echo -n " ./scripts/run-tests from within the haskell-options source" + echo " directory" + exit 1 +fi + +. scripts/common.bash + +require_cabal_dev + +# clean_dev_install + +pushd tests +# rm -rf dist +$CABAL_DEV -s ../cabal-dev install || exit 1 +popd + +cabal-dev/bin/options_tests $@ diff --git a/tests/OptionsTests.hs b/tests/OptionsTests.hs new file mode 100644 --- /dev/null +++ b/tests/OptionsTests.hs @@ -0,0 +1,29 @@ +-- Copyright (C) 2012 John Millikin +-- +-- See license.txt for details +module Main + ( tests + , main + ) where + +import Test.Chell (Suite, defaultMain) + +import OptionsTests.Defaults (test_Defaults) +import OptionsTests.Help (test_Help) +import OptionsTests.OptionTypes (test_OptionTypes) +import OptionsTests.StringParsing (test_StringParsing) +import OptionsTests.Tokenize (test_Tokenize) +import OptionsTests.Util (test_Util) + +tests :: [Suite] +tests = + [ test_Defaults + , test_Help + , test_OptionTypes + , test_StringParsing + , test_Tokenize + , test_Util + ] + +main :: IO () +main = Test.Chell.defaultMain tests diff --git a/tests/OptionsTests/Defaults.hs b/tests/OptionsTests/Defaults.hs new file mode 100644 --- /dev/null +++ b/tests/OptionsTests/Defaults.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Copyright (C) 2012 John Millikin +-- +-- See license.txt for details +module OptionsTests.Defaults + ( test_Defaults + ) where + +import Prelude hiding (FilePath) +import Data.Int +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Set as Set +import Data.Set (Set) +import Data.Text (Text) +import Data.Word + +import Filesystem.Path.CurrentOS (FilePath) +import Test.Chell + +import Options + +$(defineOptions "AllOptions" $ do + -- Simple option definitions + boolOption "s_Bool" "s_bool" True "" + stringOption "s_String" "s_string" "abc" "" + stringsOption "s_Strings" "s_strings" ["a", "b", "c"] "" + textOption "s_Text" "s_text" "abc" "" + textsOption "s_Texts" "s_texts" ["a", "b", "c"] "" + pathOption "s_Path" "s_path" "a/b/c" "" + intOption "s_Int" "s_int" 123 "" + integerOption "s_Integer" "s_integer" 123 "" + floatOption "s_Float" "s_float" 123.5 "" + doubleOption "s_Double" "s_double" 123.5 "" + + -- Explicitly typed option definitions + option "t_Bool" (\o -> o + { optionLongFlags = ["t_bool"] + , optionType = optionTypeBool + , optionDefault = "true" + }) + option "t_String" (\o -> o + { optionLongFlags = ["t_String"] + , optionType = optionTypeString + , optionDefault = "abc" + }) + option "t_Text" (\o -> o + { optionLongFlags = ["t_Text"] + , optionType = optionTypeText + , optionDefault = "abc" + }) + option "t_FilePath" (\o -> o + { optionLongFlags = ["t_FilePath"] + , optionType = optionTypeFilePath + , optionDefault = "a/b/c" + }) + option "t_Int" (\o -> o + { optionLongFlags = ["t_Int"] + , optionType = optionTypeInt + , optionDefault = "123" + }) + option "t_Int8" (\o -> o + { optionLongFlags = ["t_Int8"] + , optionType = optionTypeInt8 + , optionDefault = "123" + }) + option "t_Int16" (\o -> o + { optionLongFlags = ["t_Int16"] + , optionType = optionTypeInt16 + , optionDefault = "123" + }) + option "t_Int32" (\o -> o + { optionLongFlags = ["t_Int32"] + , optionType = optionTypeInt32 + , optionDefault = "123" + }) + option "t_Int64" (\o -> o + { optionLongFlags = ["t_Int64"] + , optionType = optionTypeInt64 + , optionDefault = "123" + }) + option "t_Word" (\o -> o + { optionLongFlags = ["t_Word"] + , optionType = optionTypeWord + , optionDefault = "123" + }) + option "t_Word8" (\o -> o + { optionLongFlags = ["t_Word8"] + , optionType = optionTypeWord8 + , optionDefault = "123" + }) + option "t_Word16" (\o -> o + { optionLongFlags = ["t_Word16"] + , optionType = optionTypeWord16 + , optionDefault = "123" + }) + option "t_Word32" (\o -> o + { optionLongFlags = ["t_Word32"] + , optionType = optionTypeWord32 + , optionDefault = "123" + }) + option "t_Word64" (\o -> o + { optionLongFlags = ["t_Word64"] + , optionType = optionTypeWord64 + , optionDefault = "123" + }) + option "t_Integer" (\o -> o + { optionLongFlags = ["t_Integer"] + , optionType = optionTypeInteger + , optionDefault = "123" + }) + option "t_Float" (\o -> o + { optionLongFlags = ["t_Float"] + , optionType = optionTypeFloat + , optionDefault = "123.5" + }) + option "t_Double" (\o -> o + { optionLongFlags = ["t_Double"] + , optionType = optionTypeDouble + , optionDefault = "123.5" + }) + option "t_Maybe" (\o -> o + { optionLongFlags = ["t_Maybe"] + , optionType = optionTypeMaybe optionTypeBool + , optionDefault = "true" + }) + option "t_List" (\o -> o + { optionLongFlags = ["t_List"] + , optionType = optionTypeList ',' optionTypeBool + , optionDefault = "true,false" + }) + option "t_Set" (\o -> o + { optionLongFlags = ["t_Set"] + , optionType = optionTypeSet ',' optionTypeBool + , optionDefault = "true,false" + }) + option "t_Map" (\o -> o + { optionLongFlags = ["t_Map"] + , optionType = optionTypeMap ',' '=' optionTypeString optionTypeBool + , optionDefault = "true=true,false=false" + }) + option "t_Enum" (\o -> o + { optionLongFlags = ["t_Enum"] + , optionType = optionTypeEnum ''Bool + [ ("true", True) + , ("false", False) + ] + , optionDefault = "true" + }) + ) + +test_Defaults :: Suite +test_Defaults = assertions "defaults" $ do + let def = defaultOptions :: AllOptions + + -- Simple option definitions + $expect (equal (s_Bool def) True) + $expect (equal (s_String def) ("abc" :: String)) + $expect (equal (s_Strings def) (["a", "b", "c"] :: [String])) + $expect (equal (s_Text def) ("abc" :: Text)) + $expect (equal (s_Texts def) (["a", "b", "c"] :: [Text])) + $expect (equal (s_Path def) ("a/b/c" :: FilePath)) + $expect (equal (s_Int def) (123 :: Int)) + $expect (equal (s_Integer def) (123 :: Integer)) + $expect (equal (s_Float def) (123.5 :: Float)) + $expect (equal (s_Double def) (123.5 :: Double)) + + -- Explicitly typed option definitions + $expect (equal (t_Bool def) True) + $expect (equal (t_String def) ("abc" :: String)) + $expect (equal (t_Text def) ("abc" :: Text)) + $expect (equal (t_FilePath def) ("a/b/c" :: FilePath)) + $expect (equal (t_Int def) (123 :: Int)) + $expect (equal (t_Int8 def) (123 :: Int8)) + $expect (equal (t_Int16 def) (123 :: Int16)) + $expect (equal (t_Int32 def) (123 :: Int32)) + $expect (equal (t_Int64 def) (123 :: Int64)) + $expect (equal (t_Word def) (123 :: Word)) + $expect (equal (t_Word8 def) (123 :: Word8)) + $expect (equal (t_Word16 def) (123 :: Word16)) + $expect (equal (t_Word32 def) (123 :: Word32)) + $expect (equal (t_Word64 def) (123 :: Word64)) + $expect (equal (t_Integer def) (123 :: Integer)) + $expect (equal (t_Float def) (123.5 :: Float)) + $expect (equal (t_Double def) (123.5 :: Double)) + $expect (equal (t_Maybe def) (Just True :: Maybe Bool)) + $expect (equal (t_List def) ([True,False] :: [Bool])) + $expect (equal (t_Set def) (Set.fromList [True, False] :: Set Bool)) + $expect (equal (t_Map def) (Map.fromList [("true", True), ("false", False)] :: Map String Bool)) + $expect (equal (t_Enum def) True) diff --git a/tests/OptionsTests/Help.hs b/tests/OptionsTests/Help.hs new file mode 100644 --- /dev/null +++ b/tests/OptionsTests/Help.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Copyright (C) 2012 John Millikin +-- +-- See license.txt for details +module OptionsTests.Help + ( test_Help + ) where + +import Test.Chell + +import Options.Types +import Options.Help + +test_Help :: Suite +test_Help = suite "help" + [ test_AddHelpFlags + , test_CheckHelpFlag + , test_ShowHelpSummary + , test_ShowHelpSummary_Subcommand + , test_ShowHelpAll + , test_ShowHelpAll_Subcommand + , test_ShowHelpGroup + , test_ShowHelpGroup_Subcommand + , test_ShowHelpGroup_SubcommandInvalid + ] + +test_AddHelpFlags :: Suite +test_AddHelpFlags = suite "addHelpFlags" + [ test_AddHelpFlags_None + , test_AddHelpFlags_Short + , test_AddHelpFlags_Long + , test_AddHelpFlags_Both + , test_AddHelpFlags_NoAll + , test_AddHelpFlags_Subcommand + ] + +groupInfoHelp :: Maybe GroupInfo +groupInfoHelp = Just (GroupInfo + { groupInfoName = "all" + , groupInfoTitle = "Help Options" + , groupInfoDescription = "Show all help options." + }) + +infoHelpSummary :: [Char] -> [String] -> OptionInfo +infoHelpSummary shorts longs = OptionInfo + { optionInfoKey = "main:Options.Help:optHelpSummary" + , optionInfoShortFlags = shorts + , optionInfoLongFlags = longs + , optionInfoDefault = "false" + , optionInfoUnary = True + , optionInfoDescription = "Show option summary." + , optionInfoGroup = groupInfoHelp + } + +infoHelpAll :: OptionInfo +infoHelpAll = OptionInfo + { optionInfoKey = "main:Options.Help:optHelpGroup:all" + , optionInfoShortFlags = [] + , optionInfoLongFlags = ["help-all"] + , optionInfoDefault = "false" + , optionInfoUnary = True + , optionInfoDescription = "Show all help options." + , optionInfoGroup = groupInfoHelp + } + +test_AddHelpFlags_None :: Suite +test_AddHelpFlags_None = assertions "none" $ do + let commandDefs = OptionDefinitions + [ OptionInfo "test.help" ['h'] ["help"] "default" False "" Nothing + ] + [] + let helpAdded = addHelpFlags commandDefs + let OptionDefinitions opts subcmds = helpAdded + + $expect (equal opts + [ infoHelpAll + , OptionInfo "test.help" ['h'] ["help"] "default" False "" Nothing + ]) + $expect (equal subcmds []) + +test_AddHelpFlags_Short :: Suite +test_AddHelpFlags_Short = assertions "short" $ do + let commandDefs = OptionDefinitions + [ OptionInfo "test.help" [] ["help"] "default" False "" Nothing + ] + [] + let helpAdded = addHelpFlags commandDefs + let OptionDefinitions opts subcmds = helpAdded + + $expect (equal opts + [ infoHelpSummary ['h'] [] + , infoHelpAll + , OptionInfo "test.help" [] ["help"] "default" False "" Nothing + ]) + $expect (equal subcmds []) + +test_AddHelpFlags_Long :: Suite +test_AddHelpFlags_Long = assertions "long" $ do + let commandDefs = OptionDefinitions + [ OptionInfo "test.help" ['h'] [] "default" False "" Nothing + ] + [] + let helpAdded = addHelpFlags commandDefs + let OptionDefinitions opts subcmds = helpAdded + + $expect (equal opts + [ infoHelpSummary [] ["help"] + , infoHelpAll + , OptionInfo "test.help" ['h'] [] "default" False "" Nothing + ]) + $expect (equal subcmds []) + +test_AddHelpFlags_Both :: Suite +test_AddHelpFlags_Both = assertions "both" $ do + let commandDefs = OptionDefinitions [] [] + let helpAdded = addHelpFlags commandDefs + let OptionDefinitions opts subcmds = helpAdded + + $expect (equal opts + [ infoHelpSummary ['h'] ["help"] + , infoHelpAll + ]) + $expect (equal subcmds []) + +test_AddHelpFlags_NoAll :: Suite +test_AddHelpFlags_NoAll = assertions "no-all" $ do + let commandDefs = OptionDefinitions + [ OptionInfo "test.help" ['h'] ["help", "help-all"] "default" False "" Nothing + ] + [] + let helpAdded = addHelpFlags commandDefs + let OptionDefinitions opts subcmds = helpAdded + + $expect (equal opts + [ OptionInfo "test.help" ['h'] ["help", "help-all"] "default" False "" Nothing + ]) + $expect (equal subcmds []) + +test_AddHelpFlags_Subcommand :: Suite +test_AddHelpFlags_Subcommand = assertions "subcommand" $ do + let cmd1_a = OptionInfo "test.cmd1.a" ['a'] [] "" False "" (Just GroupInfo + { groupInfoName = "foo" + , groupInfoTitle = "Foo Options" + , groupInfoDescription = "More Foo Options" + }) + let cmd1_b = OptionInfo "test.cmd1.b" ['b'] [] "" False "" (Just GroupInfo + { groupInfoName = "all" + , groupInfoTitle = "All Options" + , groupInfoDescription = "More All Options" + }) + let commandDefs = OptionDefinitions + [] + [("cmd1", [cmd1_a, cmd1_b])] + let helpAdded = addHelpFlags commandDefs + let OptionDefinitions opts subcmds = helpAdded + + let helpFoo = OptionInfo + { optionInfoKey = "main:Options.Help:optHelpGroup:foo" + , optionInfoShortFlags = [] + , optionInfoLongFlags = ["help-foo"] + , optionInfoDefault = "false" + , optionInfoUnary = True + , optionInfoDescription = "More Foo Options" + , optionInfoGroup = Just (GroupInfo + { groupInfoName = "all" + , groupInfoTitle = "Help Options" + , groupInfoDescription = "Show all help options." + }) + } + + $expect (equal opts + [ infoHelpSummary ['h'] ["help"] + , infoHelpAll + ]) + $expect (equal subcmds [("cmd1", [helpFoo, cmd1_a, cmd1_b])]) + +test_CheckHelpFlag :: Suite +test_CheckHelpFlag = assertions "checkHelpFlag" $ do + let checkFlag keys = equal (checkHelpFlag (TokensFor [(k, ("-h", "true")) | k <- keys] [])) + + $expect (checkFlag [] Nothing) + $expect (checkFlag ["main:Options.Help:optHelpSummary"] (Just HelpSummary)) + $expect (checkFlag ["main:Options.Help:optHelpGroup:all"] (Just HelpAll)) + $expect (checkFlag ["main:Options.Help:optHelpGroup:foo"] (Just (HelpGroup "foo"))) + +variedOptions :: OptionDefinitions () +variedOptions = addHelpFlags $ OptionDefinitions + [ OptionInfo "test.a" ['a'] ["long-a"] "def" False "a description here" Nothing + , OptionInfo "test.long1" [] ["a-looooooooooooong-option"] "def" False "description here" Nothing + , OptionInfo "test.long2" [] ["a-loooooooooooooong-option"] "def" False "description here" Nothing + , OptionInfo "test.b" ['b'] ["long-b"] "def" False "b description here" Nothing + , OptionInfo "test.g" ['g'] ["long-g"] "def" False "g description here" (Just GroupInfo + { groupInfoName = "group" + , groupInfoTitle = "Grouped options" + , groupInfoDescription = "Show grouped options." + }) + ] + [ ("cmd1", + [ OptionInfo "test.cmd1.z" ['z'] ["long-z"] "def" False "z description here" Nothing + ]) + , ("cmd2", + [ OptionInfo "test.cmd2.y" ['y'] ["long-y"] "def" False "y description here" Nothing + , OptionInfo "test.cmd2.g2" [] ["long-g2"] "def" False "g2 description here" (Just GroupInfo + { groupInfoName = "group" + , groupInfoTitle = "Grouped options" + , groupInfoDescription = "Show grouped options." + }) + ]) + ] + +test_ShowHelpSummary :: Suite +test_ShowHelpSummary = assertions "showHelpSummary" $ do + let expected = "\ + \Help Options:\n\ + \ -h, --help Show option summary.\n\ + \ --help-all Show all help options.\n\ + \ --help-group Show grouped options.\n\ + \\n\ + \Application Options:\n\ + \ -a, --long-a a description here\n\ + \ --a-looooooooooooong-option description here\n\ + \ --a-loooooooooooooong-option\n\ + \ description here\n\ + \ -b, --long-b b description here\n\ + \\n\ + \Subcommands:\n\ + \ cmd1\n\ + \ cmd2\n\ + \\n" + $expect (equalLines expected (helpFor HelpSummary variedOptions Nothing)) + +test_ShowHelpSummary_Subcommand :: Suite +test_ShowHelpSummary_Subcommand = assertions "showHelpSummary-subcommand" $ do + let expected = "\ + \Help Options:\n\ + \ -h, --help Show option summary.\n\ + \ --help-all Show all help options.\n\ + \ --help-group Show grouped options.\n\ + \\n\ + \Application Options:\n\ + \ -a, --long-a a description here\n\ + \ --a-looooooooooooong-option description here\n\ + \ --a-loooooooooooooong-option\n\ + \ description here\n\ + \ -b, --long-b b description here\n\ + \\n\ + \Options for subcommand \"cmd1\":\n\ + \ -z, --long-z z description here\n\ + \\n" + $expect (equalLines expected (helpFor HelpSummary variedOptions (Just "cmd1"))) + +test_ShowHelpAll :: Suite +test_ShowHelpAll = assertions "showHelpAll" $ do + let expected = "\ + \Help Options:\n\ + \ -h, --help Show option summary.\n\ + \ --help-all Show all help options.\n\ + \ --help-group Show grouped options.\n\ + \\n\ + \Grouped options:\n\ + \ -g, --long-g g description here\n\ + \\n\ + \Application Options:\n\ + \ -a, --long-a a description here\n\ + \ --a-looooooooooooong-option description here\n\ + \ --a-loooooooooooooong-option\n\ + \ description here\n\ + \ -b, --long-b b description here\n\ + \\n\ + \Options for subcommand \"cmd1\":\n\ + \ -z, --long-z z description here\n\ + \\n\ + \Options for subcommand \"cmd2\":\n\ + \ -y, --long-y y description here\n\ + \ --long-g2 g2 description here\n\ + \\n" + $expect (equalLines expected (helpFor HelpAll variedOptions Nothing)) + +test_ShowHelpAll_Subcommand :: Suite +test_ShowHelpAll_Subcommand = assertions "showHelpAll-subcommand" $ do + let expected = "\ + \Help Options:\n\ + \ -h, --help Show option summary.\n\ + \ --help-all Show all help options.\n\ + \ --help-group Show grouped options.\n\ + \\n\ + \Grouped options:\n\ + \ -g, --long-g g description here\n\ + \\n\ + \Application Options:\n\ + \ -a, --long-a a description here\n\ + \ --a-looooooooooooong-option description here\n\ + \ --a-loooooooooooooong-option\n\ + \ description here\n\ + \ -b, --long-b b description here\n\ + \\n\ + \Options for subcommand \"cmd1\":\n\ + \ -z, --long-z z description here\n\ + \\n" + $expect (equalLines expected (helpFor HelpAll variedOptions (Just "cmd1"))) + +test_ShowHelpGroup :: Suite +test_ShowHelpGroup = assertions "showHelpGroup" $ do + let expected = "\ + \Grouped options:\n\ + \ -g, --long-g g description here\n\ + \\n" + $expect (equalLines expected (helpFor (HelpGroup "group") variedOptions Nothing)) + +test_ShowHelpGroup_Subcommand :: Suite +test_ShowHelpGroup_Subcommand = assertions "showHelpGroup-subcommand" $ do + let expected = "\ + \Grouped options:\n\ + \ -g, --long-g g description here\n\ + \ --long-g2 g2 description here\n\ + \\n" + $expect (equalLines expected (helpFor (HelpGroup "group") variedOptions (Just "cmd2"))) + +test_ShowHelpGroup_SubcommandInvalid :: Suite +test_ShowHelpGroup_SubcommandInvalid = assertions "showHelpGroup-subcommand-invalid" $ do + let expected = "\ + \Grouped options:\n\ + \ -g, --long-g g description here\n\ + \\n" + $expect (equalLines expected (helpFor (HelpGroup "group") variedOptions (Just "noexist"))) diff --git a/tests/OptionsTests/OptionTypes.hs b/tests/OptionsTests/OptionTypes.hs new file mode 100644 --- /dev/null +++ b/tests/OptionsTests/OptionTypes.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Copyright (C) 2012 John Millikin +-- +-- See license.txt for details +module OptionsTests.OptionTypes + ( test_OptionTypes + ) where + +import Data.Int +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.Word + +import qualified Filesystem.Path.Rules as Path +import qualified Filesystem.Path.CurrentOS () +import Test.Chell + +import Options.OptionTypes + +test_OptionTypes :: Suite +test_OptionTypes = suite "option-types" + [ test_Bool + , test_String + , test_Text + , test_FilePath + , test_Int + , test_Int8 + , test_Int16 + , test_Int32 + , test_Int64 + , test_Word + , test_Word8 + , test_Word16 + , test_Word32 + , test_Word64 + , test_Integer + , test_Float + , test_Double + , test_Maybe + , test_List + , test_Set + , test_Map + , test_Enum + ] + +parseValid :: (Show a, Eq a) => OptionType a -> String -> a -> Assertion +parseValid t s expected = equal (optionParser t s) (Right expected) + +parseInvalid :: (Show a, Eq a) => OptionType a -> String -> String -> Assertion +parseInvalid t s err = equal (optionParser t s) (Left err) + +optionParser :: OptionType a -> String -> Either String a +optionParser (OptionType _ _ p _) = p + +test_Bool :: Suite +test_Bool = assertions "bool" $ do + $expect (parseValid optionTypeBool "true" True) + $expect (parseValid optionTypeBool "false" False) + $expect (parseInvalid optionTypeBool "" "\"\" is not in {\"true\", \"false\"}.") + +test_String :: Suite +test_String = assertions "string" $ do + let valid = parseValid optionTypeString + let invalid = parseInvalid optionTypeString + + $expect (valid "" "") + $expect (valid "a" "a") + $expect (valid "\12354" "\12354") + $expect (valid "\56507" "\56507") + $expect (valid "\61371" "\61371") + +test_Text :: Suite +test_Text = assertions "text" $ do + let p = Text.pack + let valid = parseValid optionTypeText + let invalid = parseInvalid optionTypeText + + $expect (valid "" (p "")) + $expect (valid "a" (p "a")) + $expect (valid "\12354" (p "\12354")) + $expect (valid "\56507" (p "\65533")) + $expect (valid "\61371" (p "\61371")) + +test_FilePath :: Suite +test_FilePath = assertions "filepath" $ do + let p = Path.decodeString Path.posix_ghc704 + let valid = parseValid optionTypeFilePath + let invalid = parseInvalid optionTypeFilePath + + $expect (valid "" (p "")) + $expect (valid "a" (p "a")) + $expect (valid "a-\12403-c.txt" (p "a-\12403-c.txt")) +#if defined(CABAL_OS_WINDOWS) + $expect (valid "a-\61371-c.txt" (p "a-\61371-c.txt")) +#elif __GLASGOW_HASKELL__ == 702 + $expect (valid "a-\61371-c.txt" (p "a-\56507-c.txt")) +#else + $expect (valid "a-\56507-c.txt" (p "a-\56507-c.txt")) + $expect (valid "a-\61371-c.txt" (p "a-\61371-c.txt")) +#endif + +test_Int :: Suite +test_Int = assertions "int" $ do + let valid = parseValid optionTypeInt + let invalid = parseInvalid optionTypeInt + + $expect (valid "-1" (-1 :: Int)) + $expect (valid "1" (1 :: Int)) + $expect (invalid "a" "\"a\" is not an integer.") + + let pastMin = show (toInteger (minBound :: Int) - 1) + let pastMax = show (toInteger (maxBound :: Int) + 1) + let errBounds = " is not within bounds [" ++ show (minBound :: Int) ++ ":" ++ show (maxBound :: Int) ++ "] of type int." + + $expect (invalid pastMin (pastMin ++ errBounds)) + $expect (valid (show (minBound :: Int)) minBound) + $expect (valid (show (maxBound :: Int)) maxBound) + $expect (invalid pastMax (pastMax ++ errBounds)) + +test_Int8 :: Suite +test_Int8 = assertions "int8" $ do + let valid = parseValid optionTypeInt8 + let invalid = parseInvalid optionTypeInt8 + + $expect (valid "-1" (-1 :: Int8)) + $expect (valid "1" (1 :: Int8)) + $expect (invalid "a" "\"a\" is not an integer.") + + let pastMin = show (toInteger (minBound :: Int8) - 1) + let pastMax = show (toInteger (maxBound :: Int8) + 1) + $expect (invalid pastMin "-129 is not within bounds [-128:127] of type int8.") + $expect (valid (show (minBound :: Int8)) minBound) + $expect (valid (show (maxBound :: Int8)) maxBound) + $expect (invalid pastMax "128 is not within bounds [-128:127] of type int8.") + +test_Int16 :: Suite +test_Int16 = assertions "int16" $ do + let valid = parseValid optionTypeInt16 + let invalid = parseInvalid optionTypeInt16 + + $expect (valid "-1" (-1 :: Int16)) + $expect (valid "1" (1 :: Int16)) + $expect (invalid "a" "\"a\" is not an integer.") + + let pastMin = show (toInteger (minBound :: Int16) - 1) + let pastMax = show (toInteger (maxBound :: Int16) + 1) + $expect (invalid pastMin "-32769 is not within bounds [-32768:32767] of type int16.") + $expect (valid (show (minBound :: Int16)) minBound) + $expect (valid (show (maxBound :: Int16)) maxBound) + $expect (invalid pastMax "32768 is not within bounds [-32768:32767] of type int16.") + +test_Int32 :: Suite +test_Int32 = assertions "int32" $ do + let valid = parseValid optionTypeInt32 + let invalid = parseInvalid optionTypeInt32 + + $expect (valid "-1" (-1 :: Int32)) + $expect (valid "1" (1 :: Int32)) + $expect (invalid "a" "\"a\" is not an integer.") + + let pastMin = show (toInteger (minBound :: Int32) - 1) + let pastMax = show (toInteger (maxBound :: Int32) + 1) + $expect (invalid pastMin "-2147483649 is not within bounds [-2147483648:2147483647] of type int32.") + $expect (valid (show (minBound :: Int32)) minBound) + $expect (valid (show (maxBound :: Int32)) maxBound) + $expect (invalid pastMax "2147483648 is not within bounds [-2147483648:2147483647] of type int32.") + +test_Int64 :: Suite +test_Int64 = assertions "int64" $ do + let valid = parseValid optionTypeInt64 + let invalid = parseInvalid optionTypeInt64 + + $expect (valid "-1" (-1 :: Int64)) + $expect (valid "1" (1 :: Int64)) + $expect (invalid "a" "\"a\" is not an integer.") + + let pastMin = show (toInteger (minBound :: Int64) - 1) + let pastMax = show (toInteger (maxBound :: Int64) + 1) + $expect (invalid pastMin "-9223372036854775809 is not within bounds [-9223372036854775808:9223372036854775807] of type int64.") + $expect (valid (show (minBound :: Int64)) minBound) + $expect (valid (show (maxBound :: Int64)) maxBound) + $expect (invalid pastMax "9223372036854775808 is not within bounds [-9223372036854775808:9223372036854775807] of type int64.") + +test_Word :: Suite +test_Word = assertions "word" $ do + let valid = parseValid optionTypeWord + let invalid = parseInvalid optionTypeWord + + let pastMax = show (toInteger (maxBound :: Word) + 1) + let errBounds = " is not within bounds [0:" ++ show (maxBound :: Word) ++ "] of type word." + + $expect (invalid "-1" ("-1" ++ errBounds)) + $expect (valid "0" (0 :: Word)) + $expect (valid "1" (1 :: Word)) + $expect (invalid "a" "\"a\" is not an integer.") + + $expect (valid (show (maxBound :: Word)) maxBound) + $expect (invalid pastMax (pastMax ++ errBounds)) + +test_Word8 :: Suite +test_Word8 = assertions "word8" $ do + let valid = parseValid optionTypeWord8 + let invalid = parseInvalid optionTypeWord8 + + $expect (invalid "-1" "-1 is not within bounds [0:255] of type word8.") + $expect (valid "0" (0 :: Word8)) + $expect (valid "1" (1 :: Word8)) + $expect (invalid "a" "\"a\" is not an integer.") + + let pastMax = show (toInteger (maxBound :: Word8) + 1) + $expect (valid (show (maxBound :: Word8)) maxBound) + $expect (invalid pastMax "256 is not within bounds [0:255] of type word8.") + +test_Word16 :: Suite +test_Word16 = assertions "word16" $ do + let valid = parseValid optionTypeWord16 + let invalid = parseInvalid optionTypeWord16 + + $expect (invalid "-1" "-1 is not within bounds [0:65535] of type word16.") + $expect (valid "0" (0 :: Word16)) + $expect (valid "1" (1 :: Word16)) + $expect (invalid "a" "\"a\" is not an integer.") + + let pastMax = show (toInteger (maxBound :: Word16) + 1) + $expect (valid (show (maxBound :: Word16)) maxBound) + $expect (invalid pastMax "65536 is not within bounds [0:65535] of type word16.") + +test_Word32 :: Suite +test_Word32 = assertions "word32" $ do + let valid = parseValid optionTypeWord32 + let invalid = parseInvalid optionTypeWord32 + + $expect (invalid "-1" "-1 is not within bounds [0:4294967295] of type word32.") + $expect (valid "0" (0 :: Word32)) + $expect (valid "1" (1 :: Word32)) + $expect (invalid "a" "\"a\" is not an integer.") + + let pastMax = show (toInteger (maxBound :: Word32) + 1) + $expect (valid (show (maxBound :: Word32)) maxBound) + $expect (invalid pastMax "4294967296 is not within bounds [0:4294967295] of type word32.") + +test_Word64 :: Suite +test_Word64 = assertions "word64" $ do + let valid = parseValid optionTypeWord64 + let invalid = parseInvalid optionTypeWord64 + + $expect (invalid "-1" "-1 is not within bounds [0:18446744073709551615] of type word64.") + $expect (valid "0" (0 :: Word64)) + $expect (valid "1" (1 :: Word64)) + $expect (invalid "a" "\"a\" is not an integer.") + + let pastMax = show (toInteger (maxBound :: Word64) + 1) + $expect (valid (show (maxBound :: Word64)) maxBound) + $expect (invalid pastMax "18446744073709551616 is not within bounds [0:18446744073709551615] of type word64.") + +test_Integer :: Suite +test_Integer = assertions "integer" $ do + let valid = parseValid optionTypeInteger + let invalid = parseInvalid optionTypeInteger + + $expect (invalid "" "\"\" is not an integer.") + $expect (valid "-1" (-1 :: Integer)) + $expect (valid "0" (0 :: Integer)) + $expect (valid "1" (1 :: Integer)) + $expect (invalid "a" "\"a\" is not an integer.") + +test_Float :: Suite +test_Float = assertions "float" $ do + let valid = parseValid optionTypeFloat + let invalid = parseInvalid optionTypeFloat + + $expect (valid "-1" (-1 :: Float)) + $expect (valid "0" (0 :: Float)) + $expect (valid "1" (1 :: Float)) + $expect (valid "1.5" (1.5 :: Float)) + $expect (valid "3e5" (3e5 :: Float)) + $expect (invalid "a" "\"a\" is not a number.") + +test_Double :: Suite +test_Double = assertions "double" $ do + let valid = parseValid optionTypeDouble + let invalid = parseInvalid optionTypeDouble + + $expect (valid "-1" (-1 :: Double)) + $expect (valid "0" (0 :: Double)) + $expect (valid "1" (1 :: Double)) + $expect (valid "1.5" (1.5 :: Double)) + $expect (valid "3e5" (3e5 :: Double)) + $expect (invalid "a" "\"a\" is not a number.") + +test_Maybe :: Suite +test_Maybe = assertions "maybe" $ do + let t = optionTypeMaybe optionTypeInt + let valid = parseValid t + let invalid = parseInvalid t + + $expect (valid "" Nothing) + $expect (valid "1" (Just 1)) + $expect (invalid "a" "\"a\" is not an integer.") + +test_List :: Suite +test_List = assertions "list" $ do + let t = optionTypeList ',' optionTypeInt + let valid = parseValid t + let invalid = parseInvalid t + + $expect (valid "" []) + $expect (valid "1" [1]) + $expect (valid "1,2,3" [1, 2, 3]) + $expect (valid "1,1,2,3" [1, 1, 2, 3]) + $expect (invalid "1,a,3" "\"a\" is not an integer.") + +test_Set :: Suite +test_Set = assertions "set" $ do + let t = optionTypeSet ',' optionTypeInt + let valid = parseValid t + let invalid = parseInvalid t + + $expect (valid "" Set.empty) + $expect (valid "1" (Set.fromList [1])) + $expect (valid "1,2,3" (Set.fromList [1, 2, 3])) + $expect (valid "1,1,2,3" (Set.fromList [1, 2, 3])) + $expect (invalid "1,a,3" "\"a\" is not an integer.") + +test_Map :: Suite +test_Map = assertions "map" $ do + let t = optionTypeMap ',' '=' optionTypeInt optionTypeInt + let valid = parseValid t + let invalid = parseInvalid t + + $expect (valid "" Map.empty) + $expect (valid "1=100" (Map.fromList [(1, 100)])) + $expect (valid "1=100,2=200,3=300" (Map.fromList [(1, 100), (2, 200), (3, 300)])) + $expect (valid "1=100,2=200,1=300" (Map.fromList [(1, 300), (2, 200)])) + $expect (invalid "a=1" "\"a\" is not an integer.") + $expect (invalid "1=a" "\"a\" is not an integer.") + $expect (invalid "1=" "\"\" is not an integer.") + $expect (invalid "1" "Map item \"1\" has no value.") + +data TestEnum = Enum1 | Enum2 | Enum3 + deriving (Enum, Eq, Show) + +test_Enum :: Suite +test_Enum = assertions "enum" $ do + let t = optionTypeEnum ''TestEnum + [ ("e1", Enum1) + , ("e2", Enum2) + , ("e3", Enum3) + ] + let valid = parseValid t + let invalid = parseInvalid t + + $expect (valid "e1" Enum1) + $expect (valid "e2" Enum2) + $expect (invalid "e4" "\"e4\" is not in {\"e1\", \"e2\", \"e3\"}.") diff --git a/tests/OptionsTests/StringParsing.hs b/tests/OptionsTests/StringParsing.hs new file mode 100644 --- /dev/null +++ b/tests/OptionsTests/StringParsing.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Copyright (C) 2012 John Millikin +-- +-- See license.txt for details +module OptionsTests.StringParsing + ( test_StringParsing + ) where + +import Prelude hiding (FilePath) +import Control.Monad (unless) +import Data.Text () + +import qualified Filesystem.Path.Rules as Path +import qualified Filesystem.Path.CurrentOS () +import Test.Chell + +import Options + +$(defineOptions "StringOptions" $ do + stringOption "optString" "string" "" "" + textOption "optText" "text" "" "" + pathOption "optPath" "path" (Path.decodeString Path.posix_ghc704 "") "" + + -- String, ASCII default + option "optString_defA" (\o -> o + { optionLongFlags = ["string_defA"] + , optionDefault = "a" + }) + + -- String, Unicode default + option "optString_defU" (\o -> o + { optionLongFlags = ["string_defU"] + , optionDefault = "\12354" + }) + + -- Text, ASCII default + option "optText_defA" (\o -> o + { optionLongFlags = ["text_defA"] + , optionDefault = "a" + , optionType = optionTypeText + }) + + -- Text, Unicode default + option "optText_defU" (\o -> o + { optionLongFlags = ["text_defU"] + , optionDefault = "\12354" + , optionType = optionTypeText + }) + + -- FilePath, ASCII default + option "optPath_defA" (\o -> o + { optionLongFlags = ["path_defA"] + , optionDefault = "a/b/c" + , optionType = optionTypeFilePath + }) + + -- FilePath, Unicode default + option "optPath_defU" (\o -> o + { optionLongFlags = ["path_defU"] + , optionDefault = "\12354/b/c" + , optionType = optionTypeFilePath + }) + + -- FilePath, bytes default + option "optPath_defB" (\o -> o + { optionLongFlags = ["path_defB"] + , optionDefault = "\56507/b/c" + , optionType = optionTypeFilePath + }) + ) + +windowsBuild :: Bool +#if defined(CABAL_OS_WINDOWS) +windowsBuild = True +#else +windowsBuild = False +#endif + +test_StringParsing :: Suite +test_StringParsing = suite "string-parsing" + [ test_Defaults + , test_Ascii + , test_UnicodeValid + , skipIf windowsBuild test_UnicodeInvalid + ] + +test_Defaults :: Suite +test_Defaults = assertions "defaults" $ do + let opts = defaultOptions + + $expect (equal (optString_defA opts) "a") + $expect (equal (optString_defU opts) "\12354") + + $expect (equal (optText_defA opts) "a") + $expect (equal (optText_defU opts) "\12354") + + $expect (equal (optPath_defA opts) (Path.decodeString Path.posix_ghc704 "a/b/c")) + $expect (equal (optPath_defU opts) (Path.decodeString Path.posix_ghc704 "\12354/b/c")) + unless windowsBuild $ do + $expect (equal (optPath_defB opts) (Path.decodeString Path.posix_ghc704 "\56507/b/c")) + +test_Ascii :: Suite +test_Ascii = assertions "ascii" $ do + let parsed = parseOptions ["--string=a", "--text=a", "--path=a"] + let Just opts = parsedOptions parsed + + $expect (equal (optString opts) "a") + $expect (equal (optText opts) "a") + $expect (equal (optPath opts) (Path.decodeString Path.posix_ghc704 "a")) + +test_UnicodeValid :: Suite +test_UnicodeValid = assertions "unicode-valid" $ do +#if defined(OPTIONS_ENCODING_UTF8) + let parsed = parseOptions ["--string=\227\129\130", "--text=\227\129\130", "--path=\227\129\130/b/c"] +#else + let parsed = parseOptions ["--string=\12354", "--text=\12354", "--path=\12354/b/c"] +#endif + let Just opts = parsedOptions parsed + + $expect (equal (optString opts) "\12354") + $expect (equal (optText opts) "\12354") + $expect (equal (optPath opts) (Path.decodeString Path.posix_ghc704 "\12354/b/c")) + +test_UnicodeInvalid :: Suite +test_UnicodeInvalid = assertions "unicode-invalid" $ do +#if __GLASGOW_HASKELL__ >= 704 + let parsed = parseOptions ["--string=\56507", "--text=\56507", "--path=\12354/\56507"] + let expectedString = "\56507" + let expectedText = "\65533" +#elif __GLASGOW_HASKELL__ >= 702 + let parsed = parseOptions ["--string=\61371", "--text=\61371", "--path=\12354/\61371"] + let expectedString = "\61371" + let expectedText = "\61371" +#else + let parsed = parseOptions ["--string=\187", "--text=\187", "--path=\227\129\130/\187"] + let expectedString = "\56507" + let expectedText = "\65533" +#endif + let Just opts = parsedOptions parsed + + $expect (equal (optString opts) expectedString) + $expect (equal (optText opts) expectedText) + $expect (equal (optPath opts) (Path.decodeString Path.posix_ghc704 "\12354/\56507")) diff --git a/tests/OptionsTests/Tokenize.hs b/tests/OptionsTests/Tokenize.hs new file mode 100644 --- /dev/null +++ b/tests/OptionsTests/Tokenize.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Copyright (C) 2012 John Millikin +-- +-- See license.txt for details +module OptionsTests.Tokenize + ( test_Tokenize + ) where + +import Test.Chell + +import Options.Types +import Options.Tokenize + +test_Tokenize :: Suite +test_Tokenize = suite "tokenize" + [ test_Empty + , test_NoFlag + , test_ShortFlag + , test_ShortFlagUnknown + , test_ShortFlagMissing + , test_ShortFlagUnary + , test_ShortFlagDuplicate + , test_LongFlag + , test_LongFlagUnknown + , test_LongFlagMissing + , test_LongFlagUnary + , test_LongFlagDuplicate + , test_EndFlags + , test_Subcommand + , test_SubcommandUnknown + , test_Unicode + ] + +commandDefs :: OptionDefinitions () +commandDefs = OptionDefinitions + [ OptionInfo "test.a" ['a'] ["long-a"] "default" False "" Nothing + , OptionInfo "test.x" ['x'] ["long-x"] "default" True "" Nothing + , OptionInfo "test.y" ['y'] ["long-y"] "default" True "" Nothing + , OptionInfo "test.z" ['z'] ["long-z"] "default" True "" Nothing + ] + [] + +subcommandDefs :: OptionDefinitions () +subcommandDefs = OptionDefinitions + [ OptionInfo "test.a" ['a'] ["long-a"] "default" False "" Nothing + , OptionInfo "test.b" ['b'] ["long-b"] "default" False "" Nothing + , OptionInfo "test.x" ['x'] ["long-x"] "default" True "" Nothing + , OptionInfo "test.y" ['y'] ["long-y"] "default" True "" Nothing + , OptionInfo "test.z" ['z'] ["long-z"] "default" True "" Nothing + ] + [ ("sub1", + [ OptionInfo "sub.d" ['d'] ["long-d"] "default" False "" Nothing + , OptionInfo "sub.e" ['e'] ["long-e"] "default" True "" Nothing + ]) + , ("sub2", + [ OptionInfo "sub.d" ['d'] ["long-d"] "default" True "" Nothing + , OptionInfo "sub.e" ['e'] ["long-e"] "default" True "" Nothing + ]) + ] + +unicodeDefs :: OptionDefinitions () +unicodeDefs = OptionDefinitions + [ OptionInfo "test.a" ['\12354'] ["long-\12354"] "default" False "" Nothing + ] + [] + +test_Empty :: Suite +test_Empty = assertions "empty" $ do + let (subcmd, eTokens) = tokenize commandDefs [] + $expect (equal Nothing subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [] tokens) + $expect (equal [] args) + +test_NoFlag :: Suite +test_NoFlag = assertions "no-flag" $ do + let (subcmd, eTokens) = tokenize commandDefs ["-", "foo", "bar"] + $expect (equal Nothing subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [] tokens) + $expect (equal ["-", "foo", "bar"] args) + +test_ShortFlag :: Suite +test_ShortFlag = assertions "short-flag" $ do + do + let (subcmd, eTokens) = tokenize commandDefs ["-a", "foo", "bar"] + $expect (equal Nothing subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [("test.a", ("-a", "foo"))] tokens) + $expect (equal ["bar"] args) + do + let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "bar"] + $expect (equal Nothing subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [("test.a", ("-a", "foo"))] tokens) + $expect (equal ["bar"] args) + +test_ShortFlagUnknown :: Suite +test_ShortFlagUnknown = assertions "short-flag-unknown" $ do + let (subcmd, eTokens) = tokenize commandDefs ["-c", "foo", "bar"] + $expect (equal Nothing subcmd) + $assert (left eTokens) + + let Left err = eTokens + $expect (equal "Unknown flag -c" err) + +test_ShortFlagMissing :: Suite +test_ShortFlagMissing = assertions "short-flag-missing" $ do + let (subcmd, eTokens) = tokenize commandDefs ["-a"] + $expect (equal Nothing subcmd) + $assert (left eTokens) + + let Left err = eTokens + $expect (equal "The flag -a requires an argument." err) + +test_ShortFlagUnary :: Suite +test_ShortFlagUnary = assertions "short-flag-unary" $ do + do + let (subcmd, eTokens) = tokenize commandDefs ["-x", "foo", "bar"] + $expect (equal Nothing subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [("test.x", ("-x", "true"))] tokens) + $expect (equal ["foo", "bar"] args) + do + let (subcmd, eTokens) = tokenize commandDefs ["-xy", "foo", "bar"] + $expect (equal Nothing subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [("test.x", ("-x", "true")), ("test.y", ("-y", "true"))] tokens) + $expect (equal ["foo", "bar"] args) + +test_ShortFlagDuplicate :: Suite +test_ShortFlagDuplicate = assertions "short-flag-duplicate" $ do + do + let (subcmd, eTokens) = tokenize commandDefs ["-x", "-x"] + $expect (equal Nothing subcmd) + $assert (left eTokens) + + let Left err = eTokens + $expect (equal "Multiple values for flag -x were provided." err) + do + let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "-a", "foo"] + $expect (equal Nothing subcmd) + $assert (left eTokens) + + let Left err = eTokens + $expect (equal "Multiple values for flag -a were provided." err) + do + let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "-afoo"] + $expect (equal Nothing subcmd) + $assert (left eTokens) + + let Left err = eTokens + $expect (equal "Multiple values for flag -a were provided." err) + +test_LongFlag :: Suite +test_LongFlag = assertions "long-flag" $ do + do + let (subcmd, eTokens) = tokenize commandDefs ["--long-a", "foo", "bar"] + $expect (equal Nothing subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [("test.a", ("--long-a", "foo"))] tokens) + $expect (equal ["bar"] args) + do + let (subcmd, eTokens) = tokenize commandDefs ["--long-a=foo", "bar"] + $expect (equal Nothing subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [("test.a", ("--long-a", "foo"))] tokens) + $expect (equal ["bar"] args) + +test_LongFlagUnknown :: Suite +test_LongFlagUnknown = assertions "long-flag-unknown" $ do + do + let (subcmd, eTokens) = tokenize commandDefs ["--long-c", "foo", "bar"] + $expect (equal Nothing subcmd) + $assert (left eTokens) + + let Left err = eTokens + $expect (equal "Unknown flag --long-c" err) + do + let (subcmd, eTokens) = tokenize commandDefs ["--long-c=foo", "bar"] + $expect (equal Nothing subcmd) + $assert (left eTokens) + + let Left err = eTokens + $expect (equal "Unknown flag --long-c" err) + +test_LongFlagMissing :: Suite +test_LongFlagMissing = assertions "long-flag-missing" $ do + let (subcmd, eTokens) = tokenize commandDefs ["--long-a"] + $expect (equal Nothing subcmd) + $assert (left eTokens) + + let Left err = eTokens + $expect (equal "The flag --long-a requires an argument." err) + +test_LongFlagUnary :: Suite +test_LongFlagUnary = assertions "long-flag-unary" $ do + do + let (subcmd, eTokens) = tokenize commandDefs ["--long-x", "foo", "bar"] + $expect (equal Nothing subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [("test.x", ("--long-x", "true"))] tokens) + $expect (equal ["foo", "bar"] args) + do + let (subcmd, eTokens) = tokenize commandDefs ["--long-x=foo", "bar"] + $expect (equal Nothing subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [("test.x", ("--long-x", "foo"))] tokens) + $expect (equal ["bar"] args) + +test_LongFlagDuplicate :: Suite +test_LongFlagDuplicate = assertions "long-flag-duplicate" $ do + do + let (subcmd, eTokens) = tokenize commandDefs ["-x", "--long-x"] + $expect (equal Nothing subcmd) + $assert (left eTokens) + + let Left err = eTokens + $expect (equal "Multiple values for flag --long-x were provided." err) + do + let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "--long-a", "foo"] + $expect (equal Nothing subcmd) + $assert (left eTokens) + + let Left err = eTokens + $expect (equal "Multiple values for flag --long-a were provided." err) + do + let (subcmd, eTokens) = tokenize commandDefs ["-afoo", "--long-a=foo"] + $expect (equal Nothing subcmd) + $assert (left eTokens) + + let Left err = eTokens + $expect (equal "Multiple values for flag --long-a were provided." err) + +test_EndFlags :: Suite +test_EndFlags = assertions "end-flags" $ do + let (subcmd, eTokens) = tokenize commandDefs ["foo", "--", "-a", "bar"] + $expect (equal Nothing subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [] tokens) + $expect (equal ["foo", "-a", "bar"] args) + +test_Subcommand :: Suite +test_Subcommand = assertions "subcommand" $ do + do + let (subcmd, eTokens) = tokenize subcommandDefs ["-x", "sub1", "-d", "foo", "--long-e", "bar"] + $expect (equal (Just "sub1") subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [("test.x", ("-x", "true")), ("sub.d", ("-d", "foo")), ("sub.e", ("--long-e", "true"))] tokens) + $expect (equal ["bar"] args) + do + let (subcmd, eTokens) = tokenize subcommandDefs ["-x", "sub2", "-d", "foo", "--long-e", "bar"] + $expect (equal (Just "sub2") subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [("test.x", ("-x", "true")), ("sub.d", ("-d", "true")), ("sub.e", ("--long-e", "true"))] tokens) + $expect (equal ["foo", "bar"] args) + +test_SubcommandUnknown:: Suite +test_SubcommandUnknown = assertions "subcommand-unknown" $ do + let (subcmd, eTokens) = tokenize subcommandDefs ["foo"] + $expect (equal Nothing subcmd) + $assert (left eTokens) + + let Left err = eTokens + $expect (equal "Unknown subcommand \"foo\"." err) + +test_Unicode :: Suite +test_Unicode = assertions "unicode" $ do +#if defined(OPTIONS_ENCODING_UTF8) + let shortArgs = ["-\227\129\130", "foo", "bar"] + let longArgs = ["--long-\227\129\130=foo", "bar"] +#else + let shortArgs = ["-\12354", "foo", "bar"] + let longArgs = ["--long-\12354=foo", "bar"] +#endif + do + let (subcmd, eTokens) = tokenize unicodeDefs shortArgs + $expect (equal Nothing subcmd) + case eTokens of + Left err -> error err + Right _ -> return () + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [("test.a", ("-\12354", "foo"))] tokens) + $expect (equal ["bar"] args) + do + let (subcmd, eTokens) = tokenize unicodeDefs longArgs + $expect (equal Nothing subcmd) + $assert (right eTokens) + + let Right (TokensFor tokens args) = eTokens + $expect (equal [("test.a", ("--long-\12354", "foo"))] tokens) + $expect (equal ["bar"] args) diff --git a/tests/OptionsTests/Util.hs b/tests/OptionsTests/Util.hs new file mode 100644 --- /dev/null +++ b/tests/OptionsTests/Util.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Copyright (C) 2012 John Millikin +-- +-- See license.txt for details +module OptionsTests.Util + ( test_Util + ) where + +#if defined(OPTIONS_ENCODING_UTF8) +import Data.Bits +import qualified Data.ByteString.Char8 as Char8 +import Data.Char (chr, ord) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import Test.Chell.QuickCheck +import Test.QuickCheck (Property, forAll) +import Test.QuickCheck.Gen +#endif + +import Test.Chell + +import Options.Util + +test_Util :: Suite +test_Util = suite "util" + [ test_ValidFieldName + , test_ValidShortFlag + , test_ValidLongFlag + , test_HasDuplicates +#if defined(OPTIONS_ENCODING_UTF8) + , property "decodeUtf8" prop_DecodeUtf8 +#endif + ] + +test_ValidFieldName :: Suite +test_ValidFieldName = assertions "validFieldName" $ do + $expect (validFieldName "a") + $expect (validFieldName "abc") + $expect (validFieldName "_abc_") + $expect (validFieldName "abc'") + $expect (validFieldName "\12354") + $expect (not (validFieldName "")) + $expect (not (validFieldName "'a")) + $expect (not (validFieldName "a b")) + $expect (not (validFieldName "Ab")) + +test_ValidShortFlag :: Suite +test_ValidShortFlag = assertions "validShortFlag" $ do + $expect (validShortFlag 'a') + $expect (validShortFlag 'A') + $expect (validShortFlag '0') + $expect (validShortFlag '\12354') + $expect (not (validShortFlag ' ')) + $expect (not (validShortFlag '-')) + +test_ValidLongFlag :: Suite +test_ValidLongFlag = assertions "validLongFlag" $ do + $expect (validLongFlag "a") + $expect (validLongFlag "A") + $expect (validLongFlag "abc") + $expect (validLongFlag "0") + $expect (validLongFlag "012") + $expect (validLongFlag "a-b") + $expect (validLongFlag "a_b") + $expect (validLongFlag "\12354bc") + $expect (not (validLongFlag "")) + $expect (not (validLongFlag "a b")) + $expect (not (validLongFlag "a+b")) + $expect (not (validLongFlag "-")) + $expect (not (validLongFlag "--")) + +test_HasDuplicates :: Suite +test_HasDuplicates = assertions "hasDuplicates" $ do + $expect (not (hasDuplicates ([] :: [Char]))) + $expect (not (hasDuplicates ['a', 'b'])) + $expect (hasDuplicates ['a', 'b', 'a']) + +#if defined(OPTIONS_ENCODING_UTF8) +prop_DecodeUtf8 :: Property +prop_DecodeUtf8 = forAll example prop where + example = do + chunks <- listOf genChunk + let utf = concat [x | (x, _) <- chunks] + let chars = concat [x | (_, x) <- chunks] + return (Char8.pack utf, chars) + genChunk = do + unichr <- genUnichar + let utf = Char8.unpack (Text.encodeUtf8 (Text.singleton unichr)) + nBytes <- choose (1, length utf) + let truncUtf = take nBytes utf + return $ if nBytes == length utf + then (utf, [unichr]) + else (truncUtf, map (\c -> chr (ord c + 0xDC00)) truncUtf) + prop (bytes, expected) = decodeUtf8 bytes == expected + +genUnichar :: Gen Char +genUnichar = chr `fmap` excluding reserved (oneof planes) where + excluding :: [a -> Bool] -> Gen a -> Gen a + excluding bad gen = loop where + loop = do + x <- gen + if or (map ($ x) bad) + then loop + else return x + + reserved = [lowSurrogate, highSurrogate, noncharacter] + lowSurrogate c = c >= 0xDC00 && c <= 0xDFFF + highSurrogate c = c >= 0xD800 && c <= 0xDBFF + noncharacter c = masked == 0xFFFE || masked == 0xFFFF where + masked = c .&. 0xFFFF + + ascii = choose (0,0x7F) + plane0 = choose (0xF0, 0xFFFF) + plane1 = oneof [ choose (0x10000, 0x10FFF) + , choose (0x11000, 0x11FFF) + , choose (0x12000, 0x12FFF) + , choose (0x13000, 0x13FFF) + , choose (0x1D000, 0x1DFFF) + , choose (0x1F000, 0x1FFFF) + ] + plane2 = oneof [ choose (0x20000, 0x20FFF) + , choose (0x21000, 0x21FFF) + , choose (0x22000, 0x22FFF) + , choose (0x23000, 0x23FFF) + , choose (0x24000, 0x24FFF) + , choose (0x25000, 0x25FFF) + , choose (0x26000, 0x26FFF) + , choose (0x27000, 0x27FFF) + , choose (0x28000, 0x28FFF) + , choose (0x29000, 0x29FFF) + , choose (0x2A000, 0x2AFFF) + , choose (0x2B000, 0x2BFFF) + , choose (0x2F000, 0x2FFFF) + ] + plane14 = choose (0xE0000, 0xE0FFF) + planes = [ascii, plane0, plane1, plane2, plane14] +#endif diff --git a/tests/options-tests.cabal b/tests/options-tests.cabal new file mode 100644 --- /dev/null +++ b/tests/options-tests.cabal @@ -0,0 +1,39 @@ +name: options-tests +version: 0 +build-type: Simple +cabal-version: >= 1.6 + +flag coverage + default: False + manual: True + +executable options_tests + main-is: OptionsTests.hs + ghc-options: -Wall + cc-options: -Wall + hs-source-dirs: ../lib,. + + if flag(coverage) + ghc-options: -fhpc + + if os(windows) + cpp-options: -DCABAL_OS_WINDOWS + + if !os(windows) && impl(ghc < 7.2) + cpp-options: -DOPTIONS_ENCODING_UTF8 + c-sources: ../cbits/utf8.c + + build-depends: + base >= 4.0 && < 5.0 + , bytestring + , chell >= 0.2 && < 0.3 + , chell-quickcheck >= 0.1 && < 0.2 + , containers + , monads-tf + , QuickCheck + , split + , system-filepath >= 0.4 && < 0.5 + , template-haskell + , text + , transformers +