Merge pull request #34 from alpmestan/jkarni/qq-parser

Switch to Parsec for QQ parsing
This commit is contained in:
Alp Mestanogullari 2014-11-13 11:59:30 +01:00
commit 4f62dceb78
2 changed files with 86 additions and 34 deletions

View file

@ -47,6 +47,7 @@ library
, network-uri >= 2.6 , network-uri >= 2.6
, wai , wai
, warp , warp
, parsec
, safe , safe
, transformers , transformers
, template-haskell , template-haskell
@ -92,6 +93,7 @@ test-suite spec
, http-types , http-types
, network >= 2.6 , network >= 2.6
, QuickCheck , QuickCheck
, parsec
, servant , servant
, string-conversions , string-conversions
, text , text

View file

@ -4,14 +4,14 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Servant.Utils.ApiQuasiQuoting where module Servant.Utils.ApiQuasiQuoting where
import Control.Applicative import Control.Monad (void)
import Data.List.Split (splitOn) import Control.Applicative hiding (many, (<|>), optional)
import Data.Maybe (mapMaybe)
import Language.Haskell.TH.Quote import Language.Haskell.TH.Quote
import Language.Haskell.TH import Language.Haskell.TH
import Safe (headMay) import Text.ParserCombinators.Parsec
import Servant.API.Capture import Servant.API.Capture
import Servant.API.Get import Servant.API.Get
@ -34,6 +34,7 @@ class ExpSYM repr' repr | repr -> repr', repr' -> repr where
put :: String -> repr put :: String -> repr
delete :: String -> repr delete :: String -> repr
infixr 6 >: infixr 6 >:
(>:) :: Type -> Type -> Type (>:) :: Type -> Type -> Type
@ -54,42 +55,91 @@ instance ExpSYM Type Type where
delete "()" = ConT ''Delete delete "()" = ConT ''Delete
delete _ = error "Delete does not return a request body" delete _ = error "Delete does not return a request body"
readEntry :: ExpSYM r r => [String] -> Maybe r parseMethod :: ExpSYM repr' repr => Parser (String -> repr)
readEntry [] = Nothing parseMethod = try (string "GET" >> return get)
readEntry (met:xs:typ) = case met of <|> try (string "POST" >> return post)
"GET" -> rd get <|> try (string "PUT" >> return put)
"POST" -> rd post <|> try (string "DELETE" >> return delete)
"PUT" -> rd put
"DELETE" -> rd delete
x -> error $ "Unknown method: " ++ x
where typ' = splitOn "->" $ concat typ
rd m = case typ' of
[] -> readEntry' xs $ m "()"
[rsp] -> readEntry' xs $ m rsp
(rqbd:[rsp]) -> readEntry' xs $ reqBody rqbd $ m rsp
_ -> error "Only functions of one argument allowed!"
readEntry x = error $ "Wrong number of elems in line: " ++ show x
readEntry' :: ExpSYM r r => String -> r -> Maybe r parseUrlSegment :: ExpSYM repr repr => Parser (repr -> repr)
readEntry' [] _ = Nothing parseUrlSegment = try parseCapture
readEntry' xs r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r <|> try parseQueryParam
where <|> try parseLit
tRepr y | [x] <- splitOn ":" y = lit x where
| a:[b] <- splitOn ":" y = case headMay a of parseCapture = do
Just '?' -> queryParam (tail a) b cname <- many (noneOf " ?/:")
Just _ -> capture a b char ':'
Nothing -> error "Expecting something after '/'" ctyp <- many (noneOf " ?/:")
| otherwise = error "Only one ':' per section" return $ capture cname ctyp
parseQueryParam = do
char '?'
cname <- many (noneOf " ?/:")
char ':'
ctyp <- many (noneOf " ?/:")
return $ queryParam cname ctyp
parseLit = lit <$> many (noneOf " ?/:")
readAll :: String -> Type parseUrl :: ExpSYM repr repr => Parser (repr -> repr)
readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s parseUrl = do
where union :: Type -> Type -> Type optional $ char '/'
union a = AppT (AppT (ConT ''(:<|>)) a) url <- parseUrlSegment `sepBy1` char '/'
return $ foldr1 (.) url
data Typ = Val String
| ReqArgVal String String
parseTyp :: Parser Typ
parseTyp = do
f <- many (noneOf "-#\n\r")
spaces
s <- optionMaybe parseRet
case s of
Nothing -> return $ Val (stripTr f)
Just s' -> return $ ReqArgVal (stripTr f) (stripTr s')
where
parseRet :: Parser String
parseRet = do
string "->"
spaces
many (noneOf "#\n\r")
stripTr = reverse . dropWhile (== ' ') . reverse
parseEntry :: ExpSYM repr repr => Parser repr
parseEntry = do
met <- parseMethod
spaces
url <- parseUrl
spaces
typ <- parseTyp
case typ of
Val s -> return $ url (met s)
ReqArgVal i o -> return $ url $ reqBody i (met o)
eol :: Parser String
eol = try (string "\n\r")
<|> try (string "\r\n")
<|> string "\n"
<|> string "\r"
<?> "end of line"
eols :: Parser ()
eols = skipMany $ void eol
parseAll :: Parser Type
parseAll = do
eols
entries <- parseEntry `endBy` eols
return $ foldr1 union entries
where union :: Type -> Type -> Type
union a = AppT (AppT (ConT ''(:<|>)) a)
sitemap :: QuasiQuoter sitemap :: QuasiQuoter
sitemap = QuasiQuoter { quoteExp = undefined sitemap = QuasiQuoter { quoteExp = undefined
, quotePat = undefined , quotePat = undefined
, quoteType = return . readAll , quoteType = \x -> case parse parseAll "" x of
Left err -> error $ show err
Right st -> return st
, quoteDec = undefined , quoteDec = undefined
} }