diff --git a/src/Servant/Common/Text.hs b/src/Servant/Common/Text.hs index cc8cb15d..0d2697d4 100644 --- a/src/Servant/Common/Text.hs +++ b/src/Servant/Common/Text.hs @@ -11,6 +11,7 @@ import Data.String.Conversions (cs) import Data.Text (Text) import Data.Text.Read (Reader, decimal, rational, signed) import Data.Word (Word, Word16, Word32, Word64, Word8) +import GHC.Float (double2Float) -- | For getting values from url captures and query string parameters -- Instances should obey: @@ -130,7 +131,9 @@ instance ToText Double where toText = cs . show instance FromText Float where - fromText = runReader rational + -- Double is more practically accurate due to weird rounding when using + -- rational. We convert to double and then convert to Float. + fromText = fmap double2Float . runReader rational instance ToText Float where toText = cs . show diff --git a/src/Servant/Utils/Links.hs b/src/Servant/Utils/Links.hs index 22275afb..be79d1cc 100644 --- a/src/Servant/Utils/Links.hs +++ b/src/Servant/Utils/Links.hs @@ -159,7 +159,7 @@ type family IsElem' a s :: Constraint type family IsElem endpoint api :: Constraint where IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb) IsElem (e :> sa) (e :> sb) = IsElem sa sb - IsElem sa (Header x :> sb) = IsElem sa sb + IsElem sa (Header x :> sb) = IsElem sa sb IsElem sa (ReqBody y x :> sb) = IsElem sa sb IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb IsElem sa (QueryParam x y :> sb) = IsElem sa sb @@ -320,8 +320,8 @@ instance (KnownSymbol sym, HasLink sub) k = symbolVal (Proxy :: Proxy sym) -- Misc instances -instance HasLink sub => HasLink (ReqBody a :> sub) where - type MkLink (ReqBody a :> sub) = MkLink sub +instance HasLink sub => HasLink (ReqBody ct a :> sub) where + type MkLink (ReqBody ct a :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) instance (ToText v, HasLink sub) diff --git a/test/Servant/Common/TextSpec.hs b/test/Servant/Common/TextSpec.hs index d5c98b1f..0f0ece51 100644 --- a/test/Servant/Common/TextSpec.hs +++ b/test/Servant/Common/TextSpec.hs @@ -55,11 +55,19 @@ spec = describe "Servant.Common.Text" $ do it "holds for Integer" $ property $ \x -> textLaw (x :: Integer) + -- The following two properties are only reasonably expected to hold up + -- to a certain precision. + -- + -- http://en.wikipedia.org/wiki/Floating_point#Internal_representation it "holds for Double" $ - property $ \x -> textLaw (x :: Double) + property $ \x -> + x < 1.0e15 && x > 1.0e-16 ==> + textLaw (x :: Double) it "holds for Float" $ - property $ \x -> textLaw (x :: Float) + property $ \x -> + x < 1.0e7 && x > 1.0e-7 ==> + textLaw (x :: Float) textLaw :: (FromText a, ToText a, Eq a) => a -> Bool textLaw a = fromText (toText a) == Just a diff --git a/test/Servant/Utils/LinksSpec.hs b/test/Servant/Utils/LinksSpec.hs index 49f4a5c5..ca017be6 100644 --- a/test/Servant/Utils/LinksSpec.hs +++ b/test/Servant/Utils/LinksSpec.hs @@ -29,7 +29,7 @@ type TestApi = :<|> "raw" :> Raw type TestLink = "hello" :> "hi" :> Get '[JSON] Bool -type TestLink2 = "greet" :> Post '[PlainText] Bool +type TestLink2 = "greet" :> ReqBody '[JSON] [Int] :> Post '[PlainText] Bool type TestLink3 = "parent" :> "child" :> Get '[JSON] String type BadTestLink = "hallo" :> "hi" :> Get '[JSON] Bool