diff --git a/Network/XmlRpc/Internals.hs b/Network/XmlRpc/Internals.hs --- a/Network/XmlRpc/Internals.hs +++ b/Network/XmlRpc/Internals.hs @@ -18,6 +18,15 @@ -- ----------------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif + module Network.XmlRpc.Internals ( -- * Method calls and repsonses MethodCall(..), MethodResponse(..), @@ -40,6 +49,8 @@ import Control.Exception import Control.Monad import Control.Monad.Except +import qualified Control.Monad.Fail as Fail +import Control.Monad.Fail (MonadFail) import Data.Char import Data.List import Data.Maybe @@ -84,11 +95,11 @@ | otherwise = x : replace ys zs xs' -- | Convert a 'Maybe' value to a value in any monad -maybeToM :: Monad m => +maybeToM :: MonadFail m => String -- ^ Error message to fail with for 'Nothing' -> Maybe a -- ^ The 'Maybe' value. -> m a -- ^ The resulting value in the monad. -maybeToM err Nothing = fail err +maybeToM err Nothing = Fail.fail err maybeToM _ (Just x) = return x -- | Convert a 'Maybe' value to a value in any monad @@ -120,7 +131,7 @@ ioErrorToErr x = (liftIO x >>= return) `catchError` \e -> throwError (show e) -- | Handle errors from the error monad. -handleError :: Monad m => (String -> m a) -> Err m a -> m a +handleError :: MonadFail m => (String -> m a) -> Err m a -> m a handleError h m = do Right x <- runExceptT (catchError m (lift . h)) return x @@ -197,7 +208,7 @@ ("array",r) -> [(TArray,r)] -- | Gets the value of a struct member -structGetValue :: Monad m => String -> Value -> Err m Value +structGetValue :: MonadFail m => String -> Value -> Err m Value structGetValue n (ValueStruct t) = maybeToM ("Unknown member '" ++ n ++ "'") (lookup n t) structGetValue _ _ = fail "Value is not a struct" @@ -269,7 +280,7 @@ f _ = Nothing getType _ = TBool -instance XmlRpcType String where +instance OVERLAPPING_ XmlRpcType String where toValue = ValueString fromValue = simpleFromValue f where f (ValueString x) = Just x @@ -309,7 +320,7 @@ getType _ = TDateTime -- FIXME: array elements may have different types -instance XmlRpcType a => XmlRpcType [a] where +instance OVERLAPPABLE_ XmlRpcType a => XmlRpcType [a] where toValue = ValueArray . map toValue fromValue v = case v of ValueArray xs -> mapM fromValue xs @@ -317,7 +328,7 @@ getType _ = TArray -- FIXME: struct elements may have different types -instance XmlRpcType a => XmlRpcType [(String,a)] where +instance OVERLAPPING_ XmlRpcType a => XmlRpcType [(String,a)] where toValue xs = ValueStruct [(n, toValue v) | (n,v) <- xs] fromValue v = case v of @@ -359,7 +370,7 @@ getType _ = TArray -- | Get a field value from a (possibly heterogeneous) struct. -getField :: (Monad m, XmlRpcType a) => +getField :: (MonadFail m, XmlRpcType a) => String -- ^ Field name -> [(String,Value)] -- ^ Struct -> Err m a @@ -519,7 +530,7 @@ maybe (fail $ "Error parsing dateTime '" ++ dt ++ "'") return - (parseTime defaultTimeLocale xmlRpcDateFormat dt) + (parseTimeM True defaultTimeLocale xmlRpcDateFormat dt) localTimeToCalendarTime :: LocalTime -> CalendarTime localTimeToCalendarTime l = @@ -562,7 +573,7 @@ fromXRMethodCall (XR.MethodCall (XR.MethodName name) params) = liftM (MethodCall name) (fromXRParams (fromMaybe (XR.Params []) params)) -fromXRMethodResponse :: Monad m => XR.MethodResponse -> Err m MethodResponse +fromXRMethodResponse :: MonadFail m => XR.MethodResponse -> Err m MethodResponse fromXRMethodResponse (XR.MethodResponseParams xps) = liftM Return (fromXRParams xps >>= onlyOneResult) fromXRMethodResponse (XR.MethodResponseFault (XR.Fault v)) = @@ -587,7 +598,7 @@ fromXRMethodCall xc -- | Parses a method response from XML. -parseResponse :: (Show e, MonadError e m) => String -> Err m MethodResponse +parseResponse :: (Show e, MonadError e m, MonadFail m) => String -> Err m MethodResponse parseResponse c = do mxr <- errorToErr (readXml c) diff --git a/Network/XmlRpc/Pretty.hs b/Network/XmlRpc/Pretty.hs --- a/Network/XmlRpc/Pretty.hs +++ b/Network/XmlRpc/Pretty.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} -- | This is a fast non-pretty-printer for turning the internal representation -- of generic structured XML documents into Lazy ByteStrings. @@ -6,26 +8,31 @@ -- Text.Xml.HaXml.Types, so you can pretty-print as much or as little -- of the document as you wish. -module Network.XmlRpc.Pretty (document, content, element, +module Network.XmlRpc.Pretty (document, content, element, doctypedecl, prolog, cp) where -import Prelude hiding (maybe, elem, concat, null, head) -import qualified Prelude as P -import Data.ByteString.Lazy.Char8 (ByteString(), elem, empty) -import qualified Data.ByteString.Lazy.UTF8 as BU -import Text.XML.HaXml.Types -import Blaze.ByteString.Builder (Builder, fromLazyByteString, toLazyByteString) -import Blaze.ByteString.Builder.Char.Utf8 (fromString) -import Data.Maybe (isNothing) -import Data.Monoid (Monoid, mempty, mconcat, mappend) -import qualified GHC.Exts as Ext +import Blaze.ByteString.Builder (Builder, + fromLazyByteString, + toLazyByteString) +import Blaze.ByteString.Builder.Char.Utf8 (fromString) +import Data.ByteString.Lazy.Char8 (ByteString, elem, empty) +import qualified Data.ByteString.Lazy.UTF8 as BU +import Data.Maybe (isNothing) +import Data.Monoid (Monoid, mappend, mconcat, + mempty) +import Data.Semigroup (Semigroup) +import qualified GHC.Exts as Ext +import Prelude hiding (concat, elem, head, + maybe, null) +import qualified Prelude as P +import Text.XML.HaXml.Types -- |A 'Builder' with a recognizable empty value. -newtype MBuilder = MBuilder { unMB :: Maybe Builder } deriving Monoid +newtype MBuilder = MBuilder { unMB :: Maybe Builder } deriving (Semigroup, Monoid) -- |'Maybe' eliminator specialized for 'MBuilder'. maybe :: (t -> MBuilder) -> Maybe t -> MBuilder -maybe _ Nothing = mempty +maybe _ Nothing = mempty maybe f (Just x) = f x -- |Nullity predicate for 'MBuilder'. @@ -44,18 +51,22 @@ -- syntax. instance Ext.IsString MBuilder where fromString "" = mempty - fromString s = MBuilder . Just . fromString $ s + fromString s = MBuilder . Just . fromString $ s --- A simple implementation of the pretty-printing combinator interface, --- but for plain ByteStrings: +-- Only define <> as mappend if not already provided in Prelude +#if !MIN_VERSION_base(4,11,0) infixr 6 <> -infixr 6 <+> -infixr 5 $$ -- |Beside. (<>) :: MBuilder -> MBuilder -> MBuilder (<>) = mappend +#endif +-- A simple implementation of the pretty-printing combinator interface, +-- but for plain ByteStrings: +infixr 6 <+> +infixr 5 $$ + -- |Concatenate two 'MBuilder's with a single space in between -- them. If either of the component 'MBuilder's is empty, then the -- other is returned without any additional space. @@ -69,7 +80,7 @@ -- them. If either of the component 'MBuilder's is empty, then the -- other is returned without any additional newline. ($$) :: MBuilder -> MBuilder -> MBuilder -($$) b1 b2 +($$) b1 b2 | null b2 = b1 | null b1 = b2 | otherwise = b1 <> "\n" <> b2 @@ -82,7 +93,7 @@ aux (x:xs) = x <> mconcat (map (sep <>) xs) -- |List version of '<+>'. -hsep :: [MBuilder] -> MBuilder +hsep :: [MBuilder] -> MBuilder hsep = intercalate " " -- |List version of '$$'. @@ -96,7 +107,7 @@ vcatMap = (vcat .) . map -- |``Paragraph fill'' version of 'sep'. -fsep :: [MBuilder] -> MBuilder +fsep :: [MBuilder] -> MBuilder fsep = hsep -- |Bracket an 'MBuilder' with parentheses. @@ -109,7 +120,7 @@ name :: QName -> MBuilder name = MBuilder . Just . fromString . unQ where unQ (QN (Namespace prefix uri) n) = prefix++":"++n - unQ (N n) = n + unQ (N n) = n ---- -- Now for the XML pretty-printing interface. @@ -140,7 +151,7 @@ -- |Run an 'MBuilder' to generate a 'ByteString'. runMBuilder :: MBuilder -> ByteString runMBuilder = aux . unMB - where aux Nothing = empty + where aux Nothing = empty aux (Just b) = toLazyByteString b document = runMBuilder . documentB @@ -161,8 +172,8 @@ maybe encodingdecl e <+> maybe sddecl sd <+> "?>" -misc (Comment s) = "" -misc (PI (n,s)) = " text n <+> text s <+> "?>" +misc (Comment s) = "" +misc (PI (n,s)) = " text n <+> text s <+> "?>" sddecl sd | sd = "standalone='yes'" | otherwise = "standalone='no'" @@ -171,14 +182,14 @@ else hd <+> " [" $$ vcatMap markupdecl ds $$ "]>" where hd = " name n <+> maybe externalid eid -markupdecl (Element e) = elementdecl e -markupdecl (AttList a) = attlistdecl a -markupdecl (Entity e) = entitydecl e -markupdecl (Notation n) = notationdecl n -markupdecl (MarkupMisc m) = misc m +markupdecl (Element e) = elementdecl e +markupdecl (AttList a) = attlistdecl a +markupdecl (Entity e) = entitydecl e +markupdecl (Notation n) = notationdecl n +markupdecl (MarkupMisc m) = misc m elementB (Elem n as []) = "<" <> (name n <+> fsep (map attribute as)) <> "/>" -elementB (Elem n as cs) +elementB (Elem n as cs) | isText (P.head cs) = "<" <> (name n <+> fsep (map attribute as)) <> ">" <> hcatMap contentB cs <> " name n <> ">" | otherwise = "<" <> (name n <+> fsep (map attribute as)) <> ">" <> @@ -222,25 +233,25 @@ mixed (PCDATAplus ns) = "(#PCDATA |" <+> intercalate "|" (map name ns) <> ")*" attlistdecl :: AttListDecl -> MBuilder -attlistdecl (AttListDecl n ds) = " name n <+> +attlistdecl (AttListDecl n ds) = " name n <+> fsep (map attdef ds) <> ">" attdef :: AttDef -> MBuilder attdef (AttDef n t d) = name n <+> atttype t <+> defaultdecl d atttype :: AttType -> MBuilder -atttype StringType = "CDATA" -atttype (TokenizedType t) = tokenizedtype t -atttype (EnumeratedType t) = enumeratedtype t +atttype StringType = "CDATA" +atttype (TokenizedType t) = tokenizedtype t +atttype (EnumeratedType t) = enumeratedtype t tokenizedtype :: TokenizedType -> MBuilder -tokenizedtype ID = "ID" -tokenizedtype IDREF = "IDREF" -tokenizedtype IDREFS = "IDREFS" -tokenizedtype ENTITY = "ENTITY" -tokenizedtype ENTITIES = "ENTITIES" -tokenizedtype NMTOKEN = "NMTOKEN" -tokenizedtype NMTOKENS = "NMTOKENS" +tokenizedtype ID = "ID" +tokenizedtype IDREF = "IDREF" +tokenizedtype IDREFS = "IDREFS" +tokenizedtype ENTITY = "ENTITY" +tokenizedtype ENTITIES = "ENTITIES" +tokenizedtype NMTOKEN = "NMTOKEN" +tokenizedtype NMTOKENS = "NMTOKENS" enumeratedtype :: EnumeratedType -> MBuilder enumeratedtype (NotationType n) = notationtype n @@ -254,13 +265,13 @@ enumeration ns = parens (intercalate "|" (map nmtoken ns)) defaultdecl :: DefaultDecl -> MBuilder -defaultdecl REQUIRED = "#REQUIRED" -defaultdecl IMPLIED = "#IMPLIED" -defaultdecl (DefaultTo a f) = maybe (const "#FIXED") f <+> attvalue a +defaultdecl REQUIRED = "#REQUIRED" +defaultdecl IMPLIED = "#IMPLIED" +defaultdecl (DefaultTo a f) = maybe (const "#FIXED") f <+> attvalue a reference :: Reference -> MBuilder -reference (RefEntity er) = entityref er -reference (RefChar cr) = charref cr +reference (RefEntity er) = entityref er +reference (RefChar cr) = charref cr entityref :: [Char] -> MBuilder entityref n = "&" <> text n <> ";" @@ -269,8 +280,8 @@ charref c = "&#" <> text (show c) <> ";" entitydecl :: EntityDecl -> MBuilder -entitydecl (EntityGEDecl d) = gedecl d -entitydecl (EntityPEDecl d) = pedecl d +entitydecl (EntityGEDecl d) = gedecl d +entitydecl (EntityPEDecl d) = pedecl d gedecl :: GEDecl -> MBuilder gedecl (GEDecl n ed) = " text n <+> entitydef ed <> ">" @@ -283,12 +294,12 @@ entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd pedef :: PEDef -> MBuilder -pedef (PEDefEntityValue ew) = entityvalue ew -pedef (PEDefExternalID eid) = externalid eid +pedef (PEDefEntityValue ew) = entityvalue ew +pedef (PEDefExternalID eid) = externalid eid externalid :: ExternalID -> MBuilder -externalid (SYSTEM sl) = "SYSTEM" <+> systemliteral sl -externalid (PUBLIC i sl) = "PUBLIC" <+> pubidliteral i <+> systemliteral sl +externalid (SYSTEM sl) = "SYSTEM" <+> systemliteral sl +externalid (PUBLIC i sl) = "PUBLIC" <+> pubidliteral i <+> systemliteral sl ndatadecl :: NDataDecl -> MBuilder ndatadecl (NDATA n) = "NDATA" <+> text n @@ -316,8 +327,8 @@ | otherwise = "\"" <> hcatMap ev evs <> "\"" ev :: EV -> MBuilder -ev (EVString s) = text s -ev (EVRef r) = reference r +ev (EVString s) = text s +ev (EVRef r) = reference r pubidliteral :: PubidLiteral -> MBuilder pubidliteral (PubidLiteral s) diff --git a/haxr.cabal b/haxr.cabal --- a/haxr.cabal +++ b/haxr.cabal @@ -1,5 +1,5 @@ Name: haxr -Version: 3000.11.2 +Version: 3000.11.3 Cabal-version: >=1.10 Build-type: Simple Copyright: Bjorn Bringert, 2003-2006 @@ -22,7 +22,7 @@ examples/test_client.hs examples/test_server.hs examples/time-xmlrpc-com.hs examples/validate.hs examples/Makefile Bug-reports: https://github.com/byorgey/haxr/issues -Tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +Tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 Source-repository head type: git @@ -33,7 +33,7 @@ default: True Library - Build-depends: base < 5, + Build-depends: base >= 4.9 && < 4.13, base-compat >= 0.8 && < 0.10, mtl, mtl-compat, @@ -70,6 +70,6 @@ Network.XmlRpc.DTD_XMLRPC Other-Modules: Network.XmlRpc.Base64 - Default-extensions: OverlappingInstances, TypeSynonymInstances, FlexibleInstances + Default-extensions: TypeSynonymInstances, FlexibleInstances Other-extensions: OverloadedStrings, GeneralizedNewtypeDeriving, TemplateHaskell Default-language: Haskell2010