Merge pull request #26 from haskell-servant/wip-allow-bodies-for-links

Fix a HasLink instance, also fix float text handling/tests.
This commit is contained in:
Julian Arni 2015-03-17 09:48:53 +01:00
commit e45beddd35
4 changed files with 18 additions and 7 deletions

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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