@@ -2,11 +2,14 @@
22{-# LANGUAGE FunctionalDependencies #-}
33{-# LANGUAGE DataKinds #-}
44{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TemplateHaskell #-}
57module Servant.API.QQ where
68
79import Control.Applicative
810import Data.List.Split (splitOn)
9−--import Language.Haskell.TH.Quote
11+import Data.Maybe (mapMaybe)
12+import Language.Haskell.TH.Quote
1013import Language.Haskell.TH
1114
1215import Servant.API.Capture
@@ -15,45 +18,60 @@ import Servant.API.Post
1518import Servant.API.Put
1619import Servant.API.Delete
1720import Servant.API.Sub
21+import Servant.API.Union
1822
1923class 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
24+ lit :: String -> repr' -> repr
25+ capture :: String -> String -> repr -> repr
26+ conj :: repr' -> repr -> repr
27+ get :: String -> repr
28+ post :: String -> repr
29+ put :: String -> repr
30+ delete :: String -> repr
31+
32+infixr 6 >:
33+
34+(>:) :: Type -> Type -> Type
35+(>:) = conj
2736
2837instance 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
38+ lit name r = (LitT (StrTyLit name)) >: r
39+ capture name typ r = (AppT (AppT (ConT ''Capture) (LitT (StrTyLit name)))
40+ (ConT $ mkName typ)) >: r
41+ conj x y = AppT (AppT (ConT ''(:>)) x) y
42+ get typ = AppT (ConT ''Get) (ConT $ mkName typ)
43+ post typ = AppT (ConT ''Post) (ConT $ mkName typ)
44+ put typ = AppT (ConT ''Put) (ConT $ mkName typ)
45+ delete typ = AppT (ConT ''Delete) (ConT $ mkName typ)
46+
47+readEntry :: ExpSYM r r => [String] -> Maybe r
4348readEntry [] = Nothing
4449readEntry (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
50+ "GET" -> readEntry' xs $ get typ
51+ "POST" -> readEntry' xs $ post typ
52+ "PUT" -> readEntry' xs $ put typ
53+ "DELETE" -> readEntry' xs $ delete typ
4954 x -> error $ "Unknown method: " ++ x
5055readEntry x = error $ "Wrong number of elems in line: " ++ show x
5156
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+readEntry' :: ExpSYM r r => [String] -> r -> Maybe r
58+readEntry' [] _ = Nothing
59+readEntry' [xs] r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r
60+ where
61+ tRepr y | [x] <- splitOn ":" y = lit x
62+ | a:[b] <- splitOn ":" y = capture a b
5763 | 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+ }
5977