git.iko.soy/servant
on 21c8fcb help sign in
servant/src/Servant/API/QQ.hs
77 lines 2.7 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
15import Servant.API.Capture
16import Servant.API.Get
17import Servant.API.Post
18import Servant.API.Put
19import Servant.API.Delete
20import Servant.API.Sub
21import Servant.API.Union
23class ExpSYM repr' repr | repr -> repr', repr' -> repr where
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
32infixr 6 >:
34(>:) :: Type -> Type -> Type
35(>:) = conj
37instance ExpSYM Type Type where
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)
47readEntry :: ExpSYM r r => [String] -> Maybe r
48readEntry [] = Nothing
49readEntry (met:typ:xs) = case met of
50 "GET" -> readEntry' xs $ get typ
51 "POST" -> readEntry' xs $ post typ
52 "PUT" -> readEntry' xs $ put typ
53 "DELETE" -> readEntry' xs $ delete typ
54 x -> error $ "Unknown method: " ++ x
55readEntry x = error $ "Wrong number of elems in line: " ++ show x
57readEntry' :: ExpSYM r r => [String] -> r -> Maybe r
58readEntry' [] _ = Nothing
59readEntry' [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
63 | otherwise = error "Only one ':' per section"
64readEntry' _ _ = Nothing
66readAll :: String -> Type
67readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s
68 where union :: Type -> Type -> Type
69 union a b = AppT (AppT (ConT ''(:<|>)) a) b
71sitemap :: QuasiQuoter
72sitemap = QuasiQuoter { quoteExp = undefined
73 , quotePat = undefined
74 , quoteType = return . readAll
75 , quoteDec = undefined
76 }