dbus-core 0.8.1 → 0.8.2
raw patch · 6 files changed
+156/−53 lines, 6 filesdep +monads-tfdep +transformersdep −mtldep ~HaXmldep ~QuickCheckdep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: monads-tf, transformers
Dependencies removed: mtl
Dependency ranges changed: HaXml, QuickCheck, base, binary, bytestring, containers, data-binary-ieee754, network, parsec, pretty, test-framework, test-framework-quickcheck2, text, unix
API changes (from Hackage documentation)
Files
- Makefile +5/−1
- dbus-core.cabal +20/−18
- dbus-core.nw +62/−17
- hs/DBus/Util/MonadError.hs +57/−0
- hs/DBus/Wire/Marshal.hs +4/−7
- hs/DBus/Wire/Unmarshal.hs +8/−10
Makefile view
@@ -11,6 +11,7 @@ hs/DBus/NameReservation.hs \ hs/DBus/Types.hs \ hs/DBus/Util.hs \+ hs/DBus/Util/MonadError.hs \ hs/DBus/UUID.hs \ hs/DBus/Wire.hs \ hs/DBus/Wire/Internal.hs \@@ -24,7 +25,7 @@ %.tex: %.nw noweave -delay "$<" | cpif "$@" -hs/%.hs: dbus-core.nw hs/DBus/Message hs/DBus/Wire+hs/%.hs: dbus-core.nw hs/DBus/Message hs/DBus/Wire hs/DBus/Util notangle -R"$*.hs" "$<" | cpphs --hashes --noline | cpif "$@" hs/Tests.hs: Tests.nw hs@@ -41,6 +42,9 @@ hs/DBus/Wire: mkdir -p hs/DBus/Wire++hs/DBus/Util:+ mkdir -p hs/DBus/Util %.pdf: %.tex xelatex "$<"
dbus-core.cabal view
@@ -1,5 +1,5 @@ name: dbus-core-version: 0.8.1+version: 0.8.2 synopsis: Low-level D-Bus protocol implementation license: GPL-3 license-file: License.txt@@ -11,7 +11,7 @@ stability: experimental bug-reports: mailto:jmillikin@gmail.com homepage: http://ianen.org/haskell/dbus/-tested-with: GHC==6.10.4+tested-with: GHC==6.10.4, GHC==6.12.1 extra-source-files: dbus-core.nw@@ -30,22 +30,23 @@ default: False library- ghc-options: -Wall+ ghc-options: -Wall -fno-warn-unused-do-bind hs-source-dirs: hs build-depends:- base >=4 && < 5- , parsec >= 3.0.0- , binary- , bytestring- , data-binary-ieee754 >= 0.3- , HaXml >= 1.19.7- , pretty- , text- , mtl- , containers- , unix- , network+ base >=4.0 && < 5.0+ , parsec >= 3.0 && < 4+ , binary >= 0.4 && < 0.6+ , bytestring >= 0.9 && < 0.10+ , data-binary-ieee754 >= 0.3 && < 0.5+ , HaXml >= 1.20 && < 1.21+ , pretty >= 1.0 && < 1.1+ , text >= 0.7 && < 0.8+ , transformers >= 0.2 && < 0.3+ , monads-tf >= 0.1 && < 0.2+ , containers >= 0.1 && < 0.4+ , unix >= 2.2 && < 2.5+ , network >= 2.2 && < 2.3 exposed-modules: DBus.Address@@ -68,6 +69,7 @@ DBus.Wire.Unmarshal DBus.Wire.Unicode DBus.Util+ DBus.Util.MonadError executable dbus-core-tests main-is: Tests.hs@@ -75,9 +77,9 @@ if flag(test) build-depends:- QuickCheck >= 2- , test-framework- , test-framework-quickcheck2+ QuickCheck >= 2.1 && < 2.2+ , test-framework >= 0.2 && < 0.3+ , test-framework-quickcheck2 >= 0.2 && < 0.3 else buildable: False
dbus-core.nw view
@@ -1326,7 +1326,7 @@ <<DBus/Wire/Marshal.hs>>= <<copyright>>-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} module DBus.Wire.Marshal where <<text imports>> <<marshal imports>>@@ -1340,14 +1340,13 @@ <<marshal imports>>= import qualified Control.Monad.State as State-import qualified Control.Monad.Error as E+import qualified DBus.Util.MonadError as E import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Builder as B <<DBus/Wire/Marshal.hs>>= data MarshalState = MarshalState Endianness B.Builder !Word64-newtype MarshalM a = MarshalM (E.ErrorT MarshalError (State.State MarshalState) a)- deriving (Monad, E.MonadError MarshalError, State.MonadState MarshalState)+type MarshalM = E.ErrorT MarshalError (State.State MarshalState) type Marshal = MarshalM () @ Clients can perform marshaling via {\tt marshal} and {\tt runMarshal},@@ -1355,7 +1354,7 @@ <<DBus/Wire/Marshal.hs>>= runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString-runMarshal (MarshalM m) e = case State.runState (E.runErrorT m) initialState of+runMarshal m e = case State.runState (E.runErrorT m) initialState of (Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder) (Left x, _) -> Left x where initialState = MarshalState e B.empty 0@@ -1434,8 +1433,6 @@ show (InvalidText x) = concat ["Text cannot be marshaled: ", show x] -instance E.Error MarshalError- <<wire exports>>= , MarshalError (..) @@ -1446,11 +1443,11 @@ <<DBus/Wire/Unmarshal.hs>>= <<copyright>> <<text extensions>>-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} module DBus.Wire.Unmarshal where <<text imports>> <<unmarshal imports>>-import Control.Monad (when, unless)+import Control.Monad (when, unless, liftM) import Data.Maybe (fromJust, listToMaybe, fromMaybe) import Data.Word (Word8, Word32, Word64) import Data.Int (Int16, Int32, Int64)@@ -1460,17 +1457,17 @@ <<unmarshal imports>>= import qualified Control.Monad.State as State-import qualified Control.Monad.Error as E+import Control.Monad.Trans.Class (lift)+import qualified DBus.Util.MonadError as E import qualified Data.ByteString.Lazy as L <<DBus/Wire/Unmarshal.hs>>= data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64-newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (State.State UnmarshalState) a)- deriving (Monad, Functor, E.MonadError UnmarshalError, State.MonadState UnmarshalState)+type Unmarshal = E.ErrorT UnmarshalError (State.State UnmarshalState) <<DBus/Wire/Unmarshal.hs>>= runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a-runUnmarshal (Unmarshal m) e bytes = State.evalState (E.runErrorT m) state where+runUnmarshal m e bytes = State.evalState (E.runErrorT m) state where state = UnmarshalState e bytes 0 <<DBus/Wire/Unmarshal.hs>>=@@ -1594,8 +1591,6 @@ ["Missing NUL terminator at position ", show pos] show ArraySizeMismatch = "Array size mismatch" -instance E.Error UnmarshalError- <<wire exports>>= , UnmarshalError (..) @@ -2083,7 +2078,7 @@ unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do- let getBytes = E.lift . getBytes'+ let getBytes = lift . getBytes' <<read fixed-length header>> <<read full header>>@@ -2148,7 +2143,7 @@ <<read full header>>= let fieldArray = fromJust . T.fromVariant $ header !! 6 let fieldStructures = fromJust . T.fromArray $ fieldArray-fields <- concat `fmap` mapM decodeField fieldStructures+fields <- concat `liftM` mapM decodeField fieldStructures @ The body is always aligned to 8 bytes, so pull out the padding before unmarshaling it.@@ -3926,6 +3921,56 @@ -- | Drop /n/ items from the end of a list dropEnd :: Int -> [a] -> [a] dropEnd n xs = take (length xs - n) xs++@+\section{Bundled MonadError variant}++The default {\tt ErrorT} and {\tt MonadError} classes in the+{\tt transformers} package have an idiotic dependency on the {\tt Error}+class, which is used to implement the obsolete {\tt fail} function. This+module is a variant, which doesn't include this dependency.++<<DBus/Util/MonadError.hs>>=+<<copyright>>+{-# LANGUAGE TypeFamilies #-}+module DBus.Util.MonadError where+import Control.Monad.Trans.Class+import Control.Monad.State++newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }++instance Functor m => Functor (ErrorT e m) where+ fmap f = ErrorT . fmap (fmap f) . runErrorT++instance Monad m => Monad (ErrorT e m) where+ return = ErrorT . return . Right+ (>>=) m k = ErrorT $ do+ x <- runErrorT m+ case x of+ Left l -> return $ Left l+ Right r -> runErrorT $ k r++instance MonadTrans (ErrorT e) where+ lift = ErrorT . liftM Right++class Monad m => MonadError m where+ type ErrorType m+ throwError :: ErrorType m -> m a+ catchError :: m a -> (ErrorType m -> m a) -> m a++instance Monad m => MonadError (ErrorT e m) where+ type ErrorType (ErrorT e m) = e+ throwError = ErrorT . return . Left+ catchError m h = ErrorT $ do+ x <- runErrorT m+ case x of+ Left l -> runErrorT $ h l+ Right r -> return $ Right r++instance MonadState m => MonadState (ErrorT e m) where+ type StateType (ErrorT e m) = StateType m+ get = lift get+ put = lift . put @ \section{Haddock API documentation}
+ hs/DBus/Util/MonadError.hs view
@@ -0,0 +1,57 @@+{-+ Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+ + This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ any later version.+ + This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.+ + You should have received a copy of the GNU General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.+-}++{-# LANGUAGE TypeFamilies #-}+module DBus.Util.MonadError where+import Control.Monad.Trans.Class+import Control.Monad.State++newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }++instance Functor m => Functor (ErrorT e m) where+ fmap f = ErrorT . fmap (fmap f) . runErrorT++instance Monad m => Monad (ErrorT e m) where+ return = ErrorT . return . Right+ (>>=) m k = ErrorT $ do+ x <- runErrorT m+ case x of+ Left l -> return $ Left l+ Right r -> runErrorT $ k r++instance MonadTrans (ErrorT e) where+ lift = ErrorT . liftM Right++class Monad m => MonadError m where+ type ErrorType m+ throwError :: ErrorType m -> m a+ catchError :: m a -> (ErrorType m -> m a) -> m a++instance Monad m => MonadError (ErrorT e m) where+ type ErrorType (ErrorT e m) = e+ throwError = ErrorT . return . Left+ catchError m h = ErrorT $ do+ x <- runErrorT m+ case x of+ Left l -> runErrorT $ h l+ Right r -> return $ Right r++instance MonadState m => MonadState (ErrorT e m) where+ type StateType (ErrorT e m) = StateType m+ get = lift get+ put = lift . put+
hs/DBus/Wire/Marshal.hs view
@@ -15,13 +15,13 @@ along with this program. If not, see <http://www.gnu.org/licenses/>. -} -{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} module DBus.Wire.Marshal where import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL import qualified Control.Monad.State as State-import qualified Control.Monad.Error as E+import qualified DBus.Util.MonadError as E import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Builder as B @@ -48,12 +48,11 @@ import qualified DBus.Types as T data MarshalState = MarshalState Endianness B.Builder !Word64-newtype MarshalM a = MarshalM (E.ErrorT MarshalError (State.State MarshalState) a)- deriving (Monad, E.MonadError MarshalError, State.MonadState MarshalState)+type MarshalM = E.ErrorT MarshalError (State.State MarshalState) type Marshal = MarshalM () runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString-runMarshal (MarshalM m) e = case State.runState (E.runErrorT m) initialState of+runMarshal m e = case State.runState (E.runErrorT m) initialState of (Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder) (Left x, _) -> Left x where initialState = MarshalState e B.empty 0@@ -147,8 +146,6 @@ ["Invalid variant signature: ", show x] show (InvalidText x) = concat ["Text cannot be marshaled: ", show x]--instance E.Error MarshalError marshalWord32 :: Word32 -> Marshal marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le
hs/DBus/Wire/Unmarshal.hs view
@@ -17,13 +17,14 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} module DBus.Wire.Unmarshal where import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL import qualified Control.Monad.State as State-import qualified Control.Monad.Error as E+import Control.Monad.Trans.Class (lift)+import qualified DBus.Util.MonadError as E import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Get as G@@ -39,7 +40,7 @@ import qualified DBus.Constants as C -import Control.Monad (when, unless)+import Control.Monad (when, unless, liftM) import Data.Maybe (fromJust, listToMaybe, fromMaybe) import Data.Word (Word8, Word32, Word64) import Data.Int (Int16, Int32, Int64)@@ -48,11 +49,10 @@ import qualified DBus.Types as T data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64-newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (State.State UnmarshalState) a)- deriving (Monad, Functor, E.MonadError UnmarshalError, State.MonadState UnmarshalState)+type Unmarshal = E.ErrorT UnmarshalError (State.State UnmarshalState) runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a-runUnmarshal (Unmarshal m) e bytes = State.evalState (E.runErrorT m) state where+runUnmarshal m e bytes = State.evalState (E.runErrorT m) state where state = UnmarshalState e bytes 0 unmarshal :: T.Signature -> Unmarshal [T.Variant]@@ -198,8 +198,6 @@ ["Missing NUL terminator at position ", show pos] show ArraySizeMismatch = "Array size mismatch" -instance E.Error UnmarshalError- unmarshalWord32 :: Unmarshal Word32 unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le @@ -274,7 +272,7 @@ unmarshalMessage :: Monad m => (Word32 -> m L.ByteString) -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do- let getBytes = E.lift . getBytes'+ let getBytes = lift . getBytes' let fixedSig = "yyyyuuu" fixedBytes <- getBytes 16@@ -306,7 +304,7 @@ let fieldArray = fromJust . T.fromVariant $ header !! 6 let fieldStructures = fromJust . T.fromArray $ fieldArray- fields <- concat `fmap` mapM decodeField fieldStructures+ fields <- concat `liftM` mapM decodeField fieldStructures let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 getBytes . fromIntegral $ bodyPadding