{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, TupleSections,TypeFamilies #-}
import Control.Exception (ErrorCall(..), try)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Random (evalRand, Rand, RandT)
import Data.Functor.Identity (Identity)
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.List (sort)
import qualified Data.Map.Strict as M
import Data.Maybe (fromJust, isNothing)
import Data.Ord (Down(..))
import System.Random (getStdGen, mkStdGen, RandomGen, StdGen)
import Test.Hspec
import Test.Hspec.Core.Spec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import ADEL
main :: IO ()
main = hspec $ do
describe "minimalSubmapSatisfying" $ do
before getStdGen $ do
it "finds the minimal submap of empty maps" $ idRand $ do
res <- minimalSubmapSatisfying
(makeSizedMap 0)
(const (return True))
return (res `shouldBe` M.empty)
it "finds a subset of size 5" $ idRand $ do
res <- minimalSubmapSatisfying
(makeSizedMap 200)
(\m -> return $ M.size m >= 5)
return (res `shouldSatisfy` (\m -> M.size m == 5))
prop "finds a subset of arbitrary size" $
\sizeA sizeB -> idRand $ do
let [NonNegative smaller, NonNegative bigger] =
sort [sizeA, sizeB]
submap <- minimalSubmapSatisfying
(makeSizedMap bigger)
(\m -> return $ M.size m >= smaller)
return $ M.size submap == smaller
prop "finds a specific arbitrary subset" $
\nums -> not (null nums) ==> idRand $ do
let nums' :: [Int] = map (\(Down n) -> n) $ sort $
map (Down . getPositive) nums
bigSet = makeSizedMap (head nums')
subsetNums = M.fromList $ map (,()) $ tail nums'
res <- minimalSubmapSatisfying
bigSet
(return . M.isSubmapOf subsetNums)
return $ res == subsetNums
prop
"throws an exception if the property is not true of the argument"
$ \size -> ioProperty $ do
res <- try (minimalSubmapSatisfying
(makeSizedMap size)
(return . const False))
case res of
Left (ErrorCall _) -> return True
_ -> return False
describe "minimalDifferenceSatisfying" $ do
prop "finds minimal additions to an empty set"
$ \(els :: [(Int, ())]) -> idRand $ do
let targetSet = M.fromList els
res <- minimalDifferenceSatisfying
M.empty
targetSet
(\s -> return $ targetSet `M.isSubmapOf` s)
return $ res == fmap Added targetSet
prop "adds the minimal set with arbitrary false and true parameters"
$ \(elsTrue :: [(Int, ())]) cutoff (elsFalse :: [(Int, ())]) ->
cutoff < length elsTrue &&
disjoint (M.fromList elsTrue) (M.fromList elsFalse) ==>
idRand $ do
let alreadyThere = M.fromList $ take cutoff elsTrue
falseSet = M.fromList elsFalse
trueSet = M.fromList elsTrue
expectedResult = fmap Added (M.difference trueSet alreadyThere)
res <- minimalDifferenceSatisfying
(falseSet `M.union` alreadyThere)
(falseSet `M.union` trueSet)
(\s -> return $ trueSet `M.isSubmapOf` s)
return $ res === expectedResult
prop "removes the correct arbitrary element" $
\(els1 :: [(Int, Char)])
(els2 :: [(Int, Char)])
(toRemove :: (Int, Char)) -> idRand $ do
let trueSet = M.delete (fst toRemove) (M.fromList els1)
falseSet = uncurry M.insert toRemove $ M.fromList els2
res <- minimalDifferenceSatisfying
falseSet
trueSet
(return . isNothing . M.lookup (fst toRemove))
return (res === M.singleton (fst toRemove) Removed)
disjoint :: (Ord k, Eq v) => M.Map k v -> M.Map k v -> Bool
disjoint m1 m2 = M.intersection m1 m2 == M.empty
instance RandomGen g => Example (RandT g Identity Expectation) where
type Arg (RandT g Identity Expectation) = g
evaluateExample randEx params act progressCallback = do
resRef <- newIORef Nothing
act $ \gen -> writeIORef resRef $ Just $ evalRand randEx gen
res <- fromJust <$> readIORef resRef
evaluateExample res params (\act' -> act' ()) progressCallback
instance Arbitrary StdGen where
arbitrary = mkStdGen <$> arbitrary
idRand :: Rand StdGen a -> Rand StdGen a
idRand = id
makeSizedMap :: Int -> M.Map Int ()
makeSizedMap 0 = M.empty
makeSizedMap n | n > 0 = M.insert n () $ makeSizedMap (n-1)
| otherwise = error "makeSizedMap negative"
instance Testable prop => Testable (Rand StdGen prop) where
property randAct = property $ \g -> evalRand randAct g