code.grnet.gr Git - ganeti-local/blob - test/hs/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, 2013 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:
  60 --
  61 -- > fmap id == id
  62 prop_functor_id :: Result Int -> Property
  63 prop_functor_id ri =
  64   fmap id ri ==? ri
  65
  66 -- | Tests the functor composition law:
  67 --
  68 -- > fmap (f . g)  ==  fmap f . fmap g
  69 prop_functor_composition :: Result Int
  70                          -> Fun Int Int -> Fun Int Int -> Property
  71 prop_functor_composition ri (Fun _ f) (Fun _ g) =
  72   fmap (f . g) ri ==? (fmap f . fmap g) ri
  73
  74 -- | Tests the applicative identity law:
  75 --
  76 -- > pure id <*> v = v
  77 prop_applicative_identity :: Result Int -> Property
  78 prop_applicative_identity v =
  79   pure id <*> v ==? v
  80
  81 -- | Tests the applicative composition law:
  82 --
  83 -- > pure (.) <*> u <*> v <*> w = u <*> (v <*> w)
  84 prop_applicative_composition :: Result (Fun Int Int)
  85                              -> Result (Fun Int Int)
  86                              -> Result Int
  87                              -> Property
  88 prop_applicative_composition u v w =
  89   let u' = fmap apply u
  90       v' = fmap apply v
  91   in pure (.) <*> u' <*> v' <*> w ==? u' <*> (v' <*> w)
  92
  93 -- | Tests the applicative homomorphism law:
  94 --
  95 -- > pure f <*> pure x = pure (f x)
  96 prop_applicative_homomorphism :: Fun Int Int -> Int -> Property
  97 prop_applicative_homomorphism (Fun _ f) x =
  98   ((pure f <*> pure x)::Result Int) ==? pure (f x)
  99
 100 -- | Tests the applicative interchange law:
 101 --
 102 -- > u <*> pure y = pure ($ y) <*> u
 103 prop_applicative_interchange :: Result (Fun Int Int)
 104                              -> Int -> Property
 105 prop_applicative_interchange f y =
 106   let u = fmap apply f -- need to extract the actual function from Fun
 107   in u <*> pure y ==? pure ($ y) <*> u
 108
 109 -- | Tests the applicative\/functor correspondence:
 110 --
 111 -- > fmap f x = pure f <*> x
 112 prop_applicative_functor :: Fun Int Int -> Result Int -> Property
 113 prop_applicative_functor (Fun _ f) x =
 114   fmap f x ==? pure f <*> x
 115
 116 -- | Tests the applicative\/monad correspondence:
 117 --
 118 -- > pure = return
 119 --
 120 -- > (<*>) = ap
 121 prop_applicative_monad :: Int -> Result (Fun Int Int) -> Property
 122 prop_applicative_monad v f =
 123   let v' = pure v :: Result Int
 124       f' = fmap apply f -- need to extract the actual function from Fun
 125   in v' ==? return v .&&. (f' <*> v') ==? f' `ap` v'
 126
 127 -- | Tests the monad laws:
 128 --
 129 -- > return a >>= k == k a
 130 --
 131 -- > m >>= return == m
 132 --
 133 -- > m >>= (\x -> k x >>= h) == (m >>= k) >>= h
 134 prop_monad_laws :: Int -> Result Int
 135                 -> Fun Int (Result Int)
 136                 -> Fun Int (Result Int)
 137                 -> Property
 138 prop_monad_laws a m (Fun _ k) (Fun _ h) =
 139   conjoin
 140   [ printTestCase "return a >>= k == k a" ((return a >>= k) ==? k a)
 141   , printTestCase "m >>= return == m" ((m >>= return) ==? m)
 142   , printTestCase "m >>= (\\x -> k x >>= h) == (m >>= k) >>= h)"
 143     ((m >>= (\x -> k x >>= h)) ==? ((m >>= k) >>= h))
 144   ]
 145
 146 -- | Tests the monad plus laws:
 147 --
 148 -- > mzero >>= f = mzero
 149 --
 150 -- > v >> mzero = mzero
 151 prop_monadplus_mzero :: Result Int -> Fun Int (Result Int) -> Property
 152 prop_monadplus_mzero v (Fun _ f) =
 153   printTestCase "mzero >>= f = mzero" ((mzero >>= f) ==? mzero) .&&.
 154   -- FIXME: since we have "many" mzeros, we can't test for equality,
 155   -- just that we got back a 'Bad' value; I'm not sure if this means
 156   -- our MonadPlus instance is not sound or not...
 157   printTestCase "v >> mzero = mzero" (isBad (v >> mzero))
 158
 159 testSuite "BasicTypes"
 160   [ 'prop_functor_id
 161   , 'prop_functor_composition
 162   , 'prop_applicative_identity
 163   , 'prop_applicative_composition
 164   , 'prop_applicative_homomorphism
 165   , 'prop_applicative_interchange
 166   , 'prop_applicative_functor
 167   , 'prop_applicative_monad
 168   , 'prop_monad_laws
 169   , 'prop_monadplus_mzero
 170   ]