From 1493a93b9a349dc66f7b23962c91e86dc447c24d Mon Sep 17 00:00:00 2001 From: Iustin Pop Date: Thu, 30 Aug 2012 16:58:34 +0200 Subject: [PATCH] Add unittests for the BasicTypes module MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This adds test properties for the various laws that the instances of Result should follow; I could not find (offline) laws about `mappend', but otherwise I implemented all laws that I could find. Note that we have to silence hlint warnings for the things we want to test, as otherwise hlint is all "this is already true based on the functor law, why 'fmap id' and not just 'id'?". Signed-off-by: Iustin Pop Reviewed-by: René Nussbaumer --- Makefile.am | 1 + htest/Test/Ganeti/BasicTypes.hs | 143 ++++++++++++++++++++++++++++++++ htest/test.hs | 4 +- 3 files changed, 147 insertions(+), 1 deletion(-) create mode 100644 htest/Test/Ganeti/BasicTypes.hs diff --git a/Makefile.am b/Makefile.am index b5166412f..8b3e539c9 100644 --- a/Makefile.am +++ b/Makefile.am @@ -438,6 +438,7 @@ HS_LIB_SRCS = \ htools/Ganeti/THH.hs HS_TEST_SRCS = \ + htest/Test/Ganeti/BasicTypes.hs \ htest/Test/Ganeti/Confd/Utils.hs \ htest/Test/Ganeti/HTools/CLI.hs \ htest/Test/Ganeti/HTools/Cluster.hs \ diff --git a/htest/Test/Ganeti/BasicTypes.hs b/htest/Test/Ganeti/BasicTypes.hs new file mode 100644 index 000000000..eacdfbabc --- /dev/null +++ b/htest/Test/Ganeti/BasicTypes.hs @@ -0,0 +1,143 @@ +{-# 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 + ] diff --git a/htest/test.hs b/htest/test.hs index cb0f2c82e..899db7ed8 100644 --- a/htest/test.hs +++ b/htest/test.hs @@ -30,6 +30,7 @@ import Test.Framework import System.Environment (getArgs) import Test.Ganeti.TestImports () +import Test.Ganeti.BasicTypes import Test.Ganeti.Confd.Utils import Test.Ganeti.HTools.CLI import Test.Ganeti.HTools.Cluster @@ -73,7 +74,8 @@ slow = fast -- | All our defined tests. allTests :: [(Bool, (String, [Test]))] allTests = - [ (True, testConfd_Utils) + [ (True, testBasicTypes) + , (True, testConfd_Utils) , (True, testHTools_CLI) , (True, testHTools_Container) , (True, testHTools_Instance) -- GitLab