77 lines
2.6 KiB
Haskell
77 lines
2.6 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE FunctionalDependencies #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
module Servant.API.QQ where
|
|
|
|
import Control.Applicative
|
|
import Data.List.Split (splitOn)
|
|
import Data.Maybe (mapMaybe)
|
|
import Language.Haskell.TH.Quote
|
|
import Language.Haskell.TH
|
|
|
|
import Servant.API.Capture
|
|
import Servant.API.Get
|
|
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
|
|
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
|
|
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 [] = Nothing
|
|
readEntry (met:typ:xs) = case met of
|
|
"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] -> 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
|
|
|
|
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
|
|
}
|
|
|