git.iko.soy/servant
on e6be95f help sign in
servant/src/Servant/API/QQ.hs
59 lines 2.3 kB history raw
1{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE FunctionalDependencies #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleInstances #-}
5module Servant.API.QQ where
7import Control.Applicative
8import Data.List.Split (splitOn)
9--import Language.Haskell.TH.Quote
10import Language.Haskell.TH
12import Servant.API.Capture
13import Servant.API.Get
14import Servant.API.Post
15import Servant.API.Put
16import Servant.API.Delete
17import Servant.API.Sub
19class ExpSYM repr' repr | repr -> repr', repr' -> repr where
20 simplePath :: String -> repr'
21 capture :: String -> String -> repr'
22 conj :: repr' -> repr' -> repr'
23 get :: String -> repr' -> repr
24 post :: String -> repr' -> repr
25 put :: String -> repr' -> repr
26 delete :: String -> repr' -> repr
28instance ExpSYM Type Type where
29 simplePath name = LitT (StrTyLit name)
30 capture name typ = AppT (AppT (ConT ''Capture) (simplePath name))
31 (ConT $ mkName typ)
32 conj f s = AppT (AppT (ConT ''(:>)) f) s
33 get typ r = AppT (AppT (ConT ''(:>)) r)
34 (AppT (ConT ''Get) (ConT $ mkName typ))
35 post typ r = AppT (AppT (ConT ''(:>)) r)
36 (AppT (ConT ''Post) (ConT $ mkName typ))
37 put typ r = AppT (AppT (ConT ''(:>)) r)
38 (AppT (ConT ''Put) (ConT $ mkName typ))
39 delete typ r = AppT (AppT (ConT ''(:>)) r)
40 (AppT (ConT ''Delete) (ConT $ mkName typ))
42readEntry :: ExpSYM r' r => [String] -> Maybe r
43readEntry [] = Nothing
44readEntry (met:typ:xs) = case met of
45 "GET" -> get typ <$> readEntry' xs
46 "POST" -> post typ <$> readEntry' xs
47 "PUT" -> put typ <$> readEntry' xs
48 "DELETE" -> delete typ <$> readEntry' xs
49 x -> error $ "Unknown method: " ++ x
50readEntry x = error $ "Wrong number of elems in line: " ++ show x
52readEntry' :: ExpSYM r' r => [String] -> Maybe r'
53readEntry' [] = Nothing
54readEntry' [xs] = Just $ foldr1 conj $ tRepr <$> splitOn "/" xs
55 where tRepr y | [x] <- splitOn ":" y = simplePath x
56 | x:[y] <- splitOn ":" y = capture x y
57 | otherwise = error "Only one ':' per section"
58readEntry' _ = Nothing