dbus-core-0.8.3: src/util.anansi

:# Copyright (C) 2009-2010 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/>.

\section{UUIDs}

D-Bus {\sc uuid}s are 128-bit unique identifiers, used for server instances
and machine {\sc id}s. They are not compatible with {\sc rfc4122}.

:f DBus/UUID.hs
|copyright|
module DBus.UUID
	( UUID
	, toHex
	, fromHex
	) where
|text imports|

newtype UUID = UUID Text -- TODO: (Word64, Word64)?
	deriving (Eq)

instance Show UUID where
	showsPrec d uuid = showParen (d > 10) $
		showString "UUID " . shows (toHex uuid)

toHex :: UUID -> Text
toHex (UUID text) = text

fromHex :: Text -> Maybe UUID
fromHex text = if validUUID text
	then Just $ UUID text
	else Nothing

validUUID :: Text -> Bool
validUUID text = valid where
	valid = and [TL.length text == 32, TL.all validChar text]
	validChar c = or
		[ c >= '0' && c <= '9'
		, c >= 'a' && c <= 'f'
		, c >= 'A' && c <= 'F'
		]
:

\section{Misc. utility functions}

:f DBus/Util.hs
|copyright|
module DBus.Util where
import Text.Parsec (Parsec, parse)
import Data.Char (digitToInt)
import Data.List (isPrefixOf)

checkLength :: Int -> String -> Maybe String
checkLength length' s | length s <= length' = Just s
checkLength _ _ = Nothing

parseMaybe :: Parsec String () a -> String -> Maybe a
parseMaybe p = either (const Nothing) Just . parse p ""

mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b
mkUnsafe label f x = case f x of
	Just x' -> x'
	Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x

hexToInt :: String -> Int
hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt

eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe (Left  _) = Nothing
eitherToMaybe (Right x) = Just x

fromRight :: Either a b -> b
fromRight (Right x) = x
fromRight _ = error "DBus.Util.fromRight: Left"

maybeIndex :: [a] -> Int -> Maybe a
maybeIndex (x:_ ) 0         = Just x
maybeIndex (_:xs) n | n > 0 = maybeIndex xs (n - 1)
maybeIndex _ _ = Nothing

-- | Read values from a monad until a guard value is read; return all
-- values, including the guard.
--
readUntil :: (Monad m, Eq a) => [a] -> m a -> m [a]
readUntil guard getx = readUntil' [] where
	guard' = reverse guard
	step xs | isPrefixOf guard' xs = return . reverse $ xs
	        | otherwise            = readUntil' xs
	readUntil' xs = do
		x <- getx
		step $ x:xs

-- | Drop /n/ items from the end of a list
dropEnd :: Int -> [a] -> [a]
dropEnd n xs = take (length xs - n) xs
:

\subsection{Bundled ErrorT variant}

The default {\tt ErrorT} type in the {\tt transformers} package has 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.

:f DBus/Util/MonadError.hs
|copyright|
{-# LANGUAGE TypeFamilies #-}
module DBus.Util.MonadError
	( ErrorT (..)
	, throwError
	) where
import Control.Monad.Trans.Class
import Control.Monad.State
import Control.Monad.Error.Class

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

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
:

\subsection{Extra test support}

The test suite requires a whole bunch of imports

:d test imports
import Test.QuickCheck
import qualified Test.Framework as F
import Test.Framework.Providers.QuickCheck2 (testProperty)

import Control.Arrow ((&&&))
import Control.Monad (replicateM)
import qualified Data.Binary.Get as G
import Data.Char (isPrint)
import Data.String
import Data.List (intercalate, isInfixOf)
import Data.Maybe (fromJust, isJust, isNothing)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Int (Int16, Int32, Int64)

import DBus.Address
import DBus.Message.Internal
import DBus.Types
import DBus.Wire.Internal
import DBus.Wire.Marshal
import DBus.Wire.Unmarshal
import qualified DBus.Introspection as I
:

:f Tests.hs
halfSized :: Gen a -> Gen a
halfSized gen = sized $ \n -> if n > 0 then
	resize (n `div` 2) gen
	else gen

funEq :: Eq b => (a -> b) -> (a -> b) -> a -> Bool
funEq f g x = f x == g x

sizedText :: (IsString a, Arbitrary a) => Integer -> Gen TL.Text -> Gen a
sizedText maxSize gen = step where
	step = do
		s <- gen
		if toInteger (TL.length s) > maxSize
			then halfSized step
			else return . fromString . TL.unpack $ s

atLeast :: Int -> Gen a -> Gen [a]
atLeast minSize g = sized $ \n -> do
	count <- choose (minSize, max minSize n)
	replicateM count g

isRight :: Either a b -> Bool
isRight = either (const False) (const True)
:

Some tests, such as address parsing, are single-case tests instead of
the more common ``property''. This function lets them be run only once.

:f Tests.hs
test :: Testable a => F.TestName -> a -> F.Test
test name prop = F.plusTestOptions options (testProperty name prop) where
	options = F.TestOptions Nothing (Just 1) Nothing Nothing
:

QuickCheck doesn't define instances for fixed-size integral types or
variants of {\tt Text}, so define them here.

:f Tests.hs
instance Arbitrary Word8 where
	arbitrary = arbitraryBoundedIntegral
	shrink    = shrinkIntegral

instance Arbitrary Word16 where
	arbitrary = arbitraryBoundedIntegral
	shrink    = shrinkIntegral

instance Arbitrary Word32 where
	arbitrary = arbitraryBoundedIntegral
	shrink    = shrinkIntegral

instance Arbitrary Word64 where
	arbitrary = arbitraryBoundedIntegral
	shrink    = shrinkIntegral

instance Arbitrary Int16 where
	arbitrary = arbitraryBoundedIntegral
	shrink    = shrinkIntegral

instance Arbitrary Int32 where
	arbitrary = arbitraryBoundedIntegral
	shrink    = shrinkIntegral

instance Arbitrary Int64 where
	arbitrary = arbitraryBoundedIntegral
	shrink    = shrinkIntegral

instance Arbitrary T.Text where
	arbitrary = fmap T.pack arbitrary

instance Arbitrary TL.Text where
	arbitrary = fmap TL.pack arbitrary
: