From 21c8fcbea2285c01026f11266fa5a03e44f43cfd Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 28 Oct 2014 15:22:28 +0100 Subject: [PATCH] Flip fixity of TH sub. And do some general cleanup. --- example/greet.hs | 8 ++++- src/Servant/API.hs | 5 +++ src/Servant/API/QQ.hs | 80 ++++++++++++++++++++++++++----------------- 3 files changed, 61 insertions(+), 32 deletions(-) diff --git a/example/greet.hs b/example/greet.hs index 1d364515..394a4111 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} import Control.Concurrent (forkIO, killThread) @@ -49,11 +50,16 @@ instance ToSample Greet where where g = Greet "Hello, haskeller!" -- API specification -type TestApi = +type TestApi = "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet :<|> "greet" :> ReqBody Greet :> Post Greet :<|> "delete" :> Capture "greetid" Text :> Delete +type TestApi2 = [sitemap| +GET Bool something/capt:Int +POST Bool something +|] + testApi :: Proxy TestApi testApi = Proxy diff --git a/src/Servant/API.hs b/src/Servant/API.hs index 6f841da4..be283f06 100644 --- a/src/Servant/API.hs +++ b/src/Servant/API.hs @@ -23,6 +23,10 @@ module Servant.API ( module Servant.API.Delete, -- | PUT requests module Servant.API.Put, + + -- * Utilities + -- | QuasiQuotes for endpoints + module Servant.API.QQ, ) where import Servant.API.Capture @@ -31,6 +35,7 @@ import Servant.API.Get import Servant.API.Post import Servant.API.Put import Servant.API.QueryParam +import Servant.API.QQ import Servant.API.ReqBody import Servant.API.Sub import Servant.API.Union diff --git a/src/Servant/API/QQ.hs b/src/Servant/API/QQ.hs index 5a37cedc..930a9365 100644 --- a/src/Servant/API/QQ.hs +++ b/src/Servant/API/QQ.hs @@ -2,11 +2,14 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Servant.API.QQ where import Control.Applicative import Data.List.Split (splitOn) ---import Language.Haskell.TH.Quote +import Data.Maybe (mapMaybe) +import Language.Haskell.TH.Quote import Language.Haskell.TH import Servant.API.Capture @@ -15,45 +18,60 @@ import Servant.API.Post import Servant.API.Put import Servant.API.Delete import Servant.API.Sub +import Servant.API.Union class ExpSYM repr' repr | repr -> repr', repr' -> repr where - simplePath :: String -> repr' - capture :: String -> String -> repr' - conj :: repr' -> repr' -> repr' - get :: String -> repr' -> repr - post :: String -> repr' -> repr - put :: String -> repr' -> repr - delete :: String -> repr' -> repr + lit :: String -> repr' -> repr + capture :: String -> String -> repr -> repr + conj :: repr' -> repr -> repr + get :: String -> repr + post :: String -> repr + put :: String -> repr + delete :: String -> repr + +infixr 6 >: + +(>:) :: Type -> Type -> Type +(>:) = conj instance ExpSYM Type Type where - simplePath name = LitT (StrTyLit name) - capture name typ = AppT (AppT (ConT ''Capture) (simplePath name)) - (ConT $ mkName typ) - conj f s = AppT (AppT (ConT ''(:>)) f) s - get typ r = AppT (AppT (ConT ''(:>)) r) - (AppT (ConT ''Get) (ConT $ mkName typ)) - post typ r = AppT (AppT (ConT ''(:>)) r) - (AppT (ConT ''Post) (ConT $ mkName typ)) - put typ r = AppT (AppT (ConT ''(:>)) r) - (AppT (ConT ''Put) (ConT $ mkName typ)) - delete typ r = AppT (AppT (ConT ''(:>)) r) - (AppT (ConT ''Delete) (ConT $ mkName typ)) + lit name r = (LitT (StrTyLit name)) >: r + capture name typ r = (AppT (AppT (ConT ''Capture) (LitT (StrTyLit name))) + (ConT $ mkName typ)) >: r + conj x y = AppT (AppT (ConT ''(:>)) x) y + get typ = AppT (ConT ''Get) (ConT $ mkName typ) + post typ = AppT (ConT ''Post) (ConT $ mkName typ) + put typ = AppT (ConT ''Put) (ConT $ mkName typ) + delete typ = AppT (ConT ''Delete) (ConT $ mkName typ) -readEntry :: ExpSYM r' r => [String] -> Maybe r +readEntry :: ExpSYM r r => [String] -> Maybe r readEntry [] = Nothing readEntry (met:typ:xs) = case met of - "GET" -> get typ <$> readEntry' xs - "POST" -> post typ <$> readEntry' xs - "PUT" -> put typ <$> readEntry' xs - "DELETE" -> delete typ <$> readEntry' xs + "GET" -> readEntry' xs $ get typ + "POST" -> readEntry' xs $ post typ + "PUT" -> readEntry' xs $ put typ + "DELETE" -> readEntry' xs $ delete typ x -> error $ "Unknown method: " ++ x readEntry x = error $ "Wrong number of elems in line: " ++ show x -readEntry' :: ExpSYM r' r => [String] -> Maybe r' -readEntry' [] = Nothing -readEntry' [xs] = Just $ foldr1 conj $ tRepr <$> splitOn "/" xs - where tRepr y | [x] <- splitOn ":" y = simplePath x - | x:[y] <- splitOn ":" y = capture x y +readEntry' :: ExpSYM r r => [String] -> r -> Maybe r +readEntry' [] _ = Nothing +readEntry' [xs] r = Just $ foldr1 (.) (tRepr <$> splitOn "/" xs) r + where + tRepr y | [x] <- splitOn ":" y = lit x + | a:[b] <- splitOn ":" y = capture a b | otherwise = error "Only one ':' per section" -readEntry' _ = Nothing +readEntry' _ _ = Nothing + +readAll :: String -> Type +readAll s = foldr1 union $ mapMaybe readEntry $ words <$> lines s + where union :: Type -> Type -> Type + union a b = AppT (AppT (ConT ''(:<|>)) a) b + +sitemap :: QuasiQuoter +sitemap = QuasiQuoter { quoteExp = undefined + , quotePat = undefined + , quoteType = return . readAll + , quoteDec = undefined + }