xfconf-4.8.0.0: Tests/Tests.hs

{-| some tests you can run with `runghc -lxfconf-0 Tests/Tests` -}
-- A rewrite of the previous tests using monadic quickcheck

module Main where

import Test.Framework                       (defaultMain, testGroup)
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.HUnit

import Test.QuickCheck
import Test.QuickCheck.Monadic              as QCM

import Control.Concurrent                   (threadDelay)
import Data.Char                            (toLower)
import Text.Printf

import System.XFCE.Xfconf

myChannel = "QuickCheck"

main :: IO ()
main = defaultMain testSuite

  -- we need to sleep because garbace collection must collect objects
  -- before we shutdown xfconf (!! this sucks !!)
  where msleep = threadDelay . (1000*)

testSuitv = [ testGroup "Debugging"
                    [ testStringList
                    ]
            ]

testSuite = [ testGroup "QuickCheck"
                    [ testChannelPropertyBase
                    , testXfconfValue
                    , testXfconfArray
                    , testStringList
                    , testStringArray
                    , testString
                    , testDouble
                    , testInt
                    , testUInt
                    , testInt16
                    , testUInt16
                    , testUInt64
                    , testBool
                    ]
            , testGroup "HUnit"
                    [ testChannels
                    , testHasProperty
                    , testPropertyLocked
                    , testGetKeys
                    , testGetProperties
                    , testResetProperties
                    , testChannelName
                    ]
            ]

-- | Really dumb test
testChannels = testCase "xfconf_list_channels" $ do
        putStrLn "  Available channels:"

        xfconfListChannels >>= printStringArray

        assertBool "Query list of channels" True

testHasProperty = testCase "xfconf_channel_has_property" $ do
        chan  <- channelGet "xfce4-desktop"
        dummy <- channelHasProperty chan "/no/property"
        img   <- channelHasProperty chan "/backdrop/screen0/monitor0/image-path"

        assertBool "Non-existing property" (dummy == False)
        assertBool "Existing property" (img == True)

testPropertyLocked = testCase "xfconf_channel_is_property_locked" $ do
        chan  <- channelGet "xsettings"
        value <- channelIsPropertyLocked chan "/Net/ThemeName"

        assertBool "Property should not be locked" (value == False)

testResetProperties = testCase "xfconf_channel_reset_property" $ do
        chan  <- channelGet "QuickCheck"
        channelResetProperty chan "/" True
        alist <- chan `channelGetProperties` "/"

        assertBool "Channel not empty" (null alist)

testChannelName = testCase "channel attribute name" $ do
        let name = myChannel
        name'   <- channelGetName =<< channelGet name
        name''  <- channelGetName =<< channelNew name
        name''' <- channelGetName =<< channelNewWithPropertyBase name "/foo"

        assertBool "channelGet name"                 (name === name')
        assertBool "channelNew name"                 (name === name'')
        assertBool "channelNewWithPropertyBase name" (name === name''')

  where s === s' = lower s == lower s'
        lower = map toLower


{----------------------------------------------------------------------
-- Serious business goes here
-- (well, it was serious because I had to implement GHashTable bindings)
----------------------------------------------------------------------}

testGetKeys =
  testCase "listing keys from a GHashTable" $ do
        putStrLn "  xfce4-desktop keys list:"

        desktop <- channelGet "xfce4-desktop"
        channelGetKeys desktop "/" >>= printStringArray

        assertBool "Query list of channel keys" True

testGetProperties =
  testCase "listing properties from a GHashTable" $ do
        putStrLn "  QuickCheck properties list:"

        desktop <- channelGet "QuickCheck"
        channelGetProperties desktop "/" >>= printTuples

        assertBool "Query list of channel properties" True


{----------------------------------------------------------------------
-- QuickCheck.v2
----------------------------------------------------------------------}

testChannelPropertyBase =
  testProperty "channel attribute property base" $ monadicIO $ do
          base  <- pick genAsciiString
          chan  <- QCM.run $ channelNewWithPropertyBase myChannel base
          base' <- QCM.run $ channelGetPropertyBase chan

          QCM.assert (base' == base)

-- | garbage string, just be careful to avoid C-String delimiter ('\0')
genUTFString :: Gen String
genUTFString = suchThat arbitrary (notElem '\0')

genAsciiString :: Gen String
genAsciiString = listOf1 (elements ascii)
  where ascii = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ " \t"

-- Warnings:
--
-- XfconfStringList [String] are returned as
-- XfconfArray [XfconfString s]
--
-- (U)Int16 are returned as plain (U)Int by xfconfd
genBasicXfconfValue :: Gen XfconfValue
genBasicXfconfValue = oneof [ XfconfString `fmap` genUTFString
                            , XfconfInt    `fmap` arbitrary
                            , XfconfUInt   `fmap` arbitrarySizedIntegral
                            , XfconfUInt64 `fmap` arbitrarySizedIntegral
                            , XfconfDouble `fmap` arbitrary
                            , XfconfBool   `fmap` arbitrary
                            ]

testXfconfValue = testValue "XfconfValue"
                            -- setProperty Nothing is cursed by the
                            -- monomorphism restriction
                            (Just `fmap` genBasicXfconfValue)
                            channelGetProperty
                            channelSetProperty
testXfconfArray = testValue "XfconfArray"
                            (listOf genBasicXfconfValue)
                            channelGetArray
                            channelSetArray
testStringArray = testValue "StringArray"
                            (listOf genUTFString)
                            channelGetStringArray
                            channelSetStringList
  -- We will re-use our 'testValue' function but since it expect the Get
  -- and Set operator to work with the same type, we provide an hackish
  -- function to convert an XfconfArray [XfconfString] to [String]
  where channelGetStringArray :: XfconfChannel -> String -> IO [String]
        channelGetStringArray ch prop = do
           r <- channelGetProperty ch prop
           case r of
                Just (XfconfArray v) -> return (map fromXfconfString v)
                Nothing -> return []
                _       -> error "internal error"

        fromXfconfString (XfconfString s) = s
        fromXfconfString _                = error "expect XfconfString"

testStringList  = testValue "StringList"
                            (listOf genUTFString)
                            channelGetStringList
                            channelSetStringList
testString      = testValue "String"
                            genUTFString
                            channelGetString
                            channelSetString
testDouble      = testValue "Double"
                            arbitrary
                            channelGetDouble
                            channelSetDouble
testInt         = testValue "Int"
                            arbitrary
                            channelGetInt
                            channelSetInt
testUInt        = testValue "UInt"
                            arbitrarySizedIntegral
                            channelGetUInt
                            channelSetUInt
testInt16       = testValue "Int16"
                            arbitrarySizedIntegral
                            channelGetInt16
                            channelSetInt16
testUInt16      = testValue "UInt16"
                            arbitrarySizedIntegral
                            channelGetUInt16
                            channelSetUInt16
testUInt64      = testValue "UInt64"
                            arbitrarySizedIntegral
                            channelGetUInt64
                            channelSetUInt64
testBool        = testValue "Bool"
                            arbitrary
                            channelGetBool
                            channelSetBool

-- | Check generic read and write operations
testValue typeName gen getOp setOp =
  testProperty testName $ QCM.monadicIO $ do

        value  <- QCM.pick gen
        value' <- QCM.run $ computeNewValue value
        QCM.assert (value == value')

  where testName = "xfconf_channel_get/set " ++ typeName
        computeNewValue v= do
                -- we use the name of the type as xfconf property name
                let prop = "/" ++ typeName
                channel <- channelGet myChannel

                -- apply dummy test value
                setOp channel prop v
                -- Query xfconfd back
                getOp channel prop


manualTestProperty setOp getOp value = do
    channel <- channelGet myChannel
    setOp channel prop value
    value' <- getOp channel prop
    let same = (value == value')
    if same
       then printf "Ok\n"
       else printf "(value,value') = (%s, %s)\n" (show value) (show value')

  where prop = "/Manual"

{----------------------------------------------------------------------
-- Utilities
----------------------------------------------------------------------}

-- | Pretty print function because I am getting bored watching tests
-- output
printStringArray :: [String] -> IO ()
printStringArray xs = mapM_ (\x -> putStrLn ("    " ++ show x)) xs

printTuples :: [(String, Maybe XfconfValue)] -> IO ()
printTuples xs = mapM_ fmt xs
  where fmt (k,v) = putStrLn $ "    " ++ k ++ ": " ++ show v