haxr 3000.11.2 → 3000.11.3
raw patch · 3 files changed
+93/−71 lines, 3 filesdep ~basedep ~base-compatdep ~network
Dependency ranges changed: base, base-compat, network
Files
- Network/XmlRpc/Internals.hs +22/−11
- Network/XmlRpc/Pretty.hs +67/−56
- haxr.cabal +4/−4
Network/XmlRpc/Internals.hs view
@@ -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)
Network/XmlRpc/Pretty.hs view
@@ -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) = "<!--" <+> 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 @@ 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 (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 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) = "<!ENTITY" <+> 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)
haxr.cabal view
@@ -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