@@ -1,344 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE RecordWildCards #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TemplateHaskell #-}
9−{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
10−-- | QuasiQuoting utilities for API types.
11−--
12−-- 'sitemap' allows you to write your type in a very natural way:
13−--
14−-- @
15−-- [sitemap|
16−-- PUT hello String -> ()
17−-- POST hello/p:Int String -> ()
18−-- GET hello/?name:String Int
19−-- |]
20−-- @
21−--
22−-- Will generate:
23−--
24−-- @
25−-- "hello" :> ReqBody String :> Put ()
26−-- :\<|> "hello" :> Capture "p" Int :> ReqBody String :> Post ()
27−-- :\<|> "hello" :> QueryParam "name" String :> Get Int
28−-- @
29−--
30−-- Note the @/@ before a @QueryParam@!
31−module Servant.QQ (sitemap) where
32−
33−import Control.Applicative ( (<$>) )
34−import Control.Monad ( void )
35−import Data.Monoid ( Monoid(..), (<>) )
36−import Data.Maybe ( mapMaybe )
37−import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
38−import Language.Haskell.TH
39− ( mkName, Type(AppT, ConT, LitT), TyLit(StrTyLit) )
40−import Text.ParserCombinators.Parsec
41− ( try,
42− Parser,
43− manyTill,
44− endBy,
45− sepBy1,
46− optional,
47− optionMaybe,
48− string,
49− anyChar,
50− char,
51− spaces,
52− noneOf,
53− parse,
54− skipMany,
55− many,
56− lookAhead,
57− (<|>),
58− (<?>) )
59−import Servant.API.Capture ( Capture )
60−import Servant.API.Get ( Get )
61−import Servant.API.Post ( Post )
62−import Servant.API.Put ( Put )
63−import Servant.API.Delete ( Delete )
64−import Servant.API.QueryParam ( QueryParam )
65−import Servant.API.MatrixParam ( MatrixParam )
66−import Servant.API.ReqBody ( ReqBody )
67−import Servant.API.Sub ( (:>) )
68−import Servant.API.Alternative ( (:<|>) )
69−
70−data MethodE
71−data PathElemE
72−data OptsE
73−data SitemapE
74−
75−sitemap = undefined
76−{-
77−data Validation e a = Failure e
78− | Success a
79−
80−instance Functor (Validation e) where
81− fmap _ (Failure e) = Failure e
82− fmap f (Success a) = Success (f a)
83−
84−data Exp a where
85− Method :: String -> Exp MethodE
86− Slash :: Exp PathElemE -> Exp PathElemE -> Exp PathElemE
87− PathElem :: String -> Exp PathElemE
88− Opts :: String -> Exp OptsE
89− JoinOpts :: Exp OptsE -> Exp OptsE -> Exp OptsE
90− AddOpts :: Exp SitemapE -> Exp OptsE -> Exp SitemapE
91− Line :: Exp MethodE -> Exp PathElemE -> Exp SitemapE
92− Sitemap :: Exp SitemapE -> Exp SitemapE -> Exp SitemapE
93−
94−data ParseError = ParseError Int String
95−
96−parseEverything :: String -> Exp SitemapE
97−parseEverything str = undefined {-removeComments <$> lines str
98− where removeComments = takeWhile (/= '#')
99− parseLines _ [] = []
100− parseLines lineno (x:xs) = case opts of
101− [] -> (parseUrlLine x):parseLines rest
102− xs -> undefined
103− where (opts, rest) = span (startsWith ' ') xs -}
104−
105−
106−
107−parsePath :: String -> Exp PathElemE
108−parsePath line = foldr1 Slash $ PathElem <$> wordsBy '/' line
109−
110−parseOpts :: Int -> [String] -> Either ParseError (Exp OptsE)
111−parseOpts lineno lines = foldr1 JoinOpts $ Opts <$> lines
112−
113−parseUrlLine :: Int -> String -> Either ParseError (Exp SitemapE)
114−parseUrlLine lineno line = case span '>' line of
115− ([], x) -> Left $ ParseError lineno "Expected method and url before '>'"
116− (xs, ">") -> Left $ ParseError lineno "Expected type after '>'"
117− (xs, '>':ys) | length (words xs) /= 2 -> Left $ ParseError lineno "Expected method and url before '>'"
118− | otherwise -> Line (Method met) (parsePath url)
119− where met:url = words xs
120−
121−wordsBy :: Char -> String -> [String]
122−wordsBy c s = case dropWhile (== c) s of
123− "" -> []
124− s' -> w : words s''
125− where (w, s'') = break (== c) s'
126−
127−
128−data SitemapParser = SitemapParser
129− { methodParsers :: [String -> Maybe Type]
130− , pathParsers :: [String -> Maybe Type]
131− , optsParsers :: [String -> Maybe Type]
132− }
133−
134−
135−pFirstWE :: [a -> Maybe b] -> a -> c -> Validation c b
136−pFirstWE fn a c = maybe (Failure c) Success $ pFirst fn a
137− where pFirst :: [a -> Maybe b] -> a -> Maybe b
138− pFirst fns s = case mapMaybe ($ s) fns of
139− [] -> Nothing
140− x:_ -> Just x
141−
142−
143−joinWith :: Monoid err => (typ -> typ -> typ)
144− -> Validation err typ
145− -> Validation err typ
146− -> Validation err typ
147−joinWith mult (Success s1) (Success s2) = Success (s1 `mult` s2)
148−joinWith _ (Failure e1) (Failure e2) = Failure (e1 <> e2)
149−joinWith _ (Failure e1) _ = Failure e1
150−joinWith _ _ (Failure e2) = Failure e2
151−
152−pathUnion :: Type -> Type -> Type
153−pathUnion a = AppT (AppT (ConT ''(:>)) a)
154−
155−optsUnion :: Type -> Type -> Type
156−optsUnion a = AppT (AppT (ConT ''(:<|>)) a)
157−
158−data UndefinedError = UndefinedPath String
159− | UndefinedMethod String
160− | UndefinedOpts String
161− deriving (Eq, Show)
162−
163−evalPath :: SitemapParser -> Exp PathElemE -> Validation [UndefinedError] Type
164−evalPath SitemapParser{..} (PathElem path) = pFirstWE pathParsers path [UndefinedPath path]
165−evalPath sp (p1 `Slash` p2) = joinWith pathUnion (evalPath sp p1) (evalPath sp p2)
166−
167−evalMethod :: SitemapParser -> Exp MethodE -> Validation [UndefinedError] Type
168−evalMethod SitemapParser{..} (Method met) = pFirstWE methodParsers met [UndefinedMethod met]
169−
170−evalOpts :: SitemapParser -> Exp OptsE -> Validation [UndefinedError] Type
171−evalOpts SitemapParser{..} (Opts opt) = pFirstWE optsParsers opt [UndefinedOpts opt]
172−evalOpts sp (o1 `JoinOpts` o2) = joinWith optsUnion (evalOpts sp o1) (evalOpts sp o2)
173−
174−
175−addMethodParser, addPathParser, addOptsParser :: (String -> Maybe Type) -> SitemapParser -> SitemapParser
176−addMethodParser a x@SitemapParser{..} = x{ methodParsers = methodParsers ++ [a] }
177−addOptsParser a x@SitemapParser{..} = x{ optsParsers = optsParsers ++ [a] }
178−addPathParser a x@SitemapParser{..} = x{ pathParsers = pathParsers ++ [a] }
179−
180−-- | Finally-tagless encoding for our DSL.
181−-- Keeping 'repr'' and 'repr' distinct when writing functions with an
182−-- @ExpSYM@ context ensures certain invariants (for instance, that there is
183−-- only one of 'get', 'post', 'put', and 'delete' in a value), but
184−-- sometimes requires a little more work.
185−class ExpSYM repr' repr | repr -> repr', repr' -> repr where
186− lit :: String -> repr' -> repr
187− capture :: String -> String -> repr -> repr
188− reqBody :: String -> repr -> repr
189− queryParam :: String -> String -> repr -> repr
190− matrixParam :: String -> String -> repr -> repr
191− conj :: repr' -> repr -> repr
192− get :: String -> repr
193− post :: String -> repr
194− put :: String -> repr
195− delete :: String -> repr
196−
197−
198−infixr 6 >:
199−
200−(>:) :: Type -> Type -> Type
201−(>:) = conj
202−
203−
204−instance ExpSYM Type Type where
205− lit name r = LitT (StrTyLit name) >: r
206− capture name typ r = AppT (AppT (ConT ''Capture) (LitT (StrTyLit name)))
207− (ConT $ mkName typ) >: r
208− reqBody typ r = AppT (ConT ''ReqBody) (ConT $ mkName typ) >: r
209− queryParam name typ r = AppT (AppT (ConT ''QueryParam) (LitT (StrTyLit name)))
210− (ConT $ mkName typ) >: r
211− matrixParam name typ r = AppT (AppT (ConT ''MatrixParam) (LitT (StrTyLit name)))
212− (ConT $ mkName typ) >: r
213− conj x = AppT (AppT (ConT ''(:>)) x)
214− get typ = AppT (ConT ''Get) (ConT $ mkName typ)
215− post typ = AppT (ConT ''Post) (ConT $ mkName typ)
216− put typ = AppT (ConT ''Put) (ConT $ mkName typ)
217− delete "()" = ConT ''Delete
218− delete _ = error "Delete does not return a request body"
219−
220−parseMethod :: ExpSYM repr' repr => Parser (String -> repr)
221−parseMethod = try (string "GET" >> return get)
222− <|> try (string "POST" >> return post)
223− <|> try (string "PUT" >> return put)
224− <|> try (string "DELETE" >> return delete)
225−
226−parseUrlSegment :: ExpSYM repr repr => Parser (repr -> repr)
227−parseUrlSegment = try parseCapture
228− <|> try parseQueryParam
229− <|> try parseLit
230− where
231− parseCapture = do
232− cname <- many (noneOf " ?/:;")
233− char ':'
234− ctyp <- many (noneOf " ?/:;")
235− mx <- many parseMatrixParam
236− return $ capture cname ctyp . foldr (.) id mx
237− parseQueryParam = do
238− char '?'
239− cname <- many (noneOf " ?/:;")
240− char ':'
241− ctyp <- many (noneOf " ?/:;")
242− return $ queryParam cname ctyp
243− parseLit = do
244− lt <- many (noneOf " ?/:;")
245− mx <- many parseMatrixParam
246− return $ lit lt . foldr (.) id mx
247− parseMatrixParam = do
248− char ';'
249− cname <- many (noneOf " ?/:;")
250− char ':'
251− ctyp <- many (noneOf " ?/:;")
252− return $ matrixParam cname ctyp
253−
254−parseUrl :: ExpSYM repr repr => Parser (repr -> repr)
255−parseUrl = do
256− optional $ char '/'
257− url <- parseUrlSegment `sepBy1` char '/'
258− return $ foldr1 (.) url
259−
260−data Typ = Val String
261− | ReqArgVal String String
262−
263−parseTyp :: Parser Typ
264−parseTyp = do
265− f <- many (noneOf "-{\n\r")
266− spaces
267− s <- optionMaybe (try parseRet)
268− try $ optional inlineComment
269− try $ optional blockComment
270− case s of
271− Nothing -> return $ Val (stripTr f)
272− Just s' -> return $ ReqArgVal (stripTr f) (stripTr s')
273− where
274− parseRet :: Parser String
275− parseRet = do
276− string "->"
277− spaces
278− many (noneOf "-{\n\r")
279− stripTr = reverse . dropWhile (== ' ') . reverse
280−
281−
282−parseEntry :: ExpSYM repr repr => Parser repr
283−parseEntry = do
284− met <- parseMethod
285− spaces
286− url <- parseUrl
287− spaces
288− typ <- parseTyp
289− case typ of
290− Val s -> return $ url (met s)
291− ReqArgVal i o -> return $ url $ reqBody i (met o)
292−
293−blockComment :: Parser ()
294−blockComment = do
295− string "{-"
296− manyTill anyChar (try $ string "-}")
297− return ()
298−
299−inlineComment :: Parser ()
300−inlineComment = do
301− string "--"
302− manyTill anyChar (try $ lookAhead eol)
303− return ()
304−
305−eol :: Parser String
306−eol = try (string "\n\r")
307− <|> try (string "\r\n")
308− <|> string "\n"
309− <|> string "\r"
310− <?> "end of line"
311−
312−eols :: Parser ()
313−eols = skipMany $ void eol <|> blockComment <|> inlineComment
314−
315−parseAll :: Parser Type
316−parseAll = do
317− eols
318− entries <- parseEntry `endBy` eols
319− return $ foldr1 union entries
320− where union :: Type -> Type -> Type
321− union a = AppT (AppT (ConT ''(:<|>)) a)
322−
323−-- | The sitemap QuasiQuoter.
324−--
325−-- * @.../<var>:<type>/...@ becomes a capture
326−-- * @.../?<var>:<type>@ becomes a query parameter
327−-- * @<method> ... <typ>@ becomes a method returning @<typ>@
328−-- * @<method> ... <typ1> -> <typ2>@ becomes a method with request
329−-- body of @<typ1>@ and returning @<typ2>@
330−--
331−-- Comments are allowed, and have the standard Haskell format
332−--
333−-- * @--@ for inline
334−-- * @{- ... -}@ for block
335−--
336−sitemap :: QuasiQuoter
337−sitemap = QuasiQuoter { quoteExp = undefined
338− , quotePat = undefined
339− , quoteType = \x -> case parse parseAll "" x of
340− Left err -> error $ show err
341− Right st -> return st
342− , quoteDec = undefined
343− }
344−-}