diff --git a/servant/servant.cabal b/servant/servant.cabal index 6bf6455a..f717eab3 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -101,7 +101,6 @@ test-suite spec , hspec == 2.* , QuickCheck , quickcheck-instances - , parsec , servant , string-conversions , text diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index b83d1178..b6bf7137 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -180,12 +180,13 @@ type family IsElem endpoint api :: Constraint where IsElem e e = () IsElem e a = IsElem' e a - type family IsSubList a b :: Constraint where IsSubList '[] b = () - IsSubList '[x] (x ': xs) = () - IsSubList '[x] (y ': ys) = IsSubList '[x] ys - IsSubList (x ': xs) y = IsSubList '[x] y `And` IsSubList xs y + IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y + +type family Elem e es :: Constraint where + Elem x (x ': xs) = () + Elem y (x ': xs) = Elem y xs -- Phantom types for Param data Query diff --git a/servant/test/Doctests.hs b/servant/test/Doctests.hs index 4e528dd5..bf6bcd23 100644 --- a/servant/test/Doctests.hs +++ b/servant/test/Doctests.hs @@ -9,13 +9,14 @@ import Test.DocTest main :: IO () main = do files <- find always (extension ==? ".hs") "src" + tfiles <- find always (extension ==? ".hs") "test/Servant" mCabalMacrosFile <- getCabalMacrosFile doctest $ "-isrc" : (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++ "-XOverloadedStrings" : "-XFlexibleInstances" : "-XMultiParamTypeClasses" : - files + (files ++ tfiles) getCabalMacrosFile :: IO (Maybe FilePath) getCabalMacrosFile = do diff --git a/servant/test/Servant/Utils/LinksSpec.hs b/servant/test/Servant/Utils/LinksSpec.hs index c25cccb9..07e0b068 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/servant/test/Servant/Utils/LinksSpec.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} - +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} module Servant.Utils.LinksSpec where -import Test.Hspec ( Spec, it, describe, shouldBe, Expectation ) -import Data.Proxy ( Proxy(..) ) +import Data.Proxy (Proxy (..)) +import Test.Hspec (Expectation, Spec, describe, it, + shouldBe) -import Servant.API +import Servant.API type TestApi = -- Capture and query params @@ -24,18 +24,6 @@ type TestApi = :<|> "delete" :> Header "ponies" String :> Delete '[JSON] () :<|> "raw" :> Raw -type TestLink = "hello" :> "hi" :> Get '[JSON] Bool -type TestLink2 = "greet" :> ReqBody '[JSON] [Int] :> Post '[PlainText] Bool -type TestLink3 = "parent" :> "child" :> Get '[JSON] String - -type BadTestLink = "hallo" :> "hi" :> Get '[JSON] Bool -type BadTestLink2 = "greet" :> Get '[PlainText] Bool - -type BadTestLink' = "hello" :> "hi" :> Get '[OctetStream] Bool -type BadTestLink'2 = "greet" :> Get '[OctetStream] Bool - -type NotALink = "hello" :> Capture "x" Bool :> Get '[JSON] Bool -type NotALink2 = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool apiLink :: (IsElem endpoint TestApi, HasLink endpoint) => Proxy endpoint -> MkLink endpoint @@ -49,7 +37,7 @@ shouldBeURI link expected = spec :: Spec spec = describe "Servant.Utils.Links" $ do - it "Generates correct links for capture query params" $ do + it "generates correct links for capture query params" $ do let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] ()) apiLink l1 "hi" `shouldBeURI` "hello/hi" @@ -59,15 +47,55 @@ spec = describe "Servant.Utils.Links" $ do apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true" - it "Generates correct links for query flags" $ do + it "generates correct links for query flags" $ do let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] ()) apiLink l1 True True `shouldBeURI` "balls?bouncy&fast" apiLink l1 False True `shouldBeURI` "balls?fast" - it "Generates correct links for all of the verbs" $ do + it "generates correct links for all of the verbs" $ do apiLink (Proxy :: Proxy ("get" :> Get '[JSON] ())) `shouldBeURI` "get" apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put" apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post" apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] ())) `shouldBeURI` "delete" apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw" + + +-- | +-- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed, +-- we'll just use doctest +-- +-- >>> apiLink (Proxy :: Proxy WrongPath) +-- ... +-- Could not deduce ... +-- ... +-- +-- >>> apiLink (Proxy :: Proxy WrongReturnType) +-- ... +-- Could not deduce ... +-- ... +-- +-- >>> apiLink (Proxy :: Proxy WrongContentType) +-- ... +-- Could not deduce ... +-- ... +-- +-- >>> apiLink (Proxy :: Proxy WrongMethod) +-- ... +-- Could not deduce ... +-- ... +-- +-- >>> apiLink (Proxy :: Proxy NotALink) +-- ... +-- Could not deduce ... +-- ... +-- +-- sanity check +-- >>> apiLink (Proxy :: Proxy AllGood) +-- get +type WrongPath = "getTypo" :> Get '[JSON] () +type WrongReturnType = "get" :> Get '[JSON] Bool +type WrongContentType = "get" :> Get '[OctetStream] () +type WrongMethod = "get" :> Post '[JSON] () +type NotALink = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool +type AllGood = "get" :> Get '[JSON] ()