summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBrentYorgey <>2019-01-19 23:04:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-01-19 23:04:00 (GMT)
commit3a30b4f190e87ab3eb7dcb29c65aa0515bd71a58 (patch)
tree9bdbfdcf6b4b339ecccd4615d8db995e780b8a22
parent92ccd7cbeb8cf62774c33ff49ccca2af0e36dbf0 (diff)
version 3000.11.3HEAD3000.11.3master
-rwxr-xr-x[-rw-r--r--]CHANGES0
-rw-r--r--Network/XmlRpc/Internals.hs33
-rw-r--r--Network/XmlRpc/Pretty.hs125
-rwxr-xr-x[-rw-r--r--]examples/Makefile0
-rwxr-xr-x[-rw-r--r--]examples/Person.hs0
-rwxr-xr-x[-rw-r--r--]examples/PersonTH.hs0
-rwxr-xr-x[-rw-r--r--]examples/make-stubs.hs0
-rwxr-xr-x[-rw-r--r--]examples/parse_response.hs0
-rwxr-xr-x[-rw-r--r--]examples/person_client.hs0
-rwxr-xr-x[-rw-r--r--]examples/person_server.hs0
-rwxr-xr-x[-rw-r--r--]examples/raw_call.hs0
-rwxr-xr-x[-rw-r--r--]examples/simple_client.hs0
-rwxr-xr-x[-rw-r--r--]examples/simple_server.hs0
-rwxr-xr-x[-rw-r--r--]examples/test_client.hs0
-rwxr-xr-x[-rw-r--r--]examples/test_server.hs0
-rwxr-xr-x[-rw-r--r--]examples/time-xmlrpc-com.hs0
-rwxr-xr-x[-rw-r--r--]examples/validate.hs0
-rw-r--r--haxr.cabal8
18 files changed, 94 insertions, 72 deletions
diff --git a/CHANGES b/CHANGES
index a8f95fb..a8f95fb 100644..100755
--- a/CHANGES
+++ b/CHANGES
diff --git a/Network/XmlRpc/Internals.hs b/Network/XmlRpc/Internals.hs
index f524c8f..af44946 100644
--- 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 @@ Err, maybeToM, handleError, ioErrorToErr
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 @@ replace ys zs xs@(x:xs')
| 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 :: IO a -> Err IO a
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 @@ instance Read Type where
("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 @@ instance XmlRpcType Bool where
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 @@ instance XmlRpcType CalendarTime where
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 @@ instance XmlRpcType a => XmlRpcType [a] where
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 @@ instance (XmlRpcType a, XmlRpcType b) => XmlRpcType (a,b) where
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 @@ readDateTime dt =
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 :: Monad m => XR.MethodCall -> Err m MethodCall
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 @@ parseCall c =
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
index 3f188e0..40c949b 100644
--- 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,17 +51,21 @@ fromLBS = MBuilder . Just . fromLazyByteString
-- 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
@@ -69,7 +80,7 @@ infixr 5 $$
-- 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 @@ intercalate sep = aux . filter (not . null)
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 :: (a -> MBuilder) -> [a] -> MBuilder
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 @@ text = MBuilder . Just . fromString
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 @@ attribute :: Attribute -> MBuilder
-- |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 @@ xmldecl (XMLDecl v e sd) = "<?xml version='" <> text v <> "'" <+>
maybe encodingdecl e <+>
maybe sddecl sd <+> "?>"
-misc (Comment s) = "<!--" <+> text s <+> "-->"
-misc (PI (n,s)) = "<?" <> text n <+> text s <+> "?>"
+misc (Comment s) = "<!--" <+> text s <+> "-->"
+misc (PI (n,s)) = "<?" <> text n <+> text s <+> "?>"
sddecl sd | sd = "standalone='yes'"
| otherwise = "standalone='no'"
@@ -171,14 +182,14 @@ doctypedeclB (DTD n eid ds) = if P.null ds then hd <> ">"
else hd <+> " [" $$ vcatMap markupdecl ds $$ "]>"
where hd = "<!DOCTYPE" <+> 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 PCDATA = "(#PCDATA)"
mixed (PCDATAplus ns) = "(#PCDATA |" <+> intercalate "|" (map name ns) <> ")*"
attlistdecl :: AttListDecl -> MBuilder
-attlistdecl (AttListDecl n ds) = "<!ATTLIST" <+> name n <+>
+attlistdecl (AttListDecl n ds) = "<!ATTLIST" <+> 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 :: [[Char]] -> MBuilder
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 :: (Show a) => a -> MBuilder
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) = "<!ENTITY" <+> text n <+> entitydef ed <> ">"
@@ -283,12 +294,12 @@ entitydef (DefEntityValue ew) = entityvalue ew
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 @@ entityvalue (EntityValue evs)
| 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)
@@ -338,4 +349,4 @@ cdsect c = "<![CDATA[" <> chardata c <> "]]>"
containsDoubleQuote :: [EV] -> Bool
containsDoubleQuote evs = any csq evs
where csq (EVString s) = '"' `elem` BU.fromString s
- csq _ = False \ No newline at end of file
+ csq _ = False
diff --git a/examples/Makefile b/examples/Makefile
index c9413bf..c9413bf 100644..100755
--- a/examples/Makefile
+++ b/examples/Makefile
diff --git a/examples/Person.hs b/examples/Person.hs
index 5c1e9b3..5c1e9b3 100644..100755
--- a/examples/Person.hs
+++ b/examples/Person.hs
diff --git a/examples/PersonTH.hs b/examples/PersonTH.hs
index 87ce650..87ce650 100644..100755
--- a/examples/PersonTH.hs
+++ b/examples/PersonTH.hs
diff --git a/examples/make-stubs.hs b/examples/make-stubs.hs
index 84d4f69..84d4f69 100644..100755
--- a/examples/make-stubs.hs
+++ b/examples/make-stubs.hs
diff --git a/examples/parse_response.hs b/examples/parse_response.hs
index 6715f37..6715f37 100644..100755
--- a/examples/parse_response.hs
+++ b/examples/parse_response.hs
diff --git a/examples/person_client.hs b/examples/person_client.hs
index 37465a8..37465a8 100644..100755
--- a/examples/person_client.hs
+++ b/examples/person_client.hs
diff --git a/examples/person_server.hs b/examples/person_server.hs
index 6786b44..6786b44 100644..100755
--- a/examples/person_server.hs
+++ b/examples/person_server.hs
diff --git a/examples/raw_call.hs b/examples/raw_call.hs
index fbc1777..fbc1777 100644..100755
--- a/examples/raw_call.hs
+++ b/examples/raw_call.hs
diff --git a/examples/simple_client.hs b/examples/simple_client.hs
index 646be2c..646be2c 100644..100755
--- a/examples/simple_client.hs
+++ b/examples/simple_client.hs
diff --git a/examples/simple_server.hs b/examples/simple_server.hs
index 6f3f99b..6f3f99b 100644..100755
--- a/examples/simple_server.hs
+++ b/examples/simple_server.hs
diff --git a/examples/test_client.hs b/examples/test_client.hs
index 16c42a7..16c42a7 100644..100755
--- a/examples/test_client.hs
+++ b/examples/test_client.hs
diff --git a/examples/test_server.hs b/examples/test_server.hs
index d1f2d9f..d1f2d9f 100644..100755
--- a/examples/test_server.hs
+++ b/examples/test_server.hs
diff --git a/examples/time-xmlrpc-com.hs b/examples/time-xmlrpc-com.hs
index 38925f8..38925f8 100644..100755
--- a/examples/time-xmlrpc-com.hs
+++ b/examples/time-xmlrpc-com.hs
diff --git a/examples/validate.hs b/examples/validate.hs
index 3eb9b66..3eb9b66 100644..100755
--- a/examples/validate.hs
+++ b/examples/validate.hs
diff --git a/haxr.cabal b/haxr.cabal
index 52952d9..4270f3c 100644
--- 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 @@ Extra-Source-Files:
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 @@ flag network-uri
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 @@ Library
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