diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 "$<" diff --git a/dbus-core.cabal b/dbus-core.cabal --- a/dbus-core.cabal +++ b/dbus-core.cabal @@ -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 diff --git a/dbus-core.nw b/dbus-core.nw --- a/dbus-core.nw +++ b/dbus-core.nw @@ -1326,7 +1326,7 @@ <>= <> -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} module DBus.Wire.Marshal where <> <> @@ -1340,14 +1340,13 @@ <>= 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 <>= 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 @@ <>= 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 - <>= , MarshalError (..) @@ -1446,11 +1443,11 @@ <>= <> <> -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} module DBus.Wire.Unmarshal where <> <> -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 @@ <>= 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 <>= 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 <>= @@ -1594,8 +1591,6 @@ ["Missing NUL terminator at position ", show pos] show ArraySizeMismatch = "Array size mismatch" -instance E.Error UnmarshalError - <>= , 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' <> <> @@ -2148,7 +2143,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 @ 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. + +<>= +<> +{-# 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} diff --git a/hs/DBus/Util/MonadError.hs b/hs/DBus/Util/MonadError.hs new file mode 100644 --- /dev/null +++ b/hs/DBus/Util/MonadError.hs @@ -0,0 +1,57 @@ +{- + Copyright (C) 2009 John Millikin + + 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 . +-} + +{-# 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 + diff --git a/hs/DBus/Wire/Marshal.hs b/hs/DBus/Wire/Marshal.hs --- a/hs/DBus/Wire/Marshal.hs +++ b/hs/DBus/Wire/Marshal.hs @@ -15,13 +15,13 @@ along with this program. If not, see . -} -{-# 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 diff --git a/hs/DBus/Wire/Unmarshal.hs b/hs/DBus/Wire/Unmarshal.hs --- a/hs/DBus/Wire/Unmarshal.hs +++ b/hs/DBus/Wire/Unmarshal.hs @@ -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