Signature.hs

{-# LANGUAGE TemplateHaskell #-}

-- Copyright (C) 2010-2012 John Millikin <john@john-millikin.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/>.

module DBusTests.Signature (test_Signature) where

import           Test.Chell
import           Test.Chell.QuickCheck
import           Test.QuickCheck hiding ((.&.), property)

import           DBus

import           DBusTests.Util

test_Signature :: Suite
test_Signature = suite "Signature"
    [ test_BuildSignature
    , test_ParseSignature
    , test_ParseInvalid
    , test_FormatSignature
    , test_IsAtom
    , test_ShowType
    ]

test_BuildSignature :: Test
test_BuildSignature = property "signature" prop where
    prop = forAll gen_SignatureTypes check
    check types = case signature types of
        Nothing -> False
        Just sig -> signatureTypes sig == types

test_ParseSignature :: Test
test_ParseSignature = property "parseSignature" prop where
    prop = forAll gen_SignatureString check
    check (s, types) = case parseSignature s of
        Nothing -> False
        Just sig -> signatureTypes sig == types

test_ParseInvalid :: Test
test_ParseInvalid = assertions "parse-invalid" $ do
    -- at most 255 characters
    $expect (just (parseSignature (replicate 254 'y')))
    $expect (just (parseSignature (replicate 255 'y')))
    $expect (nothing (parseSignature (replicate 256 'y')))

    -- length also enforced by 'signature'
    $expect (just (signature (replicate 255 TypeWord8)))
    $expect (nothing (signature (replicate 256 TypeWord8)))

    -- struct code
    $expect (nothing (parseSignature "r"))

    -- empty struct
    $expect (nothing (parseSignature "()"))
    $expect (nothing (signature [TypeStructure []]))

    -- dict code
    $expect (nothing (parseSignature "e"))

    -- non-atomic dict key
    $expect (nothing (parseSignature "a{vy}"))
    $expect (nothing (signature [TypeDictionary TypeVariant TypeVariant]))

test_FormatSignature :: Test
test_FormatSignature = property "formatSignature" prop where
    prop = forAll gen_SignatureString check
    check (s, _) = let
        Just sig = parseSignature s
        in formatSignature sig == s

test_IsAtom :: Test
test_IsAtom = assertions "IsAtom" $ do
    let Just sig = signature []
    assertAtom TypeSignature sig

test_ShowType :: Test
test_ShowType = assertions "show-type" $ do
    $expect (equal "Bool" (show TypeBoolean))
    $expect (equal "Bool" (show TypeBoolean))
    $expect (equal "Word8" (show TypeWord8))
    $expect (equal "Word16" (show TypeWord16))
    $expect (equal "Word32" (show TypeWord32))
    $expect (equal "Word64" (show TypeWord64))
    $expect (equal "Int16" (show TypeInt16))
    $expect (equal "Int32" (show TypeInt32))
    $expect (equal "Int64" (show TypeInt64))
    $expect (equal "Double" (show TypeDouble))
    $expect (equal "UnixFd" (show TypeUnixFd))
    $expect (equal "String" (show TypeString))
    $expect (equal "Signature" (show TypeSignature))
    $expect (equal "ObjectPath" (show TypeObjectPath))
    $expect (equal "Variant" (show TypeVariant))
    $expect (equal "[Word8]" (show (TypeArray TypeWord8)))
    $expect (equal "Dict Word8 (Dict Word8 Word8)" (show (TypeDictionary TypeWord8 (TypeDictionary TypeWord8 TypeWord8))))
    $expect (equal "(Word8, Word16)" (show (TypeStructure [TypeWord8, TypeWord16])))

gen_SignatureTypes :: Gen [Type]
gen_SignatureTypes = do
    (_, ts) <- gen_SignatureString
    return ts

gen_SignatureString :: Gen (String, [Type])
gen_SignatureString = gen where
    anyType = oneof [atom, container]
    atom = elements
        [ ("b", TypeBoolean)
        , ("y", TypeWord8)
        , ("q", TypeWord16)
        , ("u", TypeWord32)
        , ("t", TypeWord64)
        , ("n", TypeInt16)
        , ("i", TypeInt32)
        , ("x", TypeInt64)
        , ("d", TypeDouble)
        , ("h", TypeUnixFd)
        , ("s", TypeString)
        , ("o", TypeObjectPath)
        , ("g", TypeSignature)
        ]
    container = oneof
        [ return ("v", TypeVariant)
        , array
        , dict
        , struct
        ]
    array = do
        (tCode, tEnum) <- anyType
        return ('a':tCode, TypeArray tEnum)
    dict = do
        (kCode, kEnum) <- atom
        (vCode, vEnum) <- anyType
        return (concat ["a{", kCode, vCode, "}"], TypeDictionary kEnum vEnum)
    struct = do
        ts <- listOf1 (halfSized anyType)
        let (codes, enums) = unzip ts
        return ("(" ++ concat codes ++ ")", TypeStructure enums)
    gen = do
        types <- listOf anyType
        let (codes, enums) = unzip types
        let chars = concat codes
        if length chars > 255
            then halfSized gen
            else return (chars, enums)

instance Arbitrary Signature where
    arbitrary = do
        ts <- gen_SignatureTypes
        let Just sig = signature ts
        return sig