module Network.YAML.TH.Dispatcher
(ValueFn, ToValueFn (..), Dispatcher, generateDispatcherT, generateDispatcher
) where
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson hiding (json)
import qualified Data.Text as T
import qualified Data.Map as M
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as H
import Language.Haskell.TH
import Language.Haskell.TH.Lift
import Network.YAML.API
type ValueFn m = Value -> m Value
type Dispatcher m = T.Text -> Maybe (ValueFn m)
class ToValueFn m f where
toValueFn :: f -> ValueFn m
instance (ToJSON y, MonadIO m) => ToValueFn m (m y) where
toValueFn fn = \rq -> do
case rq of
Array v -> case V.toList v of
[] -> do
y <- fn
return $ toJSON y
_ -> fail $ "Invalid number of arguments"
_ -> fail $ "Invalid request format: " ++ show rq
instance (Monad m, FromJSON x, ToValueFn m f) => ToValueFn m (x -> f) where
toValueFn fn = \rq -> do
case rq of
Array v -> case V.toList v of
(arg:_) ->
case fromJSON arg of
Error str -> fail $ "Request parsing error: " ++ str
Success x -> do
toValueFn (fn x) $ Array $ V.tail v
_ -> fail $ "Invalid number of arguments"
_ -> fail $ "Invalid request format: " ++ show rq
generateDispatcherT :: Name -> API -> Q [Dec]
generateDispatcherT m (API _ _ methods) = do
method <- newName "method"
let c = clause [varP method] (normalB $ go method $ M.assocs methods) []
cName <- newName "dispatcher"
sequence [
sigD cName [t| Dispatcher $(return $ ConT m) |],
funD cName [c] ]
where
go _ [] = [| Nothing |]
go method ((methodName, m): ms) = do
let nameStr = T.unpack methodName
let name = mkName nameStr
let other = go method ms
[| if $(varE method) == $(return $ LitE $ StringL nameStr)
then Just $ toValueFn $(varE name)
else $(other) |]
generateDispatcher :: API -> Q [Dec]
generateDispatcher api = generateDispatcherT (mkName "IO") api