git.iko.soy/servant
on bab2bc7 help sign in
servant/src/Servant/API/QQ.hs
95 lines 3.6 kB history raw
1{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE FunctionalDependencies #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TemplateHaskell #-}
7module Servant.API.QQ where
9import Control.Applicative
10import Data.List.Split (splitOn)
11import Data.Maybe (mapMaybe)
12import Language.Haskell.TH.Quote
13import Language.Haskell.TH
14import Safe (headMay)
16import Servant.API.Capture
17import Servant.API.Get
18import Servant.API.Post
19import Servant.API.Put
20import Servant.API.Delete
21import Servant.API.QueryParam
22import Servant.API.ReqBody
23import Servant.API.Sub
24import Servant.API.Alternative
26class ExpSYM repr' repr | repr -> repr', repr' -> repr where
27 lit :: String -> repr' -> repr
28 capture :: String -> String -> repr -> repr
29 reqBody :: String -> repr -> repr
30 queryParam :: String -> String -> repr -> repr
31 conj :: repr' -> repr -> repr
32 get :: String -> repr
33 post :: String -> repr
34 put :: String -> repr
35 delete :: String -> repr
37infixr 6 >:
39(>:) :: Type -> Type -> Type
40(>:) = conj
43instance ExpSYM Type Type where
44 lit name r = LitT (StrTyLit name) >: r
45 capture name typ r = AppT (AppT (ConT ''Capture) (LitT (StrTyLit name)))
46 (ConT $ mkName typ) >: r
47 reqBody typ r = AppT (ConT ''ReqBody) (ConT $ mkName typ) >: r
48 queryParam name typ r = AppT (AppT (ConT ''QueryParam) (LitT (StrTyLit name)))
49 (ConT $ mkName typ) >: r
50 conj x = AppT (AppT (ConT ''(:>)) x)
51 get typ = AppT (ConT ''Get) (ConT $ mkName typ)
52 post typ = AppT (ConT ''Post) (ConT $ mkName typ)
53 put typ = AppT (ConT ''Put) (ConT $ mkName typ)
54 delete "()" = ConT ''Delete
55 delete _ = error "Delete does not return a request body"
57readEntry :: ExpSYM r r => [String] -> Maybe r
58readEntry [] = Nothing
59readEntry (met:xs:typ) = case met of
60 "GET" -> rd get
61 "POST" -> rd post
62 "PUT" -> rd put
63 "DELETE" -> rd delete
64 x -> error $ "Unknown method: " ++ x
65 where typ' = splitOn "->" $ concat typ
66 rd m = case typ' of
67 [] -> readEntry' xs $ m "()"
68 [rsp] -> readEntry' xs $ m rsp
69 (rqbd:[rsp]) -> readEntry' xs $ reqBody rqbd $ m rsp
70 _ -> error "Only functions of one argument allowed!"
71readEntry x = error $ "Wrong number of elems in line: " ++ show x
73readEntry' :: ExpSYM r r => String -> r -> Maybe r
74readEntry' [] _ = Nothing
75readEntry' xs r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r
76 where
77 tRepr y | [x] <- splitOn ":" y = lit x
78 | a:[b] <- splitOn ":" y = case headMay a of
79 Just '?' -> queryParam (tail a) b
80 Just _ -> capture a b
81 Nothing -> error "Expecting something after '/'"
82 | otherwise = error "Only one ':' per section"
84readAll :: String -> Type
85readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s
86 where union :: Type -> Type -> Type
87 union a = AppT (AppT (ConT ''(:<|>)) a)
89sitemap :: QuasiQuoter
90sitemap = QuasiQuoter { quoteExp = undefined
91 , quotePat = undefined
92 , quoteType = return . readAll
93 , quoteDec = undefined
94 }