diff --git a/servant.cabal b/servant.cabal index 19092f45..f52ca766 100644 --- a/servant.cabal +++ b/servant.cabal @@ -89,6 +89,7 @@ test-suite spec , bytestring , hspec == 2.* , QuickCheck + , quickcheck-instances , parsec , servant , string-conversions diff --git a/src/Servant/Common/Text.hs b/src/Servant/Common/Text.hs index 5ba1fa94..4df9f6f5 100644 --- a/src/Servant/Common/Text.hs +++ b/src/Servant/Common/Text.hs @@ -13,10 +13,14 @@ import Data.Text.Read ( rational, signed, decimal, Reader ) import Data.Word ( Word, Word8, Word16, Word32, Word64 ) -- | For getting values from url captures and query string parameters +-- Instances should obey: +-- > fromText (toText a) == Just a class FromText a where fromText :: Text -> Maybe a -- | For putting values in paths and query string parameters +-- Instances should obey: +-- > fromText (toText a) == Just a class ToText a where toText :: a -> Text @@ -109,7 +113,7 @@ instance ToText Word64 where toText = cs . show instance FromText Integer where - fromText = runReader decimal + fromText = runReader (signed decimal) instance ToText Integer where toText = cs . show diff --git a/test/Servant/API/ContentTypesSpec.hs b/test/Servant/API/ContentTypesSpec.hs index d02203e6..b2133ff7 100644 --- a/test/Servant/API/ContentTypesSpec.hs +++ b/test/Servant/API/ContentTypesSpec.hs @@ -21,6 +21,7 @@ import qualified Data.Text.Lazy as TextL import GHC.Generics import Test.Hspec import Test.QuickCheck +import Test.QuickCheck.Instances () import Servant.API.ContentTypes @@ -145,12 +146,6 @@ instance ToJSON SomeData instance Arbitrary SomeData where arbitrary = SomeData <$> arbitrary <*> arbitrary -instance Arbitrary TextL.Text where - arbitrary = TextL.pack <$> arbitrary - -instance Arbitrary TextS.Text where - arbitrary = TextS.pack <$> arbitrary - instance Arbitrary ZeroToOne where arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]] @@ -169,12 +164,6 @@ instance ToJSON ByteString where instance IsString AcceptHeader where fromString = AcceptHeader . fromString -instance Arbitrary BSL.ByteString where - arbitrary = cs <$> (arbitrary :: Gen String) - -instance Arbitrary ByteString where - arbitrary = cs <$> (arbitrary :: Gen String) - addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h) where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f) diff --git a/test/Servant/Common/TextSpec.hs b/test/Servant/Common/TextSpec.hs new file mode 100644 index 00000000..ec8e2c5a --- /dev/null +++ b/test/Servant/Common/TextSpec.hs @@ -0,0 +1,65 @@ +module Servant.Common.TextSpec where + +import Servant.Common.Text +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Data.Int ( Int8, Int16, Int32, Int64 ) +import Data.Text ( Text ) +import Data.Word ( Word, Word8, Word16, Word32, Word64 ) + +spec :: Spec +spec = describe "Servant.Common.Text" $ do + + context "FromText and ToText laws" $ do + + it "holds for Text" $ + property $ \x -> textLaw (x :: Text) + + it "holds for String" $ + property $ \x -> textLaw (x :: String) + + it "holds for Bool" $ + property $ \x -> textLaw (x :: Bool) + + it "holds for Int" $ + property $ \x -> textLaw (x :: Int) + + it "holds for Int8" $ + property $ \x -> textLaw (x :: Int8) + + it "holds for Int16" $ + property $ \x -> textLaw (x :: Int16) + + it "holds for Int32" $ + property $ \x -> textLaw (x :: Int32) + + it "holds for Int64" $ + property $ \x -> textLaw (x :: Int64) + + it "holds for Word" $ + property $ \x -> textLaw (x :: Word) + + it "holds for Word8" $ + property $ \x -> textLaw (x :: Word8) + + it "holds for Word16" $ + property $ \x -> textLaw (x :: Word16) + + it "holds for Word32" $ + property $ \x -> textLaw (x :: Word32) + + it "holds for Word64" $ + property $ \x -> textLaw (x :: Word64) + + it "holds for Integer" $ + property $ \x -> textLaw (x :: Integer) + + it "holds for Double" $ + property $ \x -> textLaw (x :: Double) + + it "holds for Float" $ + property $ \x -> textLaw (x :: Float) + +textLaw :: (FromText a, ToText a, Eq a) => a -> Bool +textLaw a = fromText (toText a) == Just a