@@ -0,0 +1,59 @@
1+{-# LANGUAGE MultiParamTypeClasses #-}
2+{-# LANGUAGE FunctionalDependencies #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+module Servant.API.QQ where
6+
7+import Control.Applicative
8+import Data.List.Split (splitOn)
9+--import Language.Haskell.TH.Quote
10+import Language.Haskell.TH
11+
12+import Servant.API.Capture
13+import Servant.API.Get
14+import Servant.API.Post
15+import Servant.API.Put
16+import Servant.API.Delete
17+import Servant.API.Sub
18+
19+class 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
27+
28+instance 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))
41+
42+readEntry :: ExpSYM r' r => [String] -> Maybe r
43+readEntry [] = Nothing
44+readEntry (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
50+readEntry x = error $ "Wrong number of elems in line: " ++ show x
51+
52+readEntry' :: ExpSYM r' r => [String] -> Maybe r'
53+readEntry' [] = Nothing
54+readEntry' [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"
58+readEntry' _ = Nothing
59+