Merge pull request #16 from haskell-servant/jkarni/CommonTextTests

Fix Integer FromText instance.

servant.cabal

@@ -89,6 +89,7 @@ test-suite spec
     , bytestring
     , hspec == 2.*
     , QuickCheck
+    , quickcheck-instances
     , parsec
     , servant
     , string-conversions

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

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)

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