haxr 3000.0.0 → 3000.0.1

raw patch · 4 files changed

+40/−28 lines, 4 filesdep +arraydep +old-localedep +old-timedep ~base

Dependencies added: array, old-locale, old-time

Dependency ranges changed: base

Files

• Network/XmlRpc/DTD_XMLRPC.hs +1/−1
• Network/XmlRpc/Internals.hs +14/−18
• Network/XmlRpc/Server.hs +10/−3
• haxr.cabal +15/−6

@@ -3,7 +3,7 @@ import Text.XML.HaXml.Xml2Haskell import Text.XML.HaXml.OneOfN import Data.Char (isSpace)-import Prelude (all, concatMap, (++), maybe)+import Prelude hiding (String, Int, Double) import qualified Prelude  

@@ -210,17 +210,21 @@     fromValue :: Monad m => Value -> Err m a     getType :: a -> Type -typeError :: Monad m => Type -> Value -> Err m a-typeError t v = fail ("Wanted: "  -		     -- ++ show (getType t)-		      ++ "', got: '" -		      ++ showXml (toXRValue v) ++ "'")+typeError :: (XmlRpcType a, Monad m) => Value -> Err m a+typeError v = withType $ \t ->+       fail ("Wanted: "  +	     ++ show (getType t)+	     ++ "', got: '" +	     ++ showXml (toXRValue v) ++ "'") `asTypeOf` return t +-- a type hack for use in 'typeError'+withType :: (a -> Err m a) -> Err m a+withType f = f undefined  simpleFromValue :: (Monad m, XmlRpcType a) => (Value -> Maybe a)  		-> Value -> Err m a simpleFromValue f v = -    maybe (typeError (getType (fromJust (f v))) v) return (f v)+    maybe (typeError v) return (f v)   -- | Exists to allow explicit type conversions.@@ -272,14 +276,8 @@ instance XmlRpcType a => XmlRpcType [a] where     toValue = ValueArray . map toValue      fromValue v = case v of-			 ValueArray _ -> r-			 -- FIXME: I am using TArray here because for-			 -- some reason Hugs Nov 2003 requires a XmlRpcRpc [a]-			 -- constraint on fromValue (which is not -			 -- legal haskell) to do (getType t) here.-			 _ -> r >>= \t -> typeError TArray v-	where ValueArray xs = v-	      r = mapM fromValue xs+			 ValueArray xs -> mapM fromValue xs+			 _ -> typeError v     getType _ = TArray  -- FIXME: struct elements may have different types@@ -287,10 +285,8 @@     toValue xs = ValueStruct [(n, toValue v) | (n,v) <- xs]      fromValue v = case v of-		  ValueStruct _ -> r-		  _ -> r >>= \t -> typeError (getType t) v-	where ValueStruct xs = v-	      r = mapM (\ (n,v) -> liftM ((,) n) (fromValue v)) xs+		  ValueStruct xs -> mapM (\ (n,v) -> liftM ((,) n) (fromValue v)) xs+		  _ -> typeError v     getType _ = TStruct  -- | Get a field value from a (possibly heterogeneous) struct.

@@ -74,15 +74,22 @@ 			      v <- handleIO x 			      return (Return (toValue v))     toFun _ _ = fail "Too many arguments"-    sig (_::IO a) = ([], getType (undefined::a))+    sig x = ([], getType (mType x))  instance (XmlRpcType a, XmlRpcFun b) => XmlRpcFun (a -> b) where     toFun f (MethodCall n (x:xs)) = do 				  v <- fromValue x 				  toFun (f v) (MethodCall n xs)     toFun _ _ = fail "Too few arguments"-    sig (f::a->b) = let (as, r) = sig (undefined::b) -			in (getType (undefined::a) : as, r)+    sig f = let (a,b) = funType f+                (as, r) = sig b+             in (getType a : as, r)++mType :: m a -> a+mType _ = undefined++funType :: (a -> b) -> (a, b)+funType _ = (undefined, undefined)  -- FIXME: always returns error code 0 errorToResponse :: ServerResult -> IO MethodResponse

@@ -1,7 +1,8 @@ Name: haxr-Version: 3000.0.0+Version: 3000.0.1+Cabal-version: >=1.2+Build-type: Simple Copyright: Bjorn Bringert, 2003-2006-Build-depends: base, mtl, network, HaXml >= 1.13 && < 1.14, HTTP >= 1.0 License: BSD4 License-file: LICENSE Author: Bjorn Bringert <bjorn@bringert.net>@@ -11,13 +12,21 @@ Description:         HaXR is a library for writing XML-RPC          client and server applications in Haskell.-Exposed-Modules:++Flag split-base++Library+  Build-depends: mtl, network, HaXml >= 1.13 && < 1.14, HTTP >= 1.0+  if flag(split-base)+    Build-depends: base >= 3.0, array, old-time, old-locale+  else+    Build-depends: base < 3.0+  Exposed-Modules:         Network.XmlRpc.Client,         Network.XmlRpc.Server,         Network.XmlRpc.Internals,         Network.XmlRpc.Introspect-Other-Modules:+  Other-Modules:         Network.XmlRpc.Base64,         Network.XmlRpc.DTD_XMLRPC-Extensions: OverlappingInstances, TypeSynonymInstances-GHC-options: -O2+  Extensions: OverlappingInstances, TypeSynonymInstances, FlexibleInstances