diff --git a/haxl.cabal b/haxl.cabal --- a/haxl.cabal +++ b/haxl.cabal @@ -1,5 +1,5 @@ name: haxl -version: 0.4.0.0 +version: 0.4.0.1 synopsis: A Haskell library for efficient, concurrent, and concise data access. homepage: https://github.com/facebook/Haxl @@ -113,12 +113,17 @@ TestMain.hs other-modules: + AdoTests + AllTests BatchTests + Bench CoreTests DataCacheTest ExampleDataSource LoadCache + MemoizationTests MockTAO + ProfileTests TestExampleDataSource TestTypes TestUtils diff --git a/tests/AdoTests.hs b/tests/AdoTests.hs new file mode 100644 --- /dev/null +++ b/tests/AdoTests.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE RebindableSyntax, OverloadedStrings, ApplicativeDo #-} +module AdoTests (tests) where + +import TestUtils +import MockTAO + +import Control.Applicative +import Test.HUnit + +import Prelude() +import Haxl.Prelude + +-- ----------------------------------------------------------------------------- + +-- +-- Test ApplicativeDo batching +-- +ado1 = expectRounds 1 12 ado1_ + +ado1_ = do + a <- friendsOf =<< id1 + b <- friendsOf =<< id2 + return (length (a ++ b)) + +ado2 = expectRounds 1 12 ado2_ + +ado2_ = do + x <- id1 + a <- friendsOf x + y <- id2 + b <- friendsOf y + return (length (a ++ b)) + +ado3 = expectRounds 2 11 ado3_ + +ado3_ = do + x <- id1 + a <- friendsOf x + a' <- friendsOf =<< if null a then id3 else id4 + y <- id2 + b <- friendsOf y + b' <- friendsOf =<< if null b then id4 else id3 + return (length (a' ++ b')) + +tests = TestList + [ TestLabel "ado1" $ TestCase ado1 + , TestLabel "ado2" $ TestCase ado2 + , TestLabel "ado3" $ TestCase ado3 + ] diff --git a/tests/AllTests.hs b/tests/AllTests.hs new file mode 100644 --- /dev/null +++ b/tests/AllTests.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +module AllTests (allTests) where + +import TestExampleDataSource +import BatchTests +import CoreTests +import DataCacheTest +#ifdef HAVE_APPLICATIVEDO +import AdoTests +#endif +#if __GLASGOW_HASKELL__ >= 710 +import ProfileTests +#endif +import MemoizationTests + +import Test.HUnit + +allTests :: Test +allTests = TestList + [ TestLabel "ExampleDataSource" TestExampleDataSource.tests + , TestLabel "BatchTests" BatchTests.tests + , TestLabel "CoreTests" CoreTests.tests + , TestLabel "DataCacheTests" DataCacheTest.tests +#ifdef HAVE_APPLICATIVEDO + , TestLabel "AdoTests" AdoTests.tests +#endif +#if __GLASGOW_HASKELL__ >= 710 + , TestLabel "ProfileTests" ProfileTests.tests +#endif + , TestLabel "MemoizationTests" MemoizationTests.tests + ] diff --git a/tests/Bench.hs b/tests/Bench.hs new file mode 100644 --- /dev/null +++ b/tests/Bench.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE RankNTypes, GADTs, BangPatterns, DeriveDataTypeable, + StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-type-defaults #-} + +module Bench where + +import Haxl.Core.DataCache as DataCache +import Haxl.Core.Types + +import Prelude hiding (mapM) + +import Data.Hashable +import Data.Time.Clock +import Data.Traversable +import Data.Typeable +import System.Environment +import Text.Printf + +data TestReq a where + ReqInt :: {-# UNPACK #-} !Int -> TestReq Int + ReqDouble :: {-# UNPACK #-} !Int -> TestReq Double + ReqBool :: {-# UNPACK #-} !Int -> TestReq Bool + deriving Typeable + +deriving instance Eq (TestReq a) +deriving instance Show (TestReq a) + +instance Hashable (TestReq a) where + hashWithSalt salt (ReqInt i) = hashWithSalt salt (0::Int, i) + hashWithSalt salt (ReqDouble i) = hashWithSalt salt (1::Int, i) + hashWithSalt salt (ReqBool i) = hashWithSalt salt (2::Int, i) + +main = do + [n] <- fmap (fmap read) getArgs + t0 <- getCurrentTime + let + f 0 !cache = return cache + f !n !cache = do + m <- newResult 0 + f (n-1) (DataCache.insert (ReqInt n) m cache) + -- + cache <- f n emptyDataCache + let m = DataCache.lookup (ReqInt (n `div` 2)) cache + print =<< mapM takeResult m + t1 <- getCurrentTime + printf "insert: %.2fs\n" (realToFrac (t1 `diffUTCTime` t0) :: Double) + + t0 <- getCurrentTime + let + f 0 !m = return m + f !n !m = case DataCache.lookup (ReqInt n) cache of + Nothing -> f (n-1) m + Just _ -> f (n-1) (m+1) + f n 0 >>= print + t1 <- getCurrentTime + printf "lookup: %.2fs\n" (realToFrac (t1 `diffUTCTime` t0) :: Double) diff --git a/tests/MemoizationTests.hs b/tests/MemoizationTests.hs new file mode 100644 --- /dev/null +++ b/tests/MemoizationTests.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +module MemoizationTests (tests) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +import Data.IORef + +import Test.HUnit + +import Haxl.Core +import Haxl.Core.Monad + +import ExampleDataSource + +memoSoundness :: Test +memoSoundness = TestCase $ do + iEnv <- do + exState <- ExampleDataSource.initGlobalState + initEnv (stateSet exState stateEmpty) () + + unMemoizedWombats <- runHaxl iEnv $ listWombats 100 + + (initialGet, subsequentGet) <- runHaxl iEnv $ do + wombatsMemo <- newMemoWith (listWombats 100) + let memoizedWombats = runMemo wombatsMemo + + initialGet <- memoizedWombats + subsequentGet <- memoizedWombats + + return (initialGet, subsequentGet) + + assertBool "Memo Soundness 1" $ initialGet == unMemoizedWombats + assertBool "Memo Soundness 2" $ subsequentGet == unMemoizedWombats + + let impure runCounterRef = unsafeLiftIO $ do + modifyIORef runCounterRef succ + readIORef runCounterRef + + initialRunCounter = 0 :: Int + + runCounterRef <- newIORef initialRunCounter + + (initialImpureGet, subsequentImpureGet) <- runHaxl iEnv $ do + impureMemo <- newMemoWith (impure runCounterRef) + let memoizedImpure = runMemo impureMemo + + initialImpureGet <- memoizedImpure + subsequentImpureGet <- memoizedImpure + + return (initialImpureGet, subsequentImpureGet) + + assertBool "Memo Soundness 3" $ initialImpureGet == succ initialRunCounter + assertBool "Memo Soundness 4" $ subsequentImpureGet == initialImpureGet + + let fMemoVal = 42 :: Int + + dependentResult <- runHaxl iEnv $ do + fMemoRef <- newMemo + gMemoRef <- newMemo + + let f = runMemo fMemoRef + g = runMemo gMemoRef + + prepareMemo fMemoRef $ return fMemoVal + prepareMemo gMemoRef $ succ <$> f + + a <- f + b <- g + return (a + b) + + assertBool "Memo Soundness 5" $ dependentResult == fMemoVal + succ fMemoVal + +tests = TestList [TestLabel "Memo Soundness" memoSoundness] diff --git a/tests/ProfileTests.hs b/tests/ProfileTests.hs new file mode 100644 --- /dev/null +++ b/tests/ProfileTests.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module ProfileTests where + +import Haxl.Prelude +import Data.List + +import Haxl.Core +import Haxl.Core.Monad + +import Test.HUnit + +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Data.IORef +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet + +import TestUtils + +mkProfilingEnv = do + env <- makeTestEnv + return env { flags = (flags env) { report = 4 } } + +collectsdata :: Assertion +collectsdata = do + env <- mkProfilingEnv + _x <- runHaxl env $ + withLabel "bar" $ + withLabel "foo" $ + if length (intersect ["a"::Text, "b"] ["c"]) > 1 + then return 5 + else return (4::Int) + profData <- profile <$> readIORef (profRef env) + assertEqual "has data" 3 $ HashMap.size profData + assertBool "foo allocates" $ + case profileAllocs <$> HashMap.lookup "foo" profData of + Just x -> x > 0 + Nothing -> False + assertEqual "bar does not allocate" (Just 0) $ + profileAllocs <$> HashMap.lookup "bar" profData + assertEqual "foo's parent" (Just ["bar"]) $ + HashSet.toList . profileDeps <$> HashMap.lookup "foo" profData + +exceptions :: Assertion +exceptions = do + env <- mkProfilingEnv + _x <- runHaxl env $ + withLabel "outer" $ + tryToHaxlException $ withLabel "inner" $ + unsafeLiftIO $ evaluate $ force (error "pure exception" :: Int) + profData <- profile <$> readIORef (profRef env) + assertBool "inner label not added" $ + not $ HashMap.member "inner" profData + + env2 <- mkProfilingEnv + _x <- runHaxl env2 $ + withLabel "outer" $ + tryToHaxlException $ withLabel "inner" $ + throw $ NotFound "haxl exception" + profData <- profile <$> readIORef (profRef env2) + assertBool "inner label added" $ + HashMap.member "inner" profData + +tests = TestList + [ TestLabel "collectsdata" $ TestCase collectsdata + , TestLabel "exceptions" $ TestCase exceptions + ]