git.iko.soy/typeable/servant
on master help sign in
Merge pull request #295 from haskell-servant/jkarni/293fix

Fix loop in IsSubList

commit1bb4292d971be498456d7eece6cb7bc078bb734f authorJulian Arni <jkarni@gmail.com> dateWed 16 Dec 2015, 14:11 (11 years ago) parent3429870b20edfd
4 files changed+57−28
compare with master
unifiedsplit
servant/servant.cabal−1 servant/src/Servant/Utils/Links.hs+5−4 servant/test/Doctests.hs+2−1 servant/test/Servant/Utils/LinksSpec.hs+50−22
servant/servant.cabal−1
@@ -101,7 +101,6 @@ test-suite spec
101101 , hspec == 2.*
102102 , QuickCheck
103103 , quickcheck-instances
104− , parsec
105104 , servant
106105 , string-conversions
107106 , text
servant/src/Servant/Utils/Links.hs+5−4
@@ -180,12 +180,13 @@ type family IsElem endpoint api :: Constraint where
180180 IsElem e e = ()
181181 IsElem e a = IsElem' e a
182182
183−
184183type family IsSubList a b :: Constraint where
185184 IsSubList '[] b = ()
186− IsSubList '[x] (x ': xs) = ()
187− IsSubList '[x] (y ': ys) = IsSubList '[x] ys
188− IsSubList (x ': xs) y = IsSubList '[x] y `And` IsSubList xs y
185+ IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y
186+
187+type family Elem e es :: Constraint where
188+ Elem x (x ': xs) = ()
189+ Elem y (x ': xs) = Elem y xs
189190
190191-- Phantom types for Param
191192data Query
servant/test/Doctests.hs+2−1
@@ -9,13 +9,14 @@ import Test.DocTest
99main :: IO ()
1010main = do
1111 files <- find always (extension ==? ".hs") "src"
12+ tfiles <- find always (extension ==? ".hs") "test/Servant"
1213 mCabalMacrosFile <- getCabalMacrosFile
1314 doctest $ "-isrc" :
1415 (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++
1516 "-XOverloadedStrings" :
1617 "-XFlexibleInstances" :
1718 "-XMultiParamTypeClasses" :
18− files
19+ (files ++ tfiles)
1920
2021getCabalMacrosFile :: IO (Maybe FilePath)
2122getCabalMacrosFile = do
servant/test/Servant/Utils/LinksSpec.hs+50−22
@@ -1,14 +1,14 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE PolyKinds #-}
3−{-# LANGUAGE TypeOperators #-}
41{-# LANGUAGE ConstraintKinds #-}
5−
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE TypeOperators #-}
65module Servant.Utils.LinksSpec where
76
8−import Test.Hspec ( Spec, it, describe, shouldBe, Expectation )
9−import Data.Proxy ( Proxy(..) )
7+import Data.Proxy (Proxy (..))
8+import Test.Hspec (Expectation, Spec, describe, it,
9+ shouldBe)
1010
11−import Servant.API
11+import Servant.API
1212
1313type TestApi =
1414 -- Capture and query params
@@ -24,18 +24,6 @@ type TestApi =
2424 :<|> "delete" :> Header "ponies" String :> Delete '[JSON] ()
2525 :<|> "raw" :> Raw
2626
27−type TestLink = "hello" :> "hi" :> Get '[JSON] Bool
28−type TestLink2 = "greet" :> ReqBody '[JSON] [Int] :> Post '[PlainText] Bool
29−type TestLink3 = "parent" :> "child" :> Get '[JSON] String
30−
31−type BadTestLink = "hallo" :> "hi" :> Get '[JSON] Bool
32−type BadTestLink2 = "greet" :> Get '[PlainText] Bool
33−
34−type BadTestLink' = "hello" :> "hi" :> Get '[OctetStream] Bool
35−type BadTestLink'2 = "greet" :> Get '[OctetStream] Bool
36−
37−type NotALink = "hello" :> Capture "x" Bool :> Get '[JSON] Bool
38−type NotALink2 = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool
3927
4028apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
4129 => Proxy endpoint -> MkLink endpoint
@@ -49,7 +37,7 @@ shouldBeURI link expected =
4937
5038spec :: Spec
5139spec = describe "Servant.Utils.Links" $ do
52− it "Generates correct links for capture query params" $ do
40+ it "generates correct links for capture query params" $ do
5341 let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] ())
5442 apiLink l1 "hi" `shouldBeURI` "hello/hi"
5543
@@ -59,15 +47,55 @@ spec = describe "Servant.Utils.Links" $ do
5947 apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true"
6048
6149
62− it "Generates correct links for query flags" $ do
50+ it "generates correct links for query flags" $ do
6351 let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"
6452 :> QueryFlag "fast" :> Delete '[JSON] ())
6553 apiLink l1 True True `shouldBeURI` "balls?bouncy&fast"
6654 apiLink l1 False True `shouldBeURI` "balls?fast"
6755
68− it "Generates correct links for all of the verbs" $ do
56+ it "generates correct links for all of the verbs" $ do
6957 apiLink (Proxy :: Proxy ("get" :> Get '[JSON] ())) `shouldBeURI` "get"
7058 apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put"
7159 apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post"
7260 apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] ())) `shouldBeURI` "delete"
7361 apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw"
62+
63+
64+-- |
65+-- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,
66+-- we'll just use doctest
67+--
68+-- >>> apiLink (Proxy :: Proxy WrongPath)
69+-- ...
70+-- Could not deduce ...
71+-- ...
72+--
73+-- >>> apiLink (Proxy :: Proxy WrongReturnType)
74+-- ...
75+-- Could not deduce ...
76+-- ...
77+--
78+-- >>> apiLink (Proxy :: Proxy WrongContentType)
79+-- ...
80+-- Could not deduce ...
81+-- ...
82+--
83+-- >>> apiLink (Proxy :: Proxy WrongMethod)
84+-- ...
85+-- Could not deduce ...
86+-- ...
87+--
88+-- >>> apiLink (Proxy :: Proxy NotALink)
89+-- ...
90+-- Could not deduce ...
91+-- ...
92+--
93+-- sanity check
94+-- >>> apiLink (Proxy :: Proxy AllGood)
95+-- get
96+type WrongPath = "getTypo" :> Get '[JSON] ()
97+type WrongReturnType = "get" :> Get '[JSON] Bool
98+type WrongContentType = "get" :> Get '[OctetStream] ()
99+type WrongMethod = "get" :> Post '[JSON] ()
100+type NotALink = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool
101+type AllGood = "get" :> Get '[JSON] ()