git.iko.soy/typeable/servant
on master help sign in
Flip fixity of TH sub.
21c8fcbJulian K. Arni
example/greet.hs+7−1
compare with master
unifiedsplit
@@ -5,6 +5,7 @@
5{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE QuasiQuotes #-}
8{-# OPTIONS_GHC -fno-warn-orphans #-}
9{-# OPTIONS_GHC -fno-warn-orphans #-}
9
10
10import Control.Concurrent (forkIO, killThread)
11import Control.Concurrent (forkIO, killThread)
@@ -49,11 +50,16 @@ instance ToSample Greet where
49 where g = Greet "Hello, haskeller!"
50 where g = Greet "Hello, haskeller!"
50
51
51-- API specification
52-- API specification
52−type TestApi =
53+type TestApi =
53 "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
54 "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
54 :<|> "greet" :> ReqBody Greet :> Post Greet
55 :<|> "greet" :> ReqBody Greet :> Post Greet
55 :<|> "delete" :> Capture "greetid" Text :> Delete
56 :<|> "delete" :> Capture "greetid" Text :> Delete
56
57
58+type TestApi2 = [sitemap|
59+GET Bool something/capt:Int
60+POST Bool something
61+|]
62+
57testApi :: Proxy TestApi
63testApi :: Proxy TestApi
58testApi = Proxy
64testApi = Proxy
59
65
src/Servant/API.hs+5
@@ -23,6 +23,10 @@ module Servant.API (
23 module Servant.API.Delete,
23 module Servant.API.Delete,
24 -- | PUT requests
24 -- | PUT requests
25 module Servant.API.Put,
25 module Servant.API.Put,
26+
27+ -- * Utilities
28+ -- | QuasiQuotes for endpoints
29+ module Servant.API.QQ,
26 ) where
30 ) where
27
31
28import Servant.API.Capture
32import Servant.API.Capture
@@ -31,6 +35,7 @@ import Servant.API.Get
31import Servant.API.Post
35import Servant.API.Post
32import Servant.API.Put
36import Servant.API.Put
33import Servant.API.QueryParam
37import Servant.API.QueryParam
38+import Servant.API.QQ
34import Servant.API.ReqBody
39import Servant.API.ReqBody
35import Servant.API.Sub
40import Servant.API.Sub
36import Servant.API.Union
41import Servant.API.Union
src/Servant/API/QQ.hs+50−32
@@ -2,11 +2,14 @@
2{-# LANGUAGE FunctionalDependencies #-}
2{-# LANGUAGE FunctionalDependencies #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TemplateHaskell #-}
5module Servant.API.QQ where
7module Servant.API.QQ where
6
8
7import Control.Applicative
9import Control.Applicative
8import Data.List.Split (splitOn)
10import Data.List.Split (splitOn)
11+import Data.Maybe (mapMaybe)
9−--import Language.Haskell.TH.Quote
12+import Language.Haskell.TH.Quote
10import Language.Haskell.TH
13import Language.Haskell.TH
11
14
12import Servant.API.Capture
15import Servant.API.Capture
@@ -15,45 +18,60 @@ import Servant.API.Post
15import Servant.API.Put
18import Servant.API.Put
16import Servant.API.Delete
19import Servant.API.Delete
17import Servant.API.Sub
20import Servant.API.Sub
21+import Servant.API.Union
18
22
19class ExpSYM repr' repr | repr -> repr', repr' -> repr where
23class ExpSYM repr' repr | repr -> repr', repr' -> repr where
20− simplePath :: String -> repr'
24+ lit :: String -> repr' -> repr
21− capture :: String -> String -> repr'
25+ capture :: String -> String -> repr -> repr
22− conj :: repr' -> repr' -> repr'
26+ conj :: repr' -> repr -> repr
23− get :: String -> repr' -> repr
27+ get :: String -> repr
24− post :: String -> repr' -> repr
28+ post :: String -> repr
25− put :: String -> repr' -> repr
29+ put :: String -> repr
26− delete :: String -> repr' -> repr
30+ delete :: String -> repr
31+
32+infixr 6 >:
33+
34+(>:) :: Type -> Type -> Type
35+(>:) = conj
27
36
28instance ExpSYM Type Type where
37instance ExpSYM Type Type where
29− simplePath name = LitT (StrTyLit name)
38+ lit name r = (LitT (StrTyLit name)) >: r
30− capture name typ = AppT (AppT (ConT ''Capture) (simplePath name))
39+ capture name typ r = (AppT (AppT (ConT ''Capture) (LitT (StrTyLit name)))
31− (ConT $ mkName typ)
40+ (ConT $ mkName typ)) >: r
32− conj f s = AppT (AppT (ConT ''(:>)) f) s
41+ conj x y = AppT (AppT (ConT ''(:>)) x) y
33− get typ r = AppT (AppT (ConT ''(:>)) r)
34− (AppT (ConT ''Get) (ConT $ mkName typ))
42+ get typ = AppT (ConT ''Get) (ConT $ mkName typ)
35− post typ r = AppT (AppT (ConT ''(:>)) r)
36− (AppT (ConT ''Post) (ConT $ mkName typ))
43+ post typ = AppT (ConT ''Post) (ConT $ mkName typ)
37− put typ r = AppT (AppT (ConT ''(:>)) r)
38− (AppT (ConT ''Put) (ConT $ mkName typ))
44+ put typ = AppT (ConT ''Put) (ConT $ mkName typ)
39− delete typ r = AppT (AppT (ConT ''(:>)) r)
40− (AppT (ConT ''Delete) (ConT $ mkName typ))
45+ delete typ = AppT (ConT ''Delete) (ConT $ mkName typ)
41−
46+
42−readEntry :: ExpSYM r' r => [String] -> Maybe r
47+readEntry :: ExpSYM r r => [String] -> Maybe r
43readEntry [] = Nothing
48readEntry [] = Nothing
44readEntry (met:typ:xs) = case met of
49readEntry (met:typ:xs) = case met of
45− "GET" -> get typ <$> readEntry' xs
50+ "GET" -> readEntry' xs $ get typ
46− "POST" -> post typ <$> readEntry' xs
51+ "POST" -> readEntry' xs $ post typ
47− "PUT" -> put typ <$> readEntry' xs
52+ "PUT" -> readEntry' xs $ put typ
48− "DELETE" -> delete typ <$> readEntry' xs
53+ "DELETE" -> readEntry' xs $ delete typ
49 x -> error $ "Unknown method: " ++ x
54 x -> error $ "Unknown method: " ++ x
50readEntry x = error $ "Wrong number of elems in line: " ++ show x
55readEntry x = error $ "Wrong number of elems in line: " ++ show x
51
56
52−readEntry' :: ExpSYM r' r => [String] -> Maybe r'
57+readEntry' :: ExpSYM r r => [String] -> r -> Maybe r
53−readEntry' [] = Nothing
58+readEntry' [] _ = Nothing
54−readEntry' [xs] = Just $ foldr1 conj $ tRepr <$> splitOn "/" xs
59+readEntry' [xs] r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r
60+ where
55− where tRepr y | [x] <- splitOn ":" y = simplePath x
61+ tRepr y | [x] <- splitOn ":" y = lit x
56− | x:[y] <- splitOn ":" y = capture x y
62+ | a:[b] <- splitOn ":" y = capture a b
57 | otherwise = error "Only one ':' per section"
63 | otherwise = error "Only one ':' per section"
58−readEntry' _ = Nothing
64+readEntry' _ _ = Nothing
65+
66+readAll :: String -> Type
67+readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s
68+ where union :: Type -> Type -> Type
69+ union a b = AppT (AppT (ConT ''(:<|>)) a) b
70+
71+sitemap :: QuasiQuoter
72+sitemap = QuasiQuoter { quoteExp = undefined
73+ , quotePat = undefined
74+ , quoteType = return . readAll
75+ , quoteDec = undefined
76+ }
59
77