code.grnet.gr Git - ganeti-local/blob - htest/Test/Ganeti/BasicTypes.hs

   1 {-# LANGUAGE TemplateHaskell, FlexibleInstances, TypeSynonymInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3
   4 {-| Unittests for ganeti-htools.
   5
   6 -}
   7
   8 {-
   9
  10 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
  11
  12 This program is free software; you can redistribute it and/or modify
  13 it under the terms of the GNU General Public License as published by
  14 the Free Software Foundation; either version 2 of the License, or
  15 (at your option) any later version.
  16
  17 This program is distributed in the hope that it will be useful, but
  18 WITHOUT ANY WARRANTY; without even the implied warranty of
  19 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 General Public License for more details.
  21
  22 You should have received a copy of the GNU General Public License
  23 along with this program; if not, write to the Free Software
  24 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  25 02110-1301, USA.
  26
  27 -}
  28
  29 module Test.Ganeti.BasicTypes (testBasicTypes) where
  30
  31 import Test.QuickCheck hiding (Result)
  32 import Test.QuickCheck.Function
  33
  34 import Control.Applicative
  35 import Control.Monad
  36
  37 import Test.Ganeti.TestHelper
  38 import Test.Ganeti.TestCommon
  39
  40 import Ganeti.BasicTypes
  41
  42 -- Since we actually want to test these, don't tell us not to use them :)
  43
  44 {-# ANN module "HLint: ignore Functor law" #-}
  45 {-# ANN module "HLint: ignore Monad law, left identity" #-}
  46 {-# ANN module "HLint: ignore Monad law, right identity" #-}
  47 {-# ANN module "HLint: ignore Use >=>" #-}
  48 {-# ANN module "HLint: ignore Use ." #-}
  49
  50 -- * Arbitrary instances
  51
  52 instance (Arbitrary a) => Arbitrary (Result a) where
  53   arbitrary = oneof [ Bad <$> arbitrary
  54                     , Ok  <$> arbitrary
  55                     ]
  56
  57 -- * Test cases
  58
  59 -- | Tests the functor identity law (fmap id == id).
  60 prop_functor_id :: Result Int -> Property
  61 prop_functor_id ri =
  62   fmap id ri ==? ri
  63
  64 -- | Tests the functor composition law (fmap (f . g)  ==  fmap f . fmap g).
  65 prop_functor_composition :: Result Int
  66                          -> Fun Int Int -> Fun Int Int -> Property
  67 prop_functor_composition ri (Fun _ f) (Fun _ g) =
  68   fmap (f . g) ri ==? (fmap f . fmap g) ri
  69
  70 -- | Tests the applicative identity law (pure id <*> v = v).
  71 prop_applicative_identity :: Result Int -> Property
  72 prop_applicative_identity v =
  73   pure id <*> v ==? v
  74
  75 -- | Tests the applicative composition law (pure (.) <*> u <*> v <*> w
  76 -- = u <*> (v <*> w)).
  77 prop_applicative_composition :: Result (Fun Int Int)
  78                              -> Result (Fun Int Int)
  79                              -> Result Int
  80                              -> Property
  81 prop_applicative_composition u v w =
  82   let u' = fmap apply u
  83       v' = fmap apply v
  84   in pure (.) <*> u' <*> v' <*> w ==? u' <*> (v' <*> w)
  85
  86 -- | Tests the applicative homomorphism law (pure f <*> pure x = pure (f x)).
  87 prop_applicative_homomorphism :: Fun Int Int -> Int -> Property
  88 prop_applicative_homomorphism (Fun _ f) x =
  89   ((pure f <*> pure x)::Result Int) ==? pure (f x)
  90
  91 -- | Tests the applicative interchange law (u <*> pure y = pure ($ y) <*> u).
  92 prop_applicative_interchange :: Result (Fun Int Int)
  93                              -> Int -> Property
  94 prop_applicative_interchange f y =
  95   let u = fmap apply f -- need to extract the actual function from Fun
  96   in u <*> pure y ==? pure ($ y) <*> u
  97
  98 -- | Tests the applicative\/functor correspondence (fmap f x = pure f <*> x).
  99 prop_applicative_functor :: Fun Int Int -> Result Int -> Property
 100 prop_applicative_functor (Fun _ f) x =
 101   fmap f x ==? pure f <*> x
 102
 103 -- | Tests the applicative\/monad correspondence (pure = return and
 104 -- (<*>) = ap).
 105 prop_applicative_monad :: Int -> Result (Fun Int Int) -> Property
 106 prop_applicative_monad v f =
 107   let v' = pure v :: Result Int
 108       f' = fmap apply f -- need to extract the actual function from Fun
 109   in v' ==? return v .&&. (f' <*> v') ==? f' `ap` v'
 110
 111 -- | Tests the monad laws (return a >>= k == k a, m >>= return == m, m
 112 -- >>= (\x -> k x >>= h) == (m >>= k) >>= h).
 113 prop_monad_laws :: Int -> Result Int
 114                 -> Fun Int (Result Int)
 115                 -> Fun Int (Result Int)
 116                 -> Property
 117 prop_monad_laws a m (Fun _ k) (Fun _ h) =
 118   conjoin
 119   [ printTestCase "return a >>= k == k a" ((return a >>= k) ==? k a)
 120   , printTestCase "m >>= return == m" ((m >>= return) ==? m)
 121   , printTestCase "m >>= (\\x -> k x >>= h) == (m >>= k) >>= h)"
 122     ((m >>= (\x -> k x >>= h)) ==? ((m >>= k) >>= h))
 123   ]
 124
 125 -- | Tests the monad plus laws ( mzero >>= f = mzero, v >> mzero = mzero).
 126 prop_monadplus_mzero :: Result Int -> Fun Int (Result Int) -> Property
 127 prop_monadplus_mzero v (Fun _ f) =
 128   printTestCase "mzero >>= f = mzero" ((mzero >>= f) ==? mzero) .&&.
 129   -- FIXME: since we have "many" mzeros, we can't test for equality,
 130   -- just that we got back a 'Bad' value; I'm not sure if this means
 131   -- our MonadPlus instance is not sound or not...
 132   printTestCase "v >> mzero = mzero" (isBad (v >> mzero))
 133
 134 testSuite "BasicTypes"
 135   [ 'prop_functor_id
 136   , 'prop_functor_composition
 137   , 'prop_applicative_identity
 138   , 'prop_applicative_composition
 139   , 'prop_applicative_homomorphism
 140   , 'prop_applicative_interchange
 141   , 'prop_applicative_functor
 142   , 'prop_applicative_monad
 143   , 'prop_monad_laws
 144   , 'prop_monadplus_mzero
 145   ]