Skip to content

Commit

Permalink
Merge pull request #59 from roman/41-allow-switch-cli-input
Browse files Browse the repository at this point in the history 
Add support for switch input (closes #41)
  • Loading branch information
@roman
roman authored Jul 21, 2018
2 parents b515818 + e9c3132 commit f97e1e5
Show file tree
Hide file tree
Showing 5 changed files with 229 additions and 50 deletions.
48 changes: 33 additions & 15 deletions etc/src/System/Etc/Internal/Resolver/Cli/Common.hs
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
Expand Down Expand Up @@ -59,17 +60,27 @@ instance Exception CliConfigError

--------------------------------------------------------------------------------

specToCliSwitchFieldMod specSettings =
maybe Opt.idm (Opt.long . Text.unpack) (Spec.optLong specSettings)
#if MIN_VERSION_optparse_applicative(0,14,0)
specToCliOptFieldMod :: Opt.HasName f => Spec.CliOptMetadata -> Opt.Mod f a
#endif
specToCliOptFieldMod meta =
maybe Opt.idm (Opt.long . Text.unpack) (Spec.optLong meta)
`mappend` maybe Opt.idm Opt.short shortOption
`mappend` maybe Opt.idm (Opt.help . Text.unpack) (Spec.optHelp specSettings)
`mappend` maybe Opt.idm (Opt.help . Text.unpack) (Spec.optHelp meta)
where
shortOption = do
shortStr <- Spec.optShort specSettings
shortStr <- Spec.optShort meta
fst <$> Text.uncons shortStr

specToCliVarFieldMod specSettings = specToCliSwitchFieldMod specSettings
`mappend` maybe Opt.idm (Opt.metavar . Text.unpack) (Spec.optMetavar specSettings)
#if MIN_VERSION_optparse_applicative(0,14,0)
specToCliSwitchFieldMod :: Opt.HasName f => Spec.CliSwitchMetadata -> Opt.Mod f a
#endif
specToCliSwitchFieldMod meta =
Opt.long (Text.unpack $ Spec.switchLong meta)
`mappend` maybe Opt.idm (Opt.help . Text.unpack) (Spec.switchHelp meta)

specToCliArgFieldMod :: Spec.CliArgMetadata -> Opt.Mod f a
specToCliArgFieldMod meta = maybe Opt.idm (Opt.help . Text.unpack) (Spec.argHelp meta)

commandToKey :: (MonadThrow m, JSON.ToJSON cmd) => cmd -> m [Text]
commandToKey cmd = case JSON.toJSON cmd of
Expand Down Expand Up @@ -101,16 +112,23 @@ settingsToJsonCli
-> Bool
-> Spec.CliEntryMetadata
-> Opt.Parser (Maybe (Value JSON.Value))
settingsToJsonCli cvType isSensitive specSettings =
let requiredCombinator =
if Spec.optRequired specSettings then (Just <$>) else Opt.optional
in requiredCombinator $ case specSettings of
Spec.Opt{} -> Opt.option (Opt.eitherReader $ jsonOptReader cvType isSensitive)
(specToCliVarFieldMod specSettings)

Spec.Arg{} -> Opt.argument
settingsToJsonCli cvType isSensitive specSettings = case specSettings of
Spec.Opt meta ->
let requiredCombinator = if Spec.optRequired meta then (Just <$>) else Opt.optional
in requiredCombinator $ Opt.option
(Opt.eitherReader $ jsonOptReader cvType isSensitive)
(specToCliOptFieldMod meta)

Spec.Arg meta ->
let requiredCombinator = if Spec.argRequired meta then (Just <$>) else Opt.optional
in requiredCombinator $ Opt.argument
(Opt.eitherReader $ jsonOptReader cvType isSensitive)
(specSettings & Spec.argMetavar & maybe Opt.idm (Opt.metavar . Text.unpack))
(specToCliArgFieldMod meta)

Spec.Switch meta ->
let requiredCombinator = fmap (Just . Plain . JSON.Bool)
in requiredCombinator (Opt.switch (specToCliSwitchFieldMod meta)) <|> pure Nothing



parseCommandJsonValue :: (MonadThrow m, JSON.FromJSON a) => JSON.Value -> m a
Expand Down
37 changes: 28 additions & 9 deletions etc/src/System/Etc/Internal/Spec/Parser.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -57,7 +57,12 @@ cliArgTypeParser object = do

cliArgParser :: JSON.Object -> JSON.Parser CliEntryMetadata
cliArgParser object =
Arg <$> (object .:? "metavar") <*> (fromMaybe True <$> (object .:? "required"))
Arg
<$> ( CliArgMetadata
<$> (object .:? "metavar")
<*> (object .:? "help")
<*> (fromMaybe True <$> (object .:? "required"))
)

cliOptParser :: JSON.Object -> JSON.Parser CliEntryMetadata
cliOptParser object = do
Expand All @@ -67,11 +72,18 @@ cliOptParser object = do
then fail "'option' field input requires either 'long' or 'short' settings"
else
Opt
<$> pure long
<*> pure short
<*> (object .:? "metavar")
<*> (object .:? "help")
<*> (fromMaybe True <$> (object .:? "required"))
<$> ( CliOptMetadata
<$> pure long
<*> pure short
<*> (object .:? "metavar")
<*> (object .:? "help")
<*> (fromMaybe True <$> (object .:? "required"))
)

cliSwitchParser :: JSON.Object -> JSON.Parser CliEntryMetadata
cliSwitchParser object =
Switch <$> (CliSwitchMetadata <$> (object .: "long") <*> (object .:? "help"))


cliArgKeys :: [Text]
cliArgKeys = ["input", "commands", "metavar", "required"]
Expand Down Expand Up @@ -106,12 +118,19 @@ instance JSON.FromJSON cmd => JSON.FromJSON (CliEntrySpec cmd) where

optParseEntryCtor <$> cliArgParser object

| inputName == "switch" -> do
forM_ (HashMap.keys object) $ \key ->
when (not (key `elem` cliOptKeys))
(fail $ "cli option contains invalid key " ++ show key)

optParseEntryCtor <$> cliSwitchParser object

| otherwise ->
JSON.typeMismatch "CliEntryMetadata (invalid input)" value
JSON.typeMismatch "Invalid input (option, argument, switch)" value
_ ->
JSON.typeMismatch "CliEntryMetadata (invalid input)" value
JSON.typeMismatch "Invalid input (option, argument, switch)" value
_ ->
JSON.typeMismatch "CliEntryMetadata" json
JSON.typeMismatch "Invalid input (option, argument, switch)" json

--------------------------------------------------------------------------------

Expand Down
87 changes: 65 additions & 22 deletions etc/src/System/Etc/Internal/Spec/Types.hs
View file
Original file line number Diff line number Diff line change
@@ -1,15 +1,16 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TemplateHaskell #-}
#endif
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module System.Etc.Internal.Spec.Types where


Expand All @@ -36,37 +37,79 @@ data CliArgValueType
| NumberArg
deriving (Generic, Show, Eq, Lift)

data CliEntryMetadata
= Opt {
data CliOptMetadata
= CliOptMetadata {
optLong :: !(Maybe Text)
, optShort :: !(Maybe Text)
, optMetavar :: !(Maybe Text)
, optHelp :: !(Maybe Text)
, optRequired :: !Bool
}
| Arg {
argMetavar :: !(Maybe Text)
, optRequired :: !Bool
}
deriving (Generic, Show, Eq)

instance Lift CliEntryMetadata where
lift Opt {optLong, optShort, optMetavar, optHelp, optRequired} =
[| Opt { optLong = fmap Text.pack optLongStr
instance Lift CliOptMetadata where
lift CliOptMetadata {optLong, optShort, optMetavar, optHelp, optRequired} =
[| CliOptMetadata
{ optLong = fmap Text.pack optLongStr
, optShort = fmap Text.pack optShortStr
, optMetavar = fmap Text.pack optMetavarStr
, optHelp = fmap Text.pack optHelpStr
, optRequired = optRequired }|]
, optRequired = optRequired
} |]
where
optLongStr = fmap Text.unpack optLong
optShortStr = fmap Text.unpack optShort
optMetavarStr = fmap Text.unpack optMetavar
optHelpStr = fmap Text.unpack optHelp
lift Arg {argMetavar, optRequired} =
[| Arg { argMetavar = fmap Text.pack argMetavarStr
, optRequired = optRequired } |]

data CliArgMetadata
= CliArgMetadata {
argMetavar :: !(Maybe Text)
, argHelp :: !(Maybe Text)
, argRequired :: !Bool
}
deriving (Generic, Show, Eq)

instance Lift CliArgMetadata where
lift CliArgMetadata {argMetavar, argHelp, argRequired} =
[| CliArgMetadata {
argMetavar = fmap Text.pack argMetavarStr
, argHelp = fmap Text.pack argHelpStr
, argRequired = argRequired
}
|]
where
argMetavarStr = fmap Text.unpack argMetavar
argHelpStr = fmap Text.unpack argHelp

data CliSwitchMetadata
= CliSwitchMetadata {
switchLong :: !Text
, switchHelp :: !(Maybe Text)
}
deriving (Generic, Show, Eq)

instance Lift CliSwitchMetadata where
lift CliSwitchMetadata {switchLong, switchHelp} =
[| CliSwitchMetadata
{ switchLong = Text.pack switchLongStr
, switchHelp = fmap Text.pack switchHelpStr
} |]
where
switchLongStr = Text.unpack switchLong
switchHelpStr = fmap Text.unpack switchHelp


data CliEntryMetadata
= Opt CliOptMetadata
| Arg CliArgMetadata
| Switch CliSwitchMetadata
deriving (Generic, Show, Eq)

instance Lift CliEntryMetadata where
lift (Opt metadata) = [| Opt metadata |]
lift (Arg metadata) = [| Arg metadata |]
lift (Switch metadata) = [| Switch metadata |]

data CliEntrySpec cmd
= CmdEntry {
Expand Down
101 changes: 100 additions & 1 deletion etc/test/System/Etc/Resolver/Cli/PlainTest.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -270,5 +270,104 @@ argument_tests = testGroup
Right _ -> assertFailure "Expecting required argument to fail cli resolving"
]

switch_tests :: TestTree
switch_tests = testGroup
"switch input"
[ testCase "fails if etc/spec.type is not bool" $ do
let input = mconcat
[ "{ \"etc/entries\": {"
, " \"greeting\": {"
, " \"etc/spec\": {"
, " \"default\": false"
, " , \"type\": \"string\""
, " , \"cli\": {"
, " \"input\": \"switch\""
, " , \"long\": \"valid\""
, "}}}}}"
]
(spec :: Either SomeException (SUT.ConfigSpec ())) <- try $ SUT.parseConfigSpec input

case spec of
Left err -> case fromException err of
Just SUT.SpecInvalidSyntaxFound{} -> return ()
_ -> assertFailure ("Expecting type validation to work on cli; got " <> show err)

Right _ -> assertFailure "Expecting type validation to work on cli"
, testGroup
"when etc/spec.default is false"
[ testCase "returns false when flag not given" $ do
let input = mconcat
[ "{ \"etc/entries\": {"
, " \"greeting\": {"
, " \"etc/spec\": {"
, " \"default\": false"
, " , \"type\": \"bool\""
, " , \"cli\": {"
, " \"input\": \"switch\""
, " , \"long\": \"valid\""
, "}}}}}"
]
(spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input

case SUT.resolvePlainCliPure spec "program" [] of
Left err ->
assertFailure ("Expecting default to work on cli; but didn't: " <> show err)

Right config -> do
greeting <- SUT.getConfigValue ["greeting"] config
assertBool "Expecting default to be false, but wasn't" (not greeting)
, testCase "returns true when flag given" $ do
let input = mconcat
[ "{ \"etc/entries\": {"
, " \"greeting\": {"
, " \"etc/spec\": {"
, " \"default\": false"
, " , \"type\": \"bool\""
, " , \"cli\": {"
, " \"input\": \"switch\""
, " , \"long\": \"valid\""
, "}}}}}"
]
(spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input

case SUT.resolvePlainCliPure spec "program" ["--valid"] of
Left err ->
assertFailure ("Expecting default to work on cli; but didn't: " <> show err)

Right config -> do
greeting <- SUT.getConfigValue ["greeting"] config
assertBool "Expecting result to be true, but wasn't" greeting
]
-- TODO: This testcase is failing, and it is because the optparse-applicative
-- API _always_ returns a value, if the flag is not present, it will return
-- false. Once refactoring of parser is done, we need to make use of the
-- default value to change the behavior of the optparse-applicative API to
-- return the appropiate result
-- , testGroup "when default is true"
-- [
-- testCase "entry should use default when not specified (true case)" $ do
-- let input = mconcat
-- [ "{ \"etc/entries\": {"
-- , " \"greeting\": {"
-- , " \"etc/spec\": {"
-- , " \"default\": true"
-- , " , \"type\": \"bool\""
-- , " , \"cli\": {"
-- , " \"input\": \"switch\""
-- , " , \"long\": \"invalid\""
-- , "}}}}}"
-- ]
-- (spec :: SUT.ConfigSpec ()) <- SUT.parseConfigSpec input

-- case SUT.resolvePlainCliPure spec "program" [] of
-- Left err ->
-- assertFailure ("Expecting default to work on cli; but didn't: " <> show err)

-- Right config -> do
-- greeting <- SUT.getConfigValue ["greeting"] config
-- assertBool "Expecting default to be true, but wasn't" greeting
-- ]
]

tests :: TestTree
tests = testGroup "plain" [resolver_tests, option_tests, argument_tests]
tests = testGroup "plain" [resolver_tests, option_tests, argument_tests, switch_tests]
6 changes: 3 additions & 3 deletions etc/test/System/Etc/SpecTest.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -235,7 +235,7 @@ cli_tests =
result = do
value <- getConfigValue keys (specConfigValues config)
let valueType = configValueType value
PlainEntry metadata <- cliEntry (configSources value)
PlainEntry (Opt metadata) <- cliEntry (configSources value)
short <- optShort metadata
return (short, valueType)

Expand All @@ -257,7 +257,7 @@ cli_tests =
result = do
value <- getConfigValue keys (specConfigValues config)
let valueType = configValueType value
PlainEntry metadata <- cliEntry (configSources value)
PlainEntry (Opt metadata) <- cliEntry (configSources value)
long <- optLong metadata
return (long, valueType)

Expand All @@ -279,7 +279,7 @@ cli_tests =
result = do
value <- getConfigValue keys (specConfigValues config)
let valueType = configValueType value
CmdEntry cmd metadata <- cliEntry (configSources value)
CmdEntry cmd (Opt metadata) <- cliEntry (configSources value)
long <- optLong metadata
return (cmd, long, valueType)

Expand Down

0 comments on commit f97e1e5

Please sign in to comment.