dbus-core-0.8.5.4: 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.ParserCombinators.Parsec (Parser, 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 :: Parser 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

void :: Monad m => m a -> m ()
void m = m >> return ()
:

\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|
module DBus.Util.MonadError
	( ErrorM (..)
	, ErrorT (..)
	, throwErrorM
	, throwErrorT
	) where
newtype ErrorM e a = ErrorM { runErrorM :: Either e a }

instance Functor (ErrorM e) where
	fmap f m = ErrorM $ case runErrorM m of
		Left err -> Left err
		Right x -> Right $ f x

instance Monad (ErrorM e) where
	return = ErrorM . Right
	(>>=) m k = case runErrorM m of
		Left err -> ErrorM $ Left err
		Right x -> k x

throwErrorM :: e -> ErrorM e a
throwErrorM = ErrorM . Left

newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }

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

throwErrorT :: Monad m => e -> ErrorT e m a
throwErrorT = ErrorT . return . Left
:

\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 T.Text where
	arbitrary = fmap T.pack arbitrary

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