{-# LANGUAGE OverlappingInstances, IncoherentInstances, FlexibleContexts, UndecidableInstances, LambdaCase, CPP #-}

module Autolib.XmlRpc ( ) where

import Autolib.Set 

import Network.XmlRpc.Internals

getField' :: String -> [(String, Value)] -> ExceptT String m b
getField' String
name [(String, Value)]
xs = String -> [(String, Value)] -> Err m (Maybe b)
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
String -> [(String, Value)] -> Err m (Maybe a)
getFieldMaybe String
name [(String, Value)]
xs Err m (Maybe b)
-> (Maybe b -> ExceptT String m b) -> ExceptT String m b
forall a b.
ExceptT String m a
-> (a -> ExceptT String m b) -> ExceptT String m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
    Maybe b
Nothing -> String -> ExceptT String m b
forall a. String -> ExceptT String m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ( String
"getField : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name )
    Just b
v  -> b -> ExceptT String m b
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
v

instance XmlRpcType Integer where
    getType :: Integer -> Type
getType Integer
_ = Type
TStruct
    toValue :: Integer -> Value
toValue Integer
x = [(String, Value)] -> Value
ValueStruct [ ( String
"integer", String -> Value
forall a. XmlRpcType a => a -> Value
toValue (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
x ) ]
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Integer
fromValue (ValueStruct [(String, Value)]
xs) = String -> Integer
forall a. Read a => String -> a
read (String -> Integer)
-> ExceptT String m String -> ExceptT String m Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [(String, Value)] -> ExceptT String m String
forall {m :: * -> *} {b}.
(MonadFail m, XmlRpcType b) =>
String -> [(String, Value)] -> ExceptT String m b
getField' String
"integer" [(String, Value)]
xs

#if MIN_VERSION_haxr(3000,11,4)
{-  FIXME/CHECKME:
this instance now is in haxr-3000.11.4
but it's different:

instance XmlRpcType () where
    toValue = const ValueNil
    fromValue = simpleFromValue f
        where f ValueNil = Just ()
              f _ = Nothing
    getType _ = TNil
-}
#else
instance XmlRpcType ( ) where
    toValue () = toValue ( [ ] :: [()] )
    fromValue v = return ()
    getType _ = TStruct
#endif

instance ( Ord a, XmlRpcType [a] ) => XmlRpcType ( Set a ) where
    getType :: Set a -> Type
getType Set a
_ = Type
TStruct
    toValue :: Set a -> Value
toValue Set a
s = [(String, Value)] -> Value
ValueStruct [(String
"elements", [a] -> Value
forall a. XmlRpcType a => a -> Value
toValue ([a] -> Value) -> [a] -> Value
forall a b. (a -> b) -> a -> b
$ Set a -> [a]
forall a. Set a -> [a]
setToList Set a
s )]
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m (Set a)
fromValue ( ValueStruct [(String, Value)]
v ) = [a] -> Set a
forall a. Ord a => [a] -> Set a
mkSet ([a] -> Set a) -> ExceptT String m [a] -> ExceptT String m (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [(String, Value)] -> ExceptT String m [a]
forall {m :: * -> *} {b}.
(MonadFail m, XmlRpcType b) =>
String -> [(String, Value)] -> ExceptT String m b
getField' String
"elements" [(String, Value)]
v

instance (XmlRpcType a, XmlRpcType b) => XmlRpcType (Either a b) where
    getType :: Either a b -> Type
getType Either a b
_ = Type
TStruct
    toValue :: Either a b -> Value
toValue Either a b
e = case Either a b
e of
        Left  a
x -> [(String, Value)] -> Value
ValueStruct [(String
"tag", Bool -> Value
forall a. XmlRpcType a => a -> Value
toValue Bool
False ), (String
"left" , a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
x)]
        Right b
y -> [(String, Value)] -> Value
ValueStruct [(String
"tag", Bool -> Value
forall a. XmlRpcType a => a -> Value
toValue Bool
True ), (String
"right", b -> Value
forall a. XmlRpcType a => a -> Value
toValue b
y)]
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m (Either a b)
fromValue ( ValueStruct [(String, Value)]
v ) = String -> [(String, Value)] -> ExceptT String m Bool
forall {m :: * -> *} {b}.
(MonadFail m, XmlRpcType b) =>
String -> [(String, Value)] -> ExceptT String m b
getField' String
"tag" [(String, Value)]
v ExceptT String m Bool
-> (Bool -> ExceptT String m (Either a b))
-> ExceptT String m (Either a b)
forall a b.
ExceptT String m a
-> (a -> ExceptT String m b) -> ExceptT String m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \  case
      Bool
False -> a -> Either a b
forall a b. a -> Either a b
Left  (a -> Either a b)
-> ExceptT String m a -> ExceptT String m (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [(String, Value)] -> ExceptT String m a
forall {m :: * -> *} {b}.
(MonadFail m, XmlRpcType b) =>
String -> [(String, Value)] -> ExceptT String m b
getField' String
"left" [(String, Value)]
v
      Bool
True  -> b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b)
-> ExceptT String m b -> ExceptT String m (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [(String, Value)] -> ExceptT String m b
forall {m :: * -> *} {b}.
(MonadFail m, XmlRpcType b) =>
String -> [(String, Value)] -> ExceptT String m b
getField' String
"right" [(String, Value)]
v