Synnefo » snf-ganeti » ganeti-local

{-# LANGUAGE TemplateHaskell #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

{-| Unittests for ganeti-htools.

-}

{-

Copyright (C) 2009, 2010, 2011, 2012 Google Inc.

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 2 of the License, or

(at your option) 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, write to the Free Software

Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA

02110-1301, USA.

-}

module Test.Ganeti.BasicTypes (testBasicTypes) where

import Test.QuickCheck hiding (Result)

import Test.QuickCheck.Function

import Control.Applicative

import Control.Monad

import Test.Ganeti.TestHelper

import Test.Ganeti.TestCommon

import Ganeti.BasicTypes

-- Since we actually want to test these, don't tell us not to use them :)

{-# ANN module "HLint: ignore Functor law" #-}

{-# ANN module "HLint: ignore Monad law, left identity" #-}

{-# ANN module "HLint: ignore Monad law, right identity" #-}

{-# ANN module "HLint: ignore Use >=>" #-}

-- * Arbitrary instances

instance (Arbitrary a) => Arbitrary (Result a) where

  arbitrary = oneof [ Bad <$> arbitrary

                    , Ok  <$> arbitrary

                    ]

-- * Test cases

-- | Tests the functor identity law (fmap id == id).

prop_functor_id :: Result Int -> Property

prop_functor_id ri =

  fmap id ri ==? ri

-- | Tests the functor composition law (fmap (f . g)  ==  fmap f . fmap g).

prop_functor_composition :: Result Int

                         -> Fun Int Int -> Fun Int Int -> Property

prop_functor_composition ri (Fun _ f) (Fun _ g) =

  fmap (f . g) ri ==? (fmap f . fmap g) ri

-- | Tests the applicative identity law (pure id <*> v = v).

prop_applicative_identity :: Result Int -> Property

prop_applicative_identity v =

  pure id <*> v ==? v

-- | Tests the applicative composition law (pure (.) <*> u <*> v <*> w

-- = u <*> (v <*> w)).

prop_applicative_composition :: (Result (Fun Int Int))

                             -> (Result (Fun Int Int))

                             -> Result Int

                             -> Property

prop_applicative_composition u v w =

  let u' = fmap apply u

      v' = fmap apply v

  in pure (.) <*> u' <*> v' <*> w ==? u' <*> (v' <*> w)

-- | Tests the applicative homomorphism law (pure f <*> pure x = pure (f x)).

prop_applicative_homomorphism :: Fun Int Int -> Int -> Property

prop_applicative_homomorphism (Fun _ f) x =

  ((pure f <*> pure x)::Result Int) ==?

  (pure (f x))

-- | Tests the applicative interchange law (u <*> pure y = pure ($ y) <*> u).

prop_applicative_interchange :: Result (Fun Int Int)

                             -> Int -> Property

prop_applicative_interchange f y =

  let u = fmap apply f -- need to extract the actual function from Fun

  in u <*> pure y ==? pure ($ y) <*> u

-- | Tests the applicative\/functor correspondence (fmap f x = pure f <*> x).

prop_applicative_functor :: Fun Int Int -> Result Int -> Property

prop_applicative_functor (Fun _ f) x =

  fmap f x ==? pure f <*> x

-- | Tests the applicative\/monad correspondence (pure = return and

-- (<*>) = ap).

prop_applicative_monad :: Int -> Result (Fun Int Int) -> Property

prop_applicative_monad v f =

  let v' = pure v :: Result Int

      f' = fmap apply f -- need to extract the actual function from Fun

  in v' ==? return v .&&. (f' <*> v') ==? f' `ap` v'

-- | Tests the monad laws (return a >>= k == k a, m >>= return == m, m

-- >>= (\x -> k x >>= h) == (m >>= k) >>= h).

prop_monad_laws :: Int -> Result Int

                -> Fun Int (Result Int)

                -> Fun Int (Result Int)

                -> Property

prop_monad_laws a m (Fun _ k) (Fun _ h) =

  printTestCase "return a >>= k == k a" ((return a >>= k) ==? k a) .&&.

  printTestCase "m >>= return == m" ((m >>= return) ==? m) .&&.

  printTestCase "m >>= (\\x -> k x >>= h) == (m >>= k) >>= h)"

    ((m >>= (\x -> k x >>= h)) ==? ((m >>= k) >>= h))

-- | Tests the monad plus laws ( mzero >>= f = mzero, v >> mzero = mzero).

prop_monadplus_mzero :: Result Int -> Fun Int (Result Int) -> Property

prop_monadplus_mzero v (Fun _ f) =

  printTestCase "mzero >>= f = mzero" ((mzero >>= f) ==? mzero) .&&.

  -- FIXME: since we have "many" mzeros, we can't test for equality,

  -- just that we got back a 'Bad' value; I'm not sure if this means

  -- our MonadPlus instance is not sound or not...

  printTestCase "v >> mzero = mzero" (isBad (v >> mzero))

testSuite "BasicTypes"

  [ 'prop_functor_id

  , 'prop_functor_composition

  , 'prop_applicative_identity

  , 'prop_applicative_composition

  , 'prop_applicative_homomorphism

  , 'prop_applicative_interchange

  , 'prop_applicative_functor

  , 'prop_applicative_monad

  , 'prop_monad_laws

  , 'prop_monadplus_mzero

  ]