Switch to Parsec for QQ parsing

This commit is contained in:
Julian K. Arni 2014-11-12 11:34:33 +01:00
parent c8def821a1
commit 614c06b6e5
2 changed files with 86 additions and 34 deletions

View file

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

View file

@ -4,14 +4,14 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Servant.Utils.ApiQuasiQuoting where
import Control.Applicative
import Data.List.Split (splitOn)
import Data.Maybe (mapMaybe)
import Control.Monad (void)
import Control.Applicative hiding (many, (<|>), optional)
import Language.Haskell.TH.Quote
import Language.Haskell.TH
import Safe (headMay)
import Text.ParserCombinators.Parsec
import Servant.API.Capture
import Servant.API.Get
@ -34,6 +34,7 @@ class ExpSYM repr' repr | repr -> repr', repr' -> repr where
put :: String -> repr
delete :: String -> repr
infixr 6 >:
(>:) :: Type -> Type -> Type
@ -54,42 +55,91 @@ instance ExpSYM Type Type where
delete "()" = ConT ''Delete
delete _ = error "Delete does not return a request body"
readEntry :: ExpSYM r r => [String] -> Maybe r
readEntry [] = Nothing
readEntry (met:xs:typ) = case met of
"GET" -> rd get
"POST" -> rd post
"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
parseMethod :: ExpSYM repr' repr => Parser (String -> repr)
parseMethod = try (string "GET" >> return get)
<|> try (string "POST" >> return post)
<|> try (string "PUT" >> return put)
<|> try (string "DELETE" >> return delete)
readEntry' :: ExpSYM r r => String -> r -> Maybe r
readEntry' [] _ = Nothing
readEntry' xs r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r
parseUrlSegment :: ExpSYM repr repr => Parser (repr -> repr)
parseUrlSegment = try parseCapture
<|> try parseQueryParam
<|> try parseLit
where
tRepr y | [x] <- splitOn ":" y = lit x
| a:[b] <- splitOn ":" y = case headMay a of
Just '?' -> queryParam (tail a) b
Just _ -> capture a b
Nothing -> error "Expecting something after '/'"
| otherwise = error "Only one ':' per section"
parseCapture = do
cname <- many (noneOf " ?/:")
char ':'
ctyp <- many (noneOf " ?/:")
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
readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s
parseUrl :: ExpSYM repr repr => Parser (repr -> repr)
parseUrl = do
optional $ char '/'
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 { quoteExp = undefined
, quotePat = undefined
, quoteType = return . readAll
, quoteType = \x -> case parse parseAll "" x of
Left err -> error $ show err
Right st -> return st
, quoteDec = undefined
}