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

   1 {-# LANGUAGE TemplateHaskell #-}
   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
  49 -- * Arbitrary instances
  50
  51 instance (Arbitrary a) => Arbitrary (Result a) where
  52   arbitrary = oneof [ Bad <$> arbitrary
  53                     , Ok  <$> arbitrary
  54                     ]
  55
  56 -- * Test cases
  57
  58 -- | Tests the functor identity law (fmap id == id).
  59 prop_functor_id :: Result Int -> Property
  60 prop_functor_id ri =
  61   fmap id ri ==? ri
  62
  63 -- | Tests the functor composition law (fmap (f . g)  ==  fmap f . fmap g).
  64 prop_functor_composition :: Result Int
  65                          -> Fun Int Int -> Fun Int Int -> Property
  66 prop_functor_composition ri (Fun _ f) (Fun _ g) =
  67   fmap (f . g) ri ==? (fmap f . fmap g) ri
  68
  69 -- | Tests the applicative identity law (pure id <*> v = v).
  70 prop_applicative_identity :: Result Int -> Property
  71 prop_applicative_identity v =
  72   pure id <*> v ==? v
  73
  74 -- | Tests the applicative composition law (pure (.) <*> u <*> v <*> w
  75 -- = u <*> (v <*> w)).
  76 prop_applicative_composition :: (Result (Fun Int Int))
  77                              -> (Result (Fun Int Int))
  78                              -> Result Int
  79                              -> Property
  80 prop_applicative_composition u v w =
  81   let u' = fmap apply u
  82       v' = fmap apply v
  83   in pure (.) <*> u' <*> v' <*> w ==? u' <*> (v' <*> w)
  84
  85 -- | Tests the applicative homomorphism law (pure f <*> pure x = pure (f x)).
  86 prop_applicative_homomorphism :: Fun Int Int -> Int -> Property
  87 prop_applicative_homomorphism (Fun _ f) x =
  88   ((pure f <*> pure x)::Result Int) ==?
  89   (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   printTestCase "return a >>= k == k a" ((return a >>= k) ==? k a) .&&.
 119   printTestCase "m >>= return == m" ((m >>= return) ==? m) .&&.
 120   printTestCase "m >>= (\\x -> k x >>= h) == (m >>= k) >>= h)"
 121     ((m >>= (\x -> k x >>= h)) ==? ((m >>= k) >>= h))
 122
 123 -- | Tests the monad plus laws ( mzero >>= f = mzero, v >> mzero = mzero).
 124 prop_monadplus_mzero :: Result Int -> Fun Int (Result Int) -> Property
 125 prop_monadplus_mzero v (Fun _ f) =
 126   printTestCase "mzero >>= f = mzero" ((mzero >>= f) ==? mzero) .&&.
 127   -- FIXME: since we have "many" mzeros, we can't test for equality,
 128   -- just that we got back a 'Bad' value; I'm not sure if this means
 129   -- our MonadPlus instance is not sound or not...
 130   printTestCase "v >> mzero = mzero" (isBad (v >> mzero))
 131
 132 testSuite "BasicTypes"
 133   [ 'prop_functor_id
 134   , 'prop_functor_composition
 135   , 'prop_applicative_identity
 136   , 'prop_applicative_composition
 137   , 'prop_applicative_homomorphism
 138   , 'prop_applicative_interchange
 139   , 'prop_applicative_functor
 140   , 'prop_applicative_monad
 141   , 'prop_monad_laws
 142   , 'prop_monadplus_mzero
 143   ]