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

Switch to Parsec for QQ parsing

servant.cabal

@@ -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

src/Servant/Utils/ApiQuasiQuoting.hs

@@ -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 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
-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
+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 { 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
                       }