diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 71f6aa0dfa..8e496db145 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -323,6 +323,7 @@ test-suite cardano-cli-test filepath, hedgehog, hedgehog-extras ^>=0.6.1.0, + parsec, regex-tdfa, tasty, tasty-hedgehog, @@ -340,6 +341,7 @@ test-suite cardano-cli-test Test.Cli.ITN Test.Cli.Json Test.Cli.MonadWarning + Test.Cli.Parser Test.Cli.Pioneers.Exercise1 Test.Cli.Pioneers.Exercise2 Test.Cli.Pioneers.Exercise3 diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs index 062df16d70..112cc58ffc 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs @@ -4,6 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- HLINT ignore "Move brackets to avoid $" -} {- HLINT ignore "Use <$>" -} @@ -25,12 +26,14 @@ import Cardano.CLI.Types.Key import Cardano.CLI.Types.Key.VerificationKey import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as Consensus -import Control.Monad (mfilter) +import Control.Monad (mfilter, void) import qualified Data.Aeson as Aeson import Data.Bifunctor +import Data.Bits (Bits, toIntegralSized) import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as BSC +import Data.Data (Proxy (..), Typeable, typeRep) import Data.Foldable import Data.Functor (($>)) import qualified Data.IP as IP @@ -1149,7 +1152,7 @@ pPollAnswer = pPollAnswerIndex :: Parser Word pPollAnswerIndex = - Opt.option auto $ + Opt.option integralReader $ mconcat [ Opt.long "answer" , Opt.metavar "INT" @@ -1179,7 +1182,7 @@ pPollTxFile = pPollNonce :: Parser Word pPollNonce = - Opt.option auto $ + Opt.option integralReader $ mconcat [ Opt.long "nonce" , Opt.metavar "UINT" @@ -1235,7 +1238,7 @@ pScriptWitnessFiles sbe witctx autoBalanceExecUnits scriptFlagPrefix scriptFlagP pExecutionUnits :: String -> Parser ExecutionUnits pExecutionUnits scriptFlagPrefix = fmap (uncurry ExecutionUnits) $ - Opt.option Opt.auto $ + Opt.option pairIntegralReader $ mconcat [ Opt.long (scriptFlagPrefix ++ "-execution-units") , Opt.metavar "(INT, INT)" @@ -2324,7 +2327,7 @@ pTotalCollateral = pWitnessOverride :: Parser Word pWitnessOverride = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "witness-override" , Opt.metavar "WORD" @@ -2333,7 +2336,7 @@ pWitnessOverride = pNumberOfShelleyKeyWitnesses :: Parser Int pNumberOfShelleyKeyWitnesses = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "shelley-key-witnesses" , Opt.metavar "INT" @@ -2342,7 +2345,7 @@ pNumberOfShelleyKeyWitnesses = pNumberOfByronKeyWitnesses :: Parser Int pNumberOfByronKeyWitnesses = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "byron-key-witnesses" , Opt.metavar "Int" @@ -2606,7 +2609,7 @@ pInvalidHereafter eon = pTxFee :: Parser Lovelace pTxFee = fmap (L.Coin . (fromIntegral :: Natural -> Integer)) $ - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "fee" , Opt.metavar "LOVELACE" @@ -2692,7 +2695,7 @@ pInputTxOrTxBodyFile = pTxInCountDeprecated :: Parser TxInCount pTxInCountDeprecated = fmap TxInCount $ - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "tx-in-count" , Opt.metavar "NATURAL" @@ -2702,7 +2705,7 @@ pTxInCountDeprecated = pTxOutCountDeprecated :: Parser TxOutCount pTxOutCountDeprecated = fmap TxOutCount $ - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "tx-out-count" , Opt.metavar "NATURAL" @@ -2712,7 +2715,7 @@ pTxOutCountDeprecated = pTxShelleyWitnessCount :: Parser TxShelleyWitnessCount pTxShelleyWitnessCount = fmap TxShelleyWitnessCount $ - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "witness-count" , Opt.metavar "NATURAL" @@ -2722,7 +2725,7 @@ pTxShelleyWitnessCount = pTxByronWitnessCount :: Parser TxByronWitnessCount pTxByronWitnessCount = fmap TxByronWitnessCount $ - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "byron-witness-count" , Opt.metavar "NATURAL" @@ -3164,7 +3167,7 @@ pMinPoolCost = pMaxBodySize :: Parser Word32 pMaxBodySize = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "max-block-body-size" , Opt.metavar "WORD32" @@ -3173,16 +3176,51 @@ pMaxBodySize = pMaxTransactionSize :: Parser Word32 pMaxTransactionSize = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "max-tx-size" , Opt.metavar "WORD32" , Opt.help "Maximum transaction size." ] +-- | A parser for @(Int, Int)@-like expressions. In other words, 'integralReader'-lifted +-- to a pairs with a Haskell-like syntax. +pairIntegralReader :: (Typeable a, Integral a, Bits a) => ReadM (a, a) +pairIntegralReader = readerFromParsecParser pairIntegralParsecParser + +pairIntegralParsecParser :: (Typeable a, Integral a, Bits a) => Parsec.Parser (a, a) +pairIntegralParsecParser = do + Parsec.spaces -- Skip initial spaces + void $ Parsec.char '(' + Parsec.spaces -- Skip spaces between opening paren and lhs + lhs :: a <- integralParsecParser + Parsec.spaces -- Skip spaces between lhs and comma + void $ Parsec.char ',' + Parsec.spaces -- Skip spaces between comma and rhs + rhs :: a <- integralParsecParser + Parsec.spaces -- Skip spaces between comma and closing paren + void $ Parsec.char ')' + Parsec.spaces -- Skip trailing spaces + return (lhs, rhs) + +-- | @integralReader@ is a reader for a word of type @a@. When it fails +-- parsing, it provides a nice error message. This custom reader is needed +-- to avoid the overflow issues of 'Opt.auto' described in https://github.com/IntersectMBO/cardano-cli/issues/860. +integralReader :: (Typeable a, Integral a, Bits a) => ReadM a +integralReader = readerFromParsecParser integralParsecParser + +integralParsecParser :: forall a. (Typeable a, Integral a, Bits a) => Parsec.Parser a +integralParsecParser = do + i <- decimal + case toIntegralSized i of + Nothing -> fail $ "Cannot parse " <> show i <> " as a " <> typeName + Just n -> return n + where + typeName = show $ typeRep (Proxy @a) + pMaxBlockHeaderSize :: Parser Word16 pMaxBlockHeaderSize = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "max-block-header-size" , Opt.metavar "WORD16" @@ -3235,7 +3273,7 @@ pEpochBoundRetirement = pNumberOfPools :: Parser Natural pNumberOfPools = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "number-of-pools" , Opt.metavar "NATURAL" @@ -3345,7 +3383,7 @@ pMaxTxExecutionUnits :: Parser ExecutionUnits pMaxTxExecutionUnits = uncurry ExecutionUnits <$> Opt.option - Opt.auto + pairIntegralReader ( mconcat [ Opt.long "max-tx-execution-units" , Opt.metavar "(INT, INT)" @@ -3361,7 +3399,7 @@ pMaxBlockExecutionUnits :: Parser ExecutionUnits pMaxBlockExecutionUnits = uncurry ExecutionUnits <$> Opt.option - Opt.auto + pairIntegralReader ( mconcat [ Opt.long "max-block-execution-units" , Opt.metavar "(INT, INT)" @@ -3375,7 +3413,7 @@ pMaxBlockExecutionUnits = pMaxValueSize :: Parser Natural pMaxValueSize = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "max-value-size" , Opt.metavar "INT" @@ -3387,7 +3425,7 @@ pMaxValueSize = pCollateralPercent :: Parser Natural pCollateralPercent = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "collateral-percent" , Opt.metavar "INT" @@ -3401,7 +3439,7 @@ pCollateralPercent = pMaxCollateralInputs :: Parser Natural pMaxCollateralInputs = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "max-collateral-inputs" , Opt.metavar "INT" @@ -3417,7 +3455,7 @@ pProtocolVersion = (,) <$> pProtocolMajorVersion <*> pProtocolMinorVersion where pProtocolMajorVersion = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "protocol-major-version" , Opt.metavar "MAJOR" @@ -3428,7 +3466,7 @@ pProtocolVersion = ] ] pProtocolMinorVersion = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "protocol-minor-version" , Opt.metavar "MINOR" @@ -3579,7 +3617,7 @@ pDRepVotingThresholds = pMinCommitteeSize :: Parser Natural pMinCommitteeSize = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "min-committee-size" , Opt.metavar "INT" @@ -3908,7 +3946,7 @@ pGovernanceActionId = pWord16 :: String -> String -> Parser Word16 pWord16 l h = - Opt.option auto $ + Opt.option integralReader $ mconcat [ Opt.long l , Opt.metavar "WORD16" @@ -3949,7 +3987,7 @@ pNetworkIdForTestnetData envCli = pReferenceScriptSize :: Parser ReferenceScriptSize pReferenceScriptSize = fmap ReferenceScriptSize $ - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "reference-script-size" , Opt.metavar "NATURAL" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Genesis.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Genesis.hs index 87fa312377..fbcd5774e8 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Genesis.hs @@ -249,7 +249,7 @@ pGenesisCreateTestNetData sbe envCli = "The " <> eraStr <> " specification file to use as input. A default one is generated if omitted." ] pNumGenesisKeys = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "genesis-keys" , Opt.metavar "INT" @@ -258,7 +258,7 @@ pGenesisCreateTestNetData sbe envCli = ] pNumPools :: Parser Word pNumPools = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "pools" , Opt.metavar "INT" @@ -274,7 +274,7 @@ pGenesisCreateTestNetData sbe envCli = pDReps mode modeOptionName modeExplanation = DRepCredentials mode <$> Opt.option - Opt.auto + integralReader ( mconcat [ Opt.long modeOptionName , Opt.help $ "The number of DRep credentials to make (default is 0). " <> modeExplanation @@ -291,7 +291,7 @@ pGenesisCreateTestNetData sbe envCli = pStakeDelegators mode modeOptionName modeExplanation = StakeDelegators mode <$> Opt.option - Opt.auto + integralReader ( mconcat [ Opt.long modeOptionName , Opt.help $ @@ -302,7 +302,7 @@ pGenesisCreateTestNetData sbe envCli = ) pNumStuffedUtxoCount :: Parser Word pNumStuffedUtxoCount = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "stuffed-utxo" , Opt.metavar "INT" @@ -311,7 +311,7 @@ pGenesisCreateTestNetData sbe envCli = ] pNumUtxoKeys :: Parser Word pNumUtxoKeys = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "utxo-keys" , Opt.metavar "INT" @@ -322,7 +322,7 @@ pGenesisCreateTestNetData sbe envCli = pSupply = Opt.optional $ fmap Coin $ - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "total-supply" , Opt.metavar "LOVELACE" @@ -337,7 +337,7 @@ pGenesisCreateTestNetData sbe envCli = pSupplyDelegated = Opt.optional $ fmap Coin $ - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "delegated-supply" , Opt.metavar "LOVELACE" @@ -394,7 +394,7 @@ pMaybeSystemStart = pGenesisNumGenesisKeys :: Parser Word pGenesisNumGenesisKeys = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "gen-genesis-keys" , Opt.metavar "INT" @@ -407,7 +407,7 @@ pNodeConfigTemplate = optional $ parseFilePath "node-config-template" "the node pGenesisNumUTxOKeys :: Parser Word pGenesisNumUTxOKeys = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "gen-utxo-keys" , Opt.metavar "INT" @@ -417,7 +417,7 @@ pGenesisNumUTxOKeys = pGenesisNumPools :: Parser Word pGenesisNumPools = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "gen-pools" , Opt.metavar "INT" @@ -427,7 +427,7 @@ pGenesisNumPools = pGenesisNumStDelegs :: Parser Word pGenesisNumStDelegs = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "gen-stake-delegs" , Opt.metavar "INT" @@ -437,7 +437,7 @@ pGenesisNumStDelegs = pStuffedUtxoCount :: Parser Word pStuffedUtxoCount = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "num-stuffed-utxo" , Opt.metavar "INT" @@ -449,7 +449,7 @@ pInitialSupplyNonDelegated :: Parser (Maybe Coin) pInitialSupplyNonDelegated = Opt.optional $ fmap Coin $ - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "supply" , Opt.metavar "LOVELACE" @@ -461,7 +461,7 @@ pInitialSupplyDelegated :: Parser Coin pInitialSupplyDelegated = fmap (Coin . fromMaybe 0) $ Opt.optional $ - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "supply-delegated" , Opt.metavar "LOVELACE" @@ -472,7 +472,7 @@ pInitialSupplyDelegated = pSecurityParam :: Parser Word64 pSecurityParam = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "security-param" , Opt.metavar "INT" @@ -482,7 +482,7 @@ pSecurityParam = pSlotLength :: Parser Word pSlotLength = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "slot-length" , Opt.metavar "INT" @@ -502,7 +502,7 @@ pSlotCoefficient = pBulkPoolCredFiles :: Parser Word pBulkPoolCredFiles = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "bulk-pool-cred-files" , Opt.metavar "INT" @@ -512,7 +512,7 @@ pBulkPoolCredFiles = pBulkPoolsPerFile :: Parser Word pBulkPoolsPerFile = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "bulk-pools-per-file" , Opt.metavar "INT" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Node.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Node.hs index 26d87265fd..ceaf247a20 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Node.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Node.hs @@ -115,7 +115,7 @@ pNewCounter = pCounterValue :: Parser Word pCounterValue = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "counter-value" , Opt.metavar "INT" diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Options.hs b/cardano-cli/src/Cardano/CLI/Legacy/Options.hs index a9097f7101..ea154c4be1 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Options.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Options.hs @@ -564,7 +564,7 @@ pNodeCmds = pCounterValue :: Parser Word pCounterValue = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "counter-value" , Opt.metavar "INT" @@ -1135,7 +1135,7 @@ pGenesisCmds envCli = pGenesisNumGenesisKeys :: Parser Word pGenesisNumGenesisKeys = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "gen-genesis-keys" , Opt.metavar "INT" @@ -1148,7 +1148,7 @@ pGenesisCmds envCli = pGenesisNumUTxOKeys :: Parser Word pGenesisNumUTxOKeys = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "gen-utxo-keys" , Opt.metavar "INT" @@ -1158,7 +1158,7 @@ pGenesisCmds envCli = pGenesisNumPools :: Parser Word pGenesisNumPools = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "gen-pools" , Opt.metavar "INT" @@ -1168,7 +1168,7 @@ pGenesisCmds envCli = pGenesisNumStDelegs :: Parser Word pGenesisNumStDelegs = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "gen-stake-delegs" , Opt.metavar "INT" @@ -1178,7 +1178,7 @@ pGenesisCmds envCli = pStuffedUtxoCount :: Parser Word pStuffedUtxoCount = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "num-stuffed-utxo" , Opt.metavar "INT" @@ -1200,7 +1200,7 @@ pGenesisCmds envCli = pInitialSupplyNonDelegated = Opt.optional $ fmap Coin $ - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "supply" , Opt.metavar "LOVELACE" @@ -1212,7 +1212,7 @@ pGenesisCmds envCli = pInitialSupplyDelegated = fmap (Coin . fromMaybe 0) $ Opt.optional $ - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "supply-delegated" , Opt.metavar "LOVELACE" @@ -1223,7 +1223,7 @@ pGenesisCmds envCli = pSecurityParam :: Parser Word64 pSecurityParam = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "security-param" , Opt.metavar "INT" @@ -1233,7 +1233,7 @@ pGenesisCmds envCli = pSlotLength :: Parser Word pSlotLength = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "slot-length" , Opt.metavar "INT" @@ -1253,7 +1253,7 @@ pGenesisCmds envCli = pBulkPoolCredFiles :: Parser Word pBulkPoolCredFiles = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "bulk-pool-cred-files" , Opt.metavar "INT" @@ -1263,7 +1263,7 @@ pGenesisCmds envCli = pBulkPoolsPerFile :: Parser Word pBulkPoolsPerFile = - Opt.option Opt.auto $ + Opt.option integralReader $ mconcat [ Opt.long "bulk-pools-per-file" , Opt.metavar "INT" diff --git a/cardano-cli/src/Cardano/CLI/Options/Ping.hs b/cardano-cli/src/Cardano/CLI/Options/Ping.hs index 55ff5ef1a4..f07570b136 100644 --- a/cardano-cli/src/Cardano/CLI/Options/Ping.hs +++ b/cardano-cli/src/Cardano/CLI/Options/Ping.hs @@ -8,6 +8,7 @@ module Cardano.CLI.Options.Ping where import Cardano.CLI.Commands.Ping +import Cardano.CLI.EraBased.Options.Common (integralReader) import qualified Cardano.Network.Ping as CNP import Control.Applicative ((<|>)) @@ -55,7 +56,7 @@ pEndPoint = fmap HostEndPoint pHost <|> fmap UnixSockEndPoint pUnixSocket pPing :: Opt.Parser PingCmd pPing = PingCmd - <$> ( Opt.option Opt.auto $ + <$> ( Opt.option integralReader $ mconcat [ Opt.long "count" , Opt.short 'c' @@ -78,7 +79,7 @@ pPing = , Opt.value "3001" ] ) - <*> ( Opt.option Opt.auto $ + <*> ( Opt.option integralReader $ mconcat [ Opt.long "magic" , Opt.short 'm' diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Parser.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Parser.hs new file mode 100644 index 0000000000..d95769aaae --- /dev/null +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Parser.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cli.Parser + ( hprop_integral_reader + , hprop_integral_pair_reader_positive + , hprop_integral_pair_reader_negative + ) +where + +import Cardano.CLI.EraBased.Options.Common (integralParsecParser, + pairIntegralParsecParser) + +import Data.Bits (Bits) +import Data.Data (Proxy (..), Typeable) +import Data.Either (isLeft, isRight) +import Data.Word (Word16) +import qualified Text.Parsec as Parsec + +import Hedgehog (Gen, Property, assert, property, (===)) +import Hedgehog.Extras (assertWith, propertyOnce) +import qualified Hedgehog.Gen as Gen +import Hedgehog.Internal.Property (forAll) +import qualified Hedgehog.Range as Gen +import qualified Hedgehog.Range as Range + +-- | Execute me with: +-- @cabal test cardano-cli-test --test-options '-p "/integral reader/"'@ +hprop_integral_reader :: Property +hprop_integral_reader = property $ do + parse @Word "0" === Right 0 + parse @Word "42" === Right 42 + assertWith (parse @Word "-1") isLeft + assertWith (parse @Word "18446744073709551616") isLeft + assertWith (parse @Word "-1987090") isLeft + + w <- forAll $ Gen.word $ Gen.linear minBound maxBound + parse @Word (show w) === Right w + + parse @Word16 "0" === Right 0 + parse @Word16 "42" === Right 42 + assertWith (parse @Word16 "-1") isLeft + assertWith (parse @Word16 "65536") isLeft + assertWith (parse @Word16 "298709870987") isLeft + assertWith (parse @Word16 "-1987090") isLeft + where + parse :: (Typeable a, Integral a, Bits a) => String -> Either String a + parse s = + case Parsec.runParser integralParsecParser () "" s of + Left parsecError -> Left $ show parsecError + Right x -> Right x + +-- | Execute me with: +-- @cabal test cardano-cli-test --test-options '-p "/integral pair reader positive/"'@ +hprop_integral_pair_reader_positive :: Property +hprop_integral_pair_reader_positive = property $ do + validArbitraryTuple <- forAll $ genNumberTuple (Proxy :: Proxy Word) + assert $ isRight $ parse @Word validArbitraryTuple + where + parse :: (Typeable a, Integral a, Bits a) => String -> Either String (a, a) + parse s = + case Parsec.runParser pairIntegralParsecParser () "" s of + Left parsecError -> Left $ show parsecError + Right x -> Right x + +genNumberTuple :: forall a. Integral a => Show a => Proxy a -> Gen String +genNumberTuple _ = do + x :: a <- Gen.integral (Range.linear 0 100) + y :: a <- Gen.integral (Range.linear 0 100) + space0 <- genArbitrarySpace + space1 <- genArbitrarySpace + space2 <- genArbitrarySpace + space3 <- genArbitrarySpace + return $ + space0 ++ "(" ++ space2 ++ show x ++ space1 ++ "," ++ space2 ++ show y ++ space1 ++ ")" ++ space3 + +genArbitrarySpace :: Gen String +genArbitrarySpace = Gen.string (Range.linear 0 5) (return ' ') + +-- | Execute me with: +-- @cabal test cardano-cli-test --test-options '-p "/integral pair reader negative/"'@ +hprop_integral_pair_reader_negative :: Property +hprop_integral_pair_reader_negative = propertyOnce $ do + assertWith (parse @Word "(0, 0, 0)") isLeft + assertWith (parse @Word "(-1, 0)") isLeft + assertWith (parse @Word "(18446744073709551616, 0)") isLeft + assertWith (parse @Word "(0, 18446744073709551616)") isLeft + assertWith (parse @Word "(0, -1)") isLeft + assertWith (parse @Word "0, 0)") isLeft + assertWith (parse @Word "(0, 0") isLeft + assertWith (parse @Word "(0 0)") isLeft + assertWith (parse @Word "( 0, 0") isLeft + where + parse :: (Typeable a, Integral a, Bits a) => String -> Either String (a, a) + parse s = + case Parsec.runParser pairIntegralParsecParser () "" s of + Left parsecError -> Left $ show parsecError + Right x -> Right x