dbus-core-0.8.5: hs/Tests.hs

#line 64 "src/introduction.anansi"

#line 30 "src/introduction.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/>.

#line 65 "src/introduction.anansi"

#line 52 "src/introduction.anansi"
{-# LANGUAGE OverloadedStrings #-}

#line 66 "src/introduction.anansi"
module Main (tests, main) where

#line 159 "src/util.anansi"
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

#line 68 "src/introduction.anansi"

tests :: [F.Test]
tests = [ F.testGroup "dummy" []

#line 384 "src/types.anansi"
	, F.testGroup "String"
		[ testProperty "String -> strict Text"
			$ funEq (fromVariant . toVariant) (Just . T.pack)
		, testProperty "String <- strict Text"
			$ funEq (fromVariant . toVariant) (Just . T.unpack)
		, testProperty "String -> lazy Text"
			$ funEq (fromVariant . toVariant) (Just . TL.pack)
		, testProperty "String <- lazy Text"
			$ funEq (fromVariant . toVariant) (Just . TL.unpack)
		, testProperty "Strict Text -> lazy Text"
			$ funEq (fromVariant . toVariant) (Just . TL.pack . T.unpack)
		, testProperty "Strict Text <- lazy Text"
			$ funEq (fromVariant . toVariant) (Just . T.pack . TL.unpack)
		]

#line 736 "src/types.anansi"
	, F.testGroup "Signature"
		[ testProperty "Signature identity"
			$ funEq (mkSignature . strSignature) Just
		]

#line 806 "src/types.anansi"
	, F.testGroup "ObjectPath"
		[ testProperty "ObjectPath identity"
			$ funEq (mkObjectPath . strObjectPath) Just
		]

#line 942 "src/types.anansi"
	, F.testGroup "Array"
		[ testProperty "Array identity"
			$ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x)
		, testProperty "Array homogeneity" prop_ArrayHomogeneous
		]

#line 1071 "src/types.anansi"
	, F.testGroup "Dictionary"
		[ testProperty "Dictionary identity"
			$ \x -> Just x == dictionaryFromItems
				(dictionaryKeyType x)
				(dictionaryValueType x)
				(dictionaryItems x)
		, testProperty "Dictionary homogeneity" prop_DictionaryHomogeneous
		, testProperty "Dictionary must have atomic keys" 
			$ \vt -> forAll containerType $ \kt ->
				isNothing (dictionaryFromItems kt vt [])
		, testProperty "Dictionary <-> Array conversion"
			$ funEq (arrayToDictionary . dictionaryToArray) Just
		]

#line 1232 "src/types.anansi"
	, F.testGroup "BusName"
		[ testProperty "BusName identity"
			$ funEq (mkBusName . strBusName) Just
		]

#line 1279 "src/types.anansi"
	, F.testGroup "InterfaceName"
		[ testProperty "InterfaceName identity"
			$ funEq (mkInterfaceName . strInterfaceName) Just
		]

#line 1311 "src/types.anansi"
	, F.testGroup "ErrorName"
		[ testProperty "ErrorName identity"
			$ funEq (mkErrorName . strErrorName) Just
		]

#line 1354 "src/types.anansi"
	, F.testGroup "MemberName"
		[ testProperty "MemberName identity"
			$ funEq (mkMemberName . strMemberName) Just
		]

#line 1223 "src/wire.anansi"
	, F.testGroup "Wire format"
		[ testProperty "Marshal -> Ummarshal" prop_Unmarshal
		, F.testGroup "Messages"
			[ testProperty "Method calls" prop_WireMethodCall
			, testProperty "Method returns" prop_WireMethodReturn
			, testProperty "Errors" prop_WireError
			, testProperty "Signals" prop_WireSignal
			]
		]

#line 177 "src/addresses.anansi"
	, F.testGroup "Addresses"
		[ testProperty "Address identity"
			$ \x -> mkAddresses (strAddress x) == Just [x]
		, testProperty "Multiple addresses"
			$ \x y -> let
			joined = TL.concat [strAddress x, ";", strAddress y]
			in mkAddresses joined == Just [x, y]
		, testProperty "Ignore trailing semicolon"
			$ \x -> mkAddresses (TL.append (strAddress x) ";") == Just [x]
		, testProperty "Ignore trailing comma"
			$ \x -> let
			hasParams = not . Map.null . addressParameters $ x
			parsed = mkAddresses (TL.append (strAddress x) ",")
			in hasParams ==> parsed == Just [x]
		, F.testGroup "Valid addresses"
			[ test "colon" $ isJust . mkAddresses $ ":"
			, test "just scheme" $ isJust . mkAddresses $ "a:"
			, test "param" $ isJust . mkAddresses $ "a:b=c"
			, test "trailing semicolon" $ isJust . mkAddresses $ "a:;"
			, test "two schemes" $ isJust . mkAddresses $ "a:;b:"
			, test "trailing comma" $ isJust . mkAddresses $ "a:b=c,"
			]
		, F.testGroup "Invalid addresses"
			[ test "empty" $ isNothing . mkAddresses $ ""
			, test "no colon" $ isNothing . mkAddresses $ "a"
			, test "no equals" $ isNothing . mkAddresses $ "a:b"
			, test "no param" $ isNothing . mkAddresses $ "a:b="
			, test "no param" $ isNothing . mkAddresses $ "a:,"
			]
		]

#line 507 "src/introspection.anansi"
	, F.testGroup "Introspection"
		[ testProperty "Generate -> Parse"
			$ \x@(I.Object path _ _) -> let
			xml = I.toXML x
			Just xml' = xml
			parsed = I.fromXML path xml'
			in isJust xml ==> I.fromXML path xml' == Just x
		]

#line 72 "src/introduction.anansi"
	]

main :: IO ()
main = F.defaultMain tests

#line 106 "src/types.anansi"
instance Arbitrary Type where
	arbitrary = oneof [atomicType, containerType]

atomicType :: Gen Type
atomicType = elements
	[ DBusBoolean
	, DBusByte
	, DBusWord16
	, DBusWord32
	, DBusWord64
	, DBusInt16
	, DBusInt32
	, DBusInt64
	, DBusDouble
	, DBusString
	, DBusObjectPath
	, DBusSignature
	]

containerType :: Gen Type
containerType = do
	c <- choose (0,3) :: Gen Int
	case c of
		0 -> fmap DBusArray arbitrary
		1 -> do
			kt <- atomicType
			vt <- arbitrary
			return $ DBusDictionary kt vt
		2 -> fmap DBusStructure $ halfSized arbitrary
		3 -> return DBusVariant

#line 272 "src/types.anansi"
instance Arbitrary Variant where
	arbitrary = arbitrary >>= genVariant

genVariant :: Type -> Gen Variant
genVariant t = case t of
	DBusBoolean          -> fmap toVariant (arbitrary :: Gen Bool)
	DBusByte             -> fmap toVariant (arbitrary :: Gen Word8)
	DBusWord16           -> fmap toVariant (arbitrary :: Gen Word16)
	DBusWord32           -> fmap toVariant (arbitrary :: Gen Word32)
	DBusWord64           -> fmap toVariant (arbitrary :: Gen Word64)
	DBusInt16            -> fmap toVariant (arbitrary :: Gen Int16)
	DBusInt32            -> fmap toVariant (arbitrary :: Gen Int32)
	DBusInt64            -> fmap toVariant (arbitrary :: Gen Int64)
	DBusDouble           -> fmap toVariant (arbitrary :: Gen Double)
	DBusString           -> fmap toVariant (arbitrary :: Gen String)
	DBusObjectPath       -> fmap toVariant (arbitrary :: Gen ObjectPath)
	DBusSignature        -> fmap toVariant (arbitrary :: Gen Signature)
	(DBusArray _)        -> fmap toVariant (arbitrary :: Gen Array)
	(DBusDictionary _ _) -> fmap toVariant (arbitrary :: Gen Dictionary)
	(DBusStructure _)    -> fmap toVariant (arbitrary :: Gen Structure)
	DBusVariant          -> fmap toVariant (arbitrary :: Gen Variant)

#line 731 "src/types.anansi"
instance Arbitrary Signature where
	arbitrary = sizedText 255 $ fmap (TL.concat . map typeCode) arbitrary

#line 797 "src/types.anansi"
instance Arbitrary ObjectPath where
	arbitrary = fmap (mkObjectPath_ . TL.pack) path' where
		c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"
		path = fmap (intercalate "/" . ([] :)) genElements
		path' = frequency [(1, return "/"), (9, path)]
		genElements = atLeast 1 (atLeast 1 (elements c))

#line 926 "src/types.anansi"
instance Arbitrary Array where
	arbitrary = do
		t <- atomicType
		xs <- listOf $ genVariant t
		return . fromJust $ arrayFromItems t xs

prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where
	array = arrayFromItems firstType vs
	homogeneousTypes = all (== firstType) types
	types = map variantType vs
	firstType = if null types
		then DBusByte
		else head types

#line 1053 "src/types.anansi"
instance Arbitrary Dictionary where
	arbitrary = do
		kt <- atomicType
		vt <- atomicType
		ks <- listOf $ genVariant kt
		vs <- vectorOf (length ks) $ genVariant vt
		
		return . fromJust $ dictionaryFromItems kt vt $ zip ks vs

prop_DictionaryHomogeneous x = all correctType pairs where
	pairs = dictionaryItems x
	kType = dictionaryKeyType x
	vType = dictionaryValueType x
	correctType (k, v) = variantType k == kType &&
	                     variantType v == vType

#line 1138 "src/types.anansi"
instance Arbitrary Structure where
	arbitrary = fmap Structure $ halfSized arbitrary

#line 1212 "src/types.anansi"
instance Arbitrary BusName where
	arbitrary = sizedText 255 (oneof [unique, wellKnown]) where
		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"
		c' = c ++ ['0'..'9']
		
		unique = do
			elems' <- atLeast 2 $ elems c'
			return . TL.pack $ ':' : intercalate "." elems'
		
		wellKnown = do
			elems' <- atLeast 2 $ elems c
			return . TL.pack $ intercalate "." elems'
		
		elems start = do
			x <- elements start
			xs <- atLeast 0 (elements c')
			return (x:xs)

#line 1265 "src/types.anansi"
instance Arbitrary InterfaceName where
	arbitrary = sizedText 255 genName where
		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"
		c' = c ++ ['0'..'9']
		
		genName = fmap (TL.pack . intercalate ".") genElements
		genElements = atLeast 2 genElement
		genElement = do
			x <- elements c
			xs <- atLeast 0 (elements c')
			return (x:xs)

#line 1306 "src/types.anansi"
instance Arbitrary ErrorName where
	arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary

#line 1342 "src/types.anansi"
instance Arbitrary MemberName where
	arbitrary = sizedText 255 genName where
		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"
		c' = c ++ ['0'..'9']
		
		genName = do
			x <- elements c
			xs <- atLeast 0 (elements c')
			return . TL.pack $ (x:xs)

#line 73 "src/messages.anansi"
instance Arbitrary Flag where
	arbitrary = elements [NoReplyExpected, NoAutoStart]

#line 131 "src/messages.anansi"
instance Arbitrary Serial where
	arbitrary = fmap Serial arbitrary

#line 173 "src/messages.anansi"
instance Arbitrary MethodCall where
	arbitrary = do
		path   <- arbitrary
		member <- arbitrary
		iface  <- arbitrary
		dest   <- arbitrary
		flags  <- fmap Set.fromList arbitrary
		Structure body <- arbitrary
		return $ MethodCall path member iface dest flags body

#line 210 "src/messages.anansi"
instance Arbitrary MethodReturn where
	arbitrary = do
		serial <- arbitrary
		dest   <- arbitrary
		Structure body <- arbitrary
		return $ MethodReturn serial dest body

#line 261 "src/messages.anansi"
instance Arbitrary Error where
	arbitrary = do
		name   <- arbitrary
		serial <- arbitrary
		dest   <- arbitrary
		Structure body <- arbitrary
		return $ Error name serial dest body

#line 300 "src/messages.anansi"
instance Arbitrary Signal where
	arbitrary = do
		path   <- arbitrary
		member <- arbitrary
		iface  <- arbitrary
		dest   <- arbitrary
		Structure body <- arbitrary
		return $ Signal path member iface dest body

#line 58 "src/wire.anansi"
instance Arbitrary Endianness where
	arbitrary = elements [LittleEndian, BigEndian]

#line 1188 "src/wire.anansi"
prop_Unmarshal :: Endianness -> Variant -> Property
prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where
	sig = mkSignature . typeCode . variantType $ x
	Just sig' = sig
	
	bytes = runMarshal (marshal x) e
	Right bytes' = bytes
	
	valid = isJust sig && isRight bytes
	unmarshaled = runUnmarshal (unmarshal sig') e bytes'

prop_MarshalMessage e serial msg expected = valid ==> correct where
	bytes = marshalMessage e serial msg
	Right bytes' = bytes
	
	getBytes = G.getLazyByteString . fromIntegral
	unmarshaled = G.runGet (unmarshalMessage getBytes) bytes'
	
	valid = isRight bytes
	correct = unmarshaled == Right expected

prop_WireMethodCall e serial msg = prop_MarshalMessage e serial msg
	$ ReceivedMethodCall serial Nothing msg

prop_WireMethodReturn e serial msg = prop_MarshalMessage e serial msg
	$ ReceivedMethodReturn serial Nothing msg

prop_WireError e serial msg = prop_MarshalMessage e serial msg
	$ ReceivedError serial Nothing msg

prop_WireSignal e serial msg = prop_MarshalMessage e serial msg
	$ ReceivedSignal serial Nothing msg

#line 138 "src/addresses.anansi"
instance Arbitrary Address where
	arbitrary = genAddress where
		optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."
		methodChars = filter (flip notElem ":;") ['!'..'~']
		keyChars = filter (flip notElem "=;,") ['!'..'~']
		
		genMethod = atLeast 0 $ elements methodChars
		genParam = do
			key <- genKey
			value <- genValue
			return . concat $ [key, "=", value]
		
		genKey = atLeast 1 $ elements keyChars
		genValue = oneof [encodedValue, plainValue]
		genHex = elements $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']
		encodedValue = do
			x1 <- genHex
			x2 <- genHex
			return ['%', x1, x2]
		plainValue = atLeast 1 $ elements optional
		
		genParams = do
			params <- atLeast 0 genParam
			let params' = intercalate "," params
			extraComma <- if null params
				then return ""
				else elements ["", ","]
			return $ concat [params', extraComma]
		
		genAddress = do
			m <- genMethod
			params <- genParams
			extraSemicolon <- elements ["", ";"]
			let addrStr = concat [m, ":", params, extraSemicolon]
			let Just [addr] = mkAddresses $ TL.pack addrStr
			return addr

#line 442 "src/introspection.anansi"
subObject :: ObjectPath -> Gen I.Object
subObject parentPath = sized $ \n -> resize (min n 4) $ do
	let nonRoot = do
		x <- arbitrary
		case strObjectPath x of
			"/" -> nonRoot
			x'  -> return x'
	
	thisPath <- nonRoot
	let path' = case strObjectPath parentPath of
		"/" -> thisPath
		x   -> TL.append x thisPath
	let path = mkObjectPath_ path'
	ifaces <- arbitrary
	children <- halfSized . listOf . subObject $ path
	return $ I.Object path ifaces children

instance Arbitrary I.Object where
	arbitrary = arbitrary >>= subObject

instance Arbitrary I.Interface where
	arbitrary = do
		name <- arbitrary
		methods <- arbitrary
		signals <- arbitrary
		properties <- arbitrary
		return $ I.Interface name methods signals properties

instance Arbitrary I.Method where
	arbitrary = do
		name <- arbitrary
		inParams <- arbitrary
		outParams <- arbitrary
		return $ I.Method name inParams outParams

instance Arbitrary I.Signal where
	arbitrary = do
		name <- arbitrary
		params <- arbitrary
		return $ I.Signal name params

singleType :: Gen Signature
singleType = do
	t <- arbitrary
	case mkSignature $ typeCode t of
		Just x -> return x
		Nothing -> singleType

instance Arbitrary I.Parameter where
	arbitrary = do
		name <- listOf $ arbitrary `suchThat` isPrint
		sig <- singleType
		return $ I.Parameter (TL.pack name) sig

instance Arbitrary I.Property where
	arbitrary = do
		name <- listOf $ arbitrary `suchThat` isPrint
		sig <- singleType
		access <- elements
			[[], [I.Read], [I.Write],
			 [I.Read, I.Write]]
		return $ I.Property (TL.pack name) sig access

#line 187 "src/util.anansi"
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)

#line 216 "src/util.anansi"
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

#line 225 "src/util.anansi"
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