Browse Source

move maybeGen to Common

master
Philipp Balzarek 12 years ago
parent
commit
99880c2549
  1. 8
      tests/Tests/Arbitrary/Common.hs
  2. 10
      tests/Tests/Arbitrary/Xmpp.hs

8
tests/Tests/Arbitrary/Common.hs

@ -1,5 +1,6 @@ @@ -1,5 +1,6 @@
module Tests.Arbitrary.Common where
import Control.Applicative ((<$>))
import Data.Char
import qualified Data.Text as Text
import Test.QuickCheck
@ -12,6 +13,11 @@ shrinkTextMaybe :: Maybe Text.Text -> [Maybe Text.Text] @@ -12,6 +13,11 @@ shrinkTextMaybe :: Maybe Text.Text -> [Maybe Text.Text]
shrinkTextMaybe mbtxt = filter (\mb -> mb /= Just (Text.empty)) $ shrink mbtxt
genText1 :: Gen Text.Text
genText1 = Text.pack `fmap` string1
genText1 = Text.pack <$> string1
where
string1 = listOf1 arbitrary `suchThat` (not . all isSpace)
maybeGen :: Gen a -> Gen (Maybe a)
maybeGen g = oneof [ return Nothing
, Just <$> g
]

10
tests/Tests/Arbitrary/Xmpp.hs

@ -26,9 +26,7 @@ instance Arbitrary Jid where @@ -26,9 +26,7 @@ instance Arbitrary Jid where
tryJid = jidFromTexts <$> maybeGen (genString nodeprepProfile)
<*> genString (SP.namePrepProfile False)
<*> maybeGen (genString resourceprepProfile)
maybeGen g = oneof [ return Nothing
, Just <$> g
]
genString profile = Text.pack . take 1024 <$> listOf1 genChar
where
genChar = arbitrary `suchThat` (not . isProhibited)
@ -55,14 +53,12 @@ instance Arbitrary LangTag where @@ -55,14 +53,12 @@ instance Arbitrary LangTag where
shrink (LangTag lt lts) = [LangTag lt' lts | lt' <- shrinkText1 lt] ++
[LangTag lt lts' | lts' <- filter (not . Text.null)
<$> shrink lts]
`
instance Arbitrary StanzaError where
arbitrary = StanzaError <$> arbitrary
<*> arbitrary
<*> oneof [ return Nothing
, Just <$> ((,) <$> arbitrary <*> genText1)
]
<*> maybeGen ((,) <$> arbitrary <*> genText1)
<*> arbitrary
-- Auto-derive trivial instances

Loading…
Cancel
Save