diff --git a/hunt-searchengine.cabal b/hunt-searchengine.cabal --- a/hunt-searchengine.cabal +++ b/hunt-searchengine.cabal @@ -1,5 +1,5 @@ name: hunt-searchengine -version: 0.3.0.0 +version: 0.3.0.1 license: MIT license-file: LICENSE author: Chris Reumann, Ulf Sauer, Uwe Schmidt @@ -134,6 +134,16 @@ test-suite Hunt-Tests hs-source-dirs: test main-is: Hunt.hs + other-modules: Hunt.AnalyzerTests + Hunt.IndexTests + Hunt.InterpreterTests + Hunt.QueryParserTests + Hunt.TestHelper + Hunt.Index.ContextIndexTests + Hunt.Index.Default + Hunt.Index.Helper + Hunt.Index.IndexValueTests + type: exitcode-stdio-1.0 ghc-options: -Wall extensions: OverloadedStrings @@ -161,6 +171,11 @@ test-suite Hunt-Strictness hs-source-dirs: test main-is: Strictness.hs + other-modules: Hunt.Strict.ContextIndex + Hunt.Strict.DocTable + Hunt.Strict.Helper + Hunt.Strict.Index + type: exitcode-stdio-1.0 ghc-options: -Wall extensions: OverloadedStrings diff --git a/test/Hunt/AnalyzerTests.hs b/test/Hunt/AnalyzerTests.hs new file mode 100644 --- /dev/null +++ b/test/Hunt/AnalyzerTests.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Hunt.AnalyzerTests +(analyzerTests) +where +{-- Tests for Normalizers Analyzers Formatters #-} + +import Hunt.TestHelper + +import qualified Data.Text as T + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit hiding (Test) +import Test.QuickCheck + +import qualified Hunt.Index.Schema.Analyze as A +import qualified Hunt.Index.Schema.Normalize.Date as ND +import qualified Hunt.Index.Schema.Normalize.Position as NP +import qualified Hunt.Index.Schema.Normalize.Int as NI + +-- ---------------------------------------------------------------------------- + +analyzerTests :: [Test] +analyzerTests = + [-- Analyzer tests + testCase "scanTextRE: text1 " test_scan_text1 + , testCase "scanTextRE: date inv" test_scan_date1 + , testCase "scanTextRE: date val" test_scan_date2 + , testCase "scanTextRE: date val multiple" test_scan_date3 + , testCase "scanTextRE: date val + inval" test_scan_date4 + , testCase "scanTextRE: date val short " test_scan_date5 + , testCase "scanTextRE: date val shorter" test_scan_date6 + + -- Normalizer data - isAnyDate + , testProperty "Normalizer: date YYYYMMDD" prop_isAnyDate + , testProperty "Normalizer: date 2013-01-01T21:12:12" prop_isAnyDate2 + , testProperty "Normalizer: date 2013" prop_isAnyDate3 + + -- Normalizer position + , testProperty "Normalizer: pos double" prop_isPosition_d + , testProperty "Normalizer: pos text" prop_isPosition_t + , testCase "Normalizer: norm pos int1" test_norm_pos + , testCase "Normalizer: norm pos int2" test_norm_pos2 + , testCase "Normalizer: norm pos dbl1" test_norm_pos4 + , testCase "Normalizer: norm pos dbl2" test_norm_pos5 + , testProperty "Normalizer: norm denorm dbl" prop_norm_pos3 + + -- Normalizer int + , testProperty "Normalizer: isInt Int" prop_isInt_int + , testProperty "Normalizer: isInt Integer" prop_isInt_integer + , testProperty "Normalizer: isInt text" prop_isInt_text + , testProperty "Normalizer: isInt double" prop_isInt_double + , testCase "Normalizer: isInt overflow" test_isInt_overflow + , testCase "Normalizer: isInt nooverflow" test_isInt_overflow2 + , testCase "Normalizer: isInt maxBound1" test_isInt_upper1 + , testCase "Normalizer: isInt maxBound2" test_isInt_upper2 + , testCase "Normalizer: isInt minBound1" test_isInt_lower1 + , testCase "Normalizer: isInt minBound2" test_isInt_lower2 + + , testProperty "Normalizer: normInt int" prop_normInt_int + , testProperty "Normalizer: normInt integer" prop_normInt_integer + , testCase "Normalizer: isInt 1" test_normInt1 + , testCase "Normalizer: isInt -1" test_normInt2 + , testCase "Normalizer: isInt maxBound" test_normInt3 + , testCase "Normalizer: isInt minBound" test_normInt4 + ] + +-- ---------------------------------------------------------------------------- +-- normalizer position tests + +prop_isInt_int :: Gen Bool +prop_isInt_int = do + val <- arbitrary :: Gen Int + return . NI.isInt . T.pack . show $ val + +prop_isInt_integer :: Gen Bool +prop_isInt_integer = do + val <- arbitrary :: Gen Integer + return . NI.isInt . T.pack .show $ val + +prop_isInt_text :: Gen Bool +prop_isInt_text = do + val <- niceText1 + return . not . NI.isInt $ val + +prop_isInt_double :: Gen Bool +prop_isInt_double = do + val <- arbitrary :: Gen Double + return . not . NI.isInt . T.pack . show $ val + +test_isInt_overflow :: Assertion +test_isInt_overflow = assertEqual "" False (NI.isInt "10000000000000000000000000000000000000") + +test_isInt_overflow2 :: Assertion +test_isInt_overflow2 = assertEqual "" True (NI.isInt "6443264") + +test_isInt_upper1 :: Assertion +test_isInt_upper1 = assertEqual "" True (NI.isInt "9223372036854775807") + +test_isInt_upper2 :: Assertion +test_isInt_upper2 = assertEqual "" False (NI.isInt "9223372036854775808") + +test_isInt_lower1 :: Assertion +test_isInt_lower1 = assertEqual "" True (NI.isInt "-9223372036854775808") + +test_isInt_lower2 :: Assertion +test_isInt_lower2 = assertEqual "" False (NI.isInt "-9223372036854775809") + +prop_normInt_int :: Gen Bool +prop_normInt_int = do + val <- arbitrary :: Gen Int + return $ 21 == T.length (NI.normalizeToText . T.pack . show $ val) + +prop_normInt_integer :: Gen Bool +prop_normInt_integer = do + val <- arbitrary :: Gen Integer + return $ 21 == T.length (NI.normalizeToText . T.pack . show $ val) + +test_normInt1 :: Assertion +test_normInt1 = assertEqual "" "100000000000000000001" (NI.normalizeToText "1") + +test_normInt2 :: Assertion +test_normInt2 = assertEqual "" "000000000000000000001" (NI.normalizeToText "-1") + +test_normInt3 :: Assertion +test_normInt3 = assertEqual "" "109223372036854775807" (NI.normalizeToText "9223372036854775807") + +test_normInt4 :: Assertion +test_normInt4 = assertEqual "" "009223372036854775808" (NI.normalizeToText "-9223372036854775808") + + +-- ---------------------------------------------------------------------------- +-- normalizer position tests + +genPos :: Gen String +genPos = do + lat <- choose (-89,89) :: Gen Int + long <- choose (-179,179) :: Gen Int + return $ concat [ show lat, ".0000001-", show long, ".0000002" ] + +prop_isPosition_d :: Gen Bool +prop_isPosition_d = do + pos <- genPos + return . NP.isPosition $ T.pack pos + +prop_isPosition_t :: Gen Bool +prop_isPosition_t = do + long <- niceText1 + lat <- niceText1 + return $ False == NP.isPosition (T.concat [ long, "-", lat ]) + +test_norm_pos :: Assertion +test_norm_pos = assertEqual "" "1100000000000000110000111100000011000011001111001100000000000000" (NP.normalize "1-1") + +test_norm_pos2 :: Assertion +test_norm_pos2 = assertEqual "" "0000000000000000110000111100000011000011001111001100000000000000" (NP.normalize "-1.00--1.000") + +test_norm_pos4 :: Assertion +test_norm_pos4 = assertEqual "" "1100000000000000110000111100000011000011001111001100000000000000" (NP.normalize "1.000000-1.000000") + +test_norm_pos5 :: Assertion +test_norm_pos5 = let pos = "-25.0000001-1.0000002" in assertEqual "" pos . NP.denormalize . NP.normalize $ pos + +prop_norm_pos3 :: Gen Property +prop_norm_pos3 = do + p <- genPos + let pos = T.pack p + let pos' = NP.denormalize . NP.normalize $ pos + return $ counterexample (p ++ " != " ++ T.unpack pos') $ pos == pos' + +-- ---------------------------------------------------------------------------- +-- normalizer date tests + +-- | test with date formatted like "2013-01-01" +-- | XXX everything fails?!?! +prop_isAnyDate :: Gen Bool +prop_isAnyDate = dateYYYYMMDD >>= return . ND.isAnyDate . T.unpack + +prop_isAnyDate2 :: Gen Bool +prop_isAnyDate2 = return . ND.isAnyDate $ "2013-01-01T21:12:12" + +prop_isAnyDate3 :: Gen Bool +prop_isAnyDate3 = return . ND.isAnyDate $ "2013" + +-- ---------------------------------------------------------------------------- +-- normalizer tests - validation +{-- depricated +-- | every random text should be a valid text +prop_validate_text :: Gen Bool +prop_validate_text = niceText1 >>= return . (N.typeValidator S.CText) + +-- | every integer numbers should be valid numbers +prop_validate_int :: Gen Bool +prop_validate_int = do + int <- arbitrary :: Gen Integer + return $ N.typeValidator S.CInt (T.pack . show $ int) + +-- | random text should not be considered a valid number +prop_validate_int2 :: Gen Bool +prop_validate_int2 = niceText1 >>= \t -> return $ False == N.typeValidator S.CInt ("a" `T.append` t) + +-- | date formated "yyyy-mm-dd" should be valid +prop_validate_date :: Gen Bool +prop_validate_date = dateYYYYMMDD >>= return . (N.typeValidator S.CDate) + +-- | random text should not be considered a valid date +prop_validate_date2 :: Gen Bool +prop_validate_date2 = niceText1 >>= \d -> return $ False == N.typeValidator S.CDate d +--} +-- ---------------------------------------------------------------------------- +-- scan tests + +-- | test general text regex +test_scan_text1 :: Assertion +test_scan_text1 = assert $ length scan == 3 + where + scan = A.scanTextRE "[^ \t\n\r]*" "w1 w2 w3" + +-- | test date regex with invalid date given +test_scan_date1 :: Assertion +test_scan_date1 = assert $ length scan == 0 + where + scan = A.scanTextRE "[0-9]{4}-((0[1-9])|(1[0-2]))-((0[1-9])|([12][0-9])|(3[01]))" "w1 w2 w3" + +-- | test date regex with valid date given +test_scan_date2 :: Assertion +test_scan_date2 = assert $ length scan == 1 + where + scan = A.scanTextRE "[0-9]{4}-((0[1-9])|(1[0-2]))-((0[1-9])|([12][0-9])|(3[01]))" "2013-01-01" + +-- | test date regex with multiple dates given +test_scan_date3 :: Assertion +test_scan_date3 = assert $ length scan == 2 + where + scan = A.scanTextRE "[0-9]{4}-((0[1-9])|(1[0-2]))-((0[1-9])|([12][0-9])|(3[01]))" "2013-01-01 2012-12-31" + +-- | test date regex with date containing string +test_scan_date4 :: Assertion +test_scan_date4 = assert $ (length scan == 2) && (scan !! 1 == "2013-01-01") + where + scan = A.scanTextRE "[0-9]{4}-((0[1-9])|(1[0-2]))-((0[1-9])|([12][0-9])|(3[01]))" "2013-01-01 asd 2013-01-01" + +-- | test date regex with invalid date given +test_scan_date5 :: Assertion +test_scan_date5 = assert $ length scan == 0 + where + scan = A.scanTextRE "[0-9]{4}-((0[1-9])|(1[0-2]))-((0[1-9])|([12][0-9])|(3[01]))" "2013-01" + +-- | test date regex with invalid date given +test_scan_date6 :: Assertion +test_scan_date6 = assert $ length scan == 0 + where + scan = A.scanTextRE "[0-9]{4}-((0[1-9])|(1[0-2]))-((0[1-9])|([12][0-9])|(3[01]))" "2013" diff --git a/test/Hunt/Index/ContextIndexTests.hs b/test/Hunt/Index/ContextIndexTests.hs new file mode 100644 --- /dev/null +++ b/test/Hunt/Index/ContextIndexTests.hs @@ -0,0 +1,65 @@ +module Hunt.Index.ContextIndexTests +(contextIndexTests) +where + +import Data.Maybe +import Control.Monad + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +import Test.QuickCheck +import Test.QuickCheck.Monadic + +import Hunt.Common.Document + +import qualified Hunt.ContextIndex as ConIx +import qualified Hunt.DocTable as Dt +import Hunt.TestHelper + +contextIndexTests :: [Test] +contextIndexTests + -- XXX todo: test schema insertion on contextinsert. (ignored right now) + = [ testCase "ContextIndex: insert context" test_insert_cx + , testCase "ContextIndex: delete context" test_delete_cx + , testProperty "ContextIndex: insertList" test_insertlist + ] + +-- ---------------------------------------------------------------------------- +-- helpers +-- ---------------------------------------------------------------------------- + +-- | check insert context on ContextIndex +test_insert_cx :: Assertion +test_insert_cx + = True @?= length after == 1 && head after == cxName + where + cxName = "context" + (ConIx.ContextIndex m _) = insertCx cxName + after = ConIx.contexts m + +test_delete_cx :: Assertion +test_delete_cx + = True @?= length before == 1 && length after == 0 + where + context = "context" + cix@(ConIx.ContextIndex m _) = insertCx context + before = ConIx.contexts m + (ConIx.ContextIndex m' _ ) = ConIx.deleteContext context cix + after = ConIx.contexts m' + +-- | check insert on ContextIndex +test_insertlist :: Property +test_insertlist + = monadicIO $ do + -- insert random documents and docIds + documents <- pick mkDocuments + let cxIx = insertCx "context" + insertData <- pick $ mkInsertList $ documents + (ConIx.ContextIndex _ dt) <- ConIx.insertList insertData cxIx + -- check if docuemnts are in document table + docsTrue <- foldM (\b doc -> Dt.lookupByURI (uri doc) dt >>= \mid -> return (b && isJust mid)) True documents + -- check if documents are in index + -- XXX TODO + return docsTrue diff --git a/test/Hunt/Index/Default.hs b/test/Hunt/Index/Default.hs new file mode 100644 --- /dev/null +++ b/test/Hunt/Index/Default.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +module Hunt.Index.Default where + +import Data.List (null) +import Data.Text (Text, unpack) + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck.Monadic + +import Hunt.Common.BasicTypes +import qualified Hunt.Common.DocIdSet as Set +import Hunt.Index.Schema +import Hunt.Index.IndexImpl (IndexImpl(..)) + +import qualified Hunt.Index as Ix +import Hunt.Index.Helper + +-- ---------------------------------------------------------------------------- +-- Testsuite for `ContextType`s and underlying `Index` implementations +-- +-- Note: To test new `ContextType`s, just add the respective `ContextType` to +-- the `contextTypes` below. + +-- | TestSuite for `Index` interface +tests :: [Test] +tests = concat $ map testIndex contextTypes + +-- | list of `ContextType`s and a valid key for each Type +contextTypes :: [(ContextType, Text)] +contextTypes = [ (ctText, "test") + , (ctTextSimple, "test") + , (ctInt, "1000") + , (ctDate, "2012-01-01") + , (ctPosition, "1-1") + , (ctPositionRTree, "1-1") + ] + +-- | TestSuite for one concrete `ContextType` or `Index` implemation +testIndex :: (ContextType, Text) -> [Test] +testIndex (CType name _ _ (IndexImpl impl), key) + = [ testProperty (mkLabel "insert") (monadicIO $ insertTest impl key) + , testProperty (mkLabel "insertList") (monadicIO $ insertListTest impl key) + , testProperty (mkLabel "delete") (monadicIO $ deleteTest impl key) + , testProperty (mkLabel "deleteDocs") (monadicIO $ deleteDocsTest impl key) + , testProperty (mkLabel "empty") (monadicIO $ emptyTest impl) + , testProperty (mkLabel "toList") (monadicIO $ toListTest impl key) + ] + where + mkLabel t = "ContextType " ++ unpack name ++ ": " ++ t + +-- ---------------------------------------------------------------------------- +-- insert tests + +-- | Test insert function of `Index` typeclass +insertTest :: (Ix.Index i, Monad m, Ix.ICon i) => i -> Ix.IKey i -> m Bool +insertTest impl key + = do + ix1 <- Ix.insertM key values impl + res <- Ix.searchM PrefixNoCase key ix1 + checkResult [values] res + where + values = simpleValue1 + +-- | Test insertList function of `Index` typeclass +insertListTest :: (Ix.Index i, Monad m, Ix.ICon i) => i -> Ix.IKey i -> m Bool +insertListTest impl key + = do + ix1 <- Ix.insertListM (addKey key values) impl + res <- Ix.searchM PrefixNoCase key ix1 + checkResult values res + where + values = [simpleValue1, simpleValue2] + +-- ---------------------------------------------------------------------------- +-- delete tests + +-- | Test delete function of 'Index' typeclass +deleteTest :: (Ix.Index i, Monad m, Ix.ICon i) => i -> Ix.IKey i -> m Bool +deleteTest impl key + = do + -- insert + ix1 <- Ix.insertListM (addKey key values) impl + rs1 <- Ix.searchM PrefixNoCase key ix1 + -- delete + ix2 <- Ix.deleteDocsM (Set.fromList [docId1, docId2]) ix1 + rs2 <- Ix.searchM PrefixNoCase key ix2 + -- check + ch1 <- checkResult values rs1 + ch2 <- checkResult [] rs2 + return $ ch1 && ch2 + where + values = [simpleValue1, simpleValue2] + +deleteDocsTest :: (Ix.Index i, Monad m, Ix.ICon i) => i -> Ix.IKey i -> m Bool +deleteDocsTest impl key + = do + -- insert + ix1 <- Ix.insertListM (addKey key values) impl + rs1 <- Ix.searchM PrefixNoCase key ix1 + -- delete + ix2 <- Ix.deleteM docId1 ix1 + rs2 <- Ix.searchM PrefixNoCase key ix2 + -- check + ch1 <- checkResult values rs1 + ch2 <- checkResult [simpleValue2] rs2 + return $ ch1 && ch2 + where + values = [simpleValue1, simpleValue2] + +-- ---------------------------------------------------------------------------- +-- test other functions + +-- | test `empty` function from `Index` typeclass +emptyTest :: (Ix.Index i, Monad m, Ix.ICon i) => i -> m Bool +emptyTest impl + = do + let ix = Ix.empty `asTypeOf` impl + return . Data.List.null $ Ix.toList ix + +-- | test `toList` function from `Index` typeclass +toListTest :: (Ix.Index i, Monad m, Ix.ICon i) => i -> Ix.IKey i -> m Bool +toListTest impl key + = do + ix1 <- Ix.insertListM (addKey key values) impl + ls <- Ix.toListM ix1 + checkResult values ls + where + values = [simpleValue1, simpleValue2] diff --git a/test/Hunt/Index/Helper.hs b/test/Hunt/Index/Helper.hs new file mode 100644 --- /dev/null +++ b/test/Hunt/Index/Helper.hs @@ -0,0 +1,50 @@ +module Hunt.Index.Helper where + +import Data.List (intersect) + +import Hunt.Common.DocId (DocId, mkDocId) +import Hunt.Common.Occurrences +import Hunt.Common.IntermediateValue + +-- ---------------------------------------------------------------------------- +-- `Index` test helpers + +docId1 :: DocId +docId1 = mkDocId (1::Int) + +docId2 :: DocId +docId2 = mkDocId (2::Int) + +fromDocId :: DocId -> IntermediateValue +fromDocId docId = toIntermediate $ singleton docId 1 + +simpleValue :: Int -> IntermediateValue +simpleValue i = toIntermediate $ singleton (mkDocId i) i + +simpleValue1 :: IntermediateValue +simpleValue1 = simpleValue 1 + +simpleValue2 :: IntermediateValue +simpleValue2 = simpleValue 2 + +simpleValue1b :: IntermediateValue +simpleValue1b = complexValue 1 2 + +complexValue :: Int -> Int -> IntermediateValue +complexValue id' pos = toIntermediate $ singleton (mkDocId id') pos + +complexValues :: IntermediateValue +complexValues = toIntermediate $ + merges [ singleton docId1 1 + , singleton docId1 2 + , singleton docId2 10 + ] + +checkResult :: Monad m => [IntermediateValue] -> [(x, IntermediateValue)] -> m Bool +checkResult vs res = return $ vs == (vs `intersect` map snd res) + +addKey :: x -> [IntermediateValue] -> [(x, IntermediateValue)] +addKey key = map (\v -> (key, v)) + + + diff --git a/test/Hunt/Index/IndexValueTests.hs b/test/Hunt/Index/IndexValueTests.hs new file mode 100644 --- /dev/null +++ b/test/Hunt/Index/IndexValueTests.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Hunt.Index.IndexValueTests where + +import Data.Maybe + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import qualified Hunt.Common.Occurrences as Occ +import Hunt.Common.Occurrences (Occurrences) +import qualified Hunt.Common.DocIdSet as Set +import Hunt.Common.DocIdSet (DocIdSet) +import Hunt.Common.IntermediateValue + +import Hunt.Index.Helper + +-- ---------------------------------------------------------------------------- +-- Testsuite for `IntermediateValue` index value instances +-- Note: To add tests for new `IndexValue` implementations, extend the `values` +-- list + +-- | List of tests +tests :: [Test] +tests = concat $ map testValue values + +testValue :: IndexValueTest -> [Test] +testValue iv@(IVT n _) + = [ testCase (mkLabel "merge" ) (assertEqual "" True $ mergeTest iv) + , testCase (mkLabel "diff" ) (assertEqual "" True $ diffTest iv) + , testCase (mkLabel "from-to") (assertEqual "" True $ conversionTest iv) + ] + where + mkLabel t = "IndexValue " ++ n ++ ": " ++ t + + +-- | Existential type to enable generic tests +data IndexValueTest + = forall v. (IndexValue v, Eq v) => IVT { name :: String, ivt :: v } + +-- | list of all tested `IndexValue` implementations wrapped in the +-- existential `IndexValueTest` type. +-- Extend list to add more implementations to test suite. +values :: [IndexValueTest] +values = [ IVT "Occurrences" (fromIntermediate simpleValue1 :: Occurrences) +-- , IVT "DocIdSet" (fromIntermediate simpleValue1 :: DocIdSet) + ] + +-- | merge test for `IndexValue` implementation. +mergeTest :: IndexValueTest -> Bool +mergeTest (IVT _ v1) + = let merge1 = mergeValues v1 v2 + merge2 = mergeValues v1 v3 + + check1 = mergeAsOcc v1 v2 == fromInt merge1 + check2 = mergeAsOcc v1 v3 == fromInt merge2 + in + check1 && check2 + where + v2 = from simpleValue1b `asTypeOf` v1 + v3 = from simpleValue2 `asTypeOf` v1 + + mergeAsOcc :: forall v. IndexValue v => v -> v -> Occurrences + mergeAsOcc i1 i2 = Occ.merge (fromInt i1) (fromInt i2) + +-- | diff test for `IndexValue` implementation +diffTest :: IndexValueTest -> Bool +diffTest (IVT _ v1) + = let diff1 = diffValues set1 v2 + diff2 = diffValues set2 (fromJust diff1) + + check1 = diffAsOcc set1 v2 + check2 = diffAsOcc set2 check1 + in + check1 == fromInt (fromJust diff1) && Occ.null check2 && isNothing diff2 + where + v2 = from complexValues `asTypeOf` v1 + set1 = Set.singleton docId1 + set2 = Set.singleton docId2 + diffAsOcc set d = Occ.diffWithSet (fromInt d) set + +-- | converstion from and to tests for `IndexValue` implementation +conversionTest :: IndexValueTest -> Bool +conversionTest (IVT _ v) = v == (fromIntermediate . toIntermediate $ v) + +-- ---------------------------------------------------------------------------- +-- Helper + +fromInt :: forall v. IndexValue v => v -> Occurrences +fromInt i = fromIntermediate . toIntermediate $ i + +from :: forall x. IndexValue x => IntermediateValue -> x +from = fromIntermediate diff --git a/test/Hunt/IndexTests.hs b/test/Hunt/IndexTests.hs new file mode 100644 --- /dev/null +++ b/test/Hunt/IndexTests.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Hunt.IndexTests +(contextTypeTests) +where + +--import qualified Data.Map as M + +import Test.Framework + +import qualified Hunt.Index.Default as Default +import qualified Hunt.Index.IndexValueTests as Value + +-- ---------------------------------------------------------------------------- + +contextTypeTests :: [Test] +contextTypeTests = concat [ Default.tests + , Value.tests + ] diff --git a/test/Hunt/InterpreterTests.hs b/test/Hunt/InterpreterTests.hs new file mode 100644 --- /dev/null +++ b/test/Hunt/InterpreterTests.hs @@ -0,0 +1,562 @@ +module Hunt.InterpreterTests +(interpreterTests) +where + +import System.Directory +import System.IO + +import Control.Applicative +import Control.Exception +import Control.Monad.Error +import Data.Fixed (div', mod') +import Data.Text (Text, pack) + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit hiding (Test) +import Test.QuickCheck +import Test.QuickCheck.Monadic + +import Text.Printf (printf) + +import Hunt.ClientInterface +import Hunt.Common +import Hunt.DocTable.HashedDocTable (Documents) +import Hunt.Interpreter +import Hunt.Utility +import Hunt.Query.Intermediate + +import Hunt.TestHelper + +-- ---------------------------------------------------------------------------- + +interpreterTests :: [Test] +interpreterTests = + -- general test cases + [ testCase "Interpreter: insert" test_insert + , testCase "Interpreter: search case-insensitive" test_search_nocase + , testCase "Interpreter: search case-insensitive" test_search_nocase2 + , testCase "Interpreter: search case-sensitive" test_search_case + , testCase "Interpreter: search case-sensitive" test_search_case2 + , testCase "Interpreter: phrase case-insensitive" test_phrase_nocase + , testCase "Interpreter: phrase case-insensitive" test_phrase_nocase2 + , testCase "Interpreter: phrase case-sensitive" test_phrase_case + , testCase "Interpreter: phrase case-sensitive" test_phrase_case2 + , testCase "Interpreter: a little bit of everything" test_everything + -- XXX: still a lot of cases uncovered! + + -- test normalization + , testCase "Interpreter: norma case-insensitive" test_norm_search_nocase + , testCase "Interpreter: norma case-insensitive" test_norm_search_nocase2 + , testCase "Interpreter: norma case-sensitive" test_norm_search_case + , testCase "Interpreter: norma case-sensitive" test_norm_search_case2 + , testCase "Interpreter: n.phrase case-insensitive" test_norm_phrase_nocase + , testCase "Interpreter: n.phrase case-insensitive" test_norm_phrase_nocase2 + , testCase "Interpreter: n.phrase case-sensitive" test_norm_phrase_case + , testCase "Interpreter: n.phrase case-sensitive" test_norm_phrase_case2 + -- date search specific tests + , testCase "Interpreter: date context" test_dates + + -- position search specific tests + , testCase "Interpreter: geo context" test_geo + , testCase "Interpreter: geo context range" test_geo2 + , testCase "Interpreter: geo context range_a" test_geo2a + , testCase "Interpreter: geo context range2" test_geo3 + , testCase "Interpreter: geo delete" test_geo_delete + , testCase "Interpreter: geo and other" test_multiple_context + + -- test binary serialization + , testCase "Interpreter: store/load index" test_binary + , testCase "Interpreter: store/load schema" test_binary2 + , testProperty "Interpreter: position range query" prop_position_range + ] + +-- ----------------------------------------------------------- +-- Helper (for this test suite) + +type TestEnv = HuntEnv (Documents Document) +type TestCM a = Hunt (Documents Document) a + +testCmd :: Command -> IO (Either CmdError CmdResult) +testCmd cmd = fst <$> testRunCmd cmd + +testRunCmd :: Command -> IO (Either CmdError CmdResult, TestEnv) +testRunCmd cmd = do + env <- initHunt :: IO DefHuntEnv + res <- runCmd env cmd + return (res, env) + +-- evaluate CM and check the result +testCM' :: Bool -> TestCM () -> Assertion +testCM' b int = do + env <- initHunt :: IO DefHuntEnv + res <- runHunt int env + (if b then isRight else isLeft) res @? "unexpected interpreter result: " ++ show res + +-- evaluate CM and check if it yields a result +-- allows for a whole sequence of commands with tests inbetween +-- the interpreter can fail prematurely +testCM :: TestCM () -> Assertion +testCM = testCM' True + +-- uris of the search results +searchResultUris :: CmdResult -> [URI] +searchResultUris = map (uri . snd . unRD) . lrResult . crRes + +search :: Query -> Int -> Int -> Command +search q o m = setResultOffset o . setMaxResults m . cmdSearch $ q + +-- Do something with a temporary file and delete it afterwards +withTmpFile :: (FilePath -> IO a) -> IO a +withTmpFile io = do + tmpDir <- getTemporaryDirectory + -- XXX: file exists afterwards! + -- hacky, but I don't want to deal with generating names etc. + (file, h) <- openTempFile tmpDir "huntix" + hClose h -- we just want the filename + io file `finally` whenM (doesFileExist file) (removeFile file) + +-- | default test setup used in most tests +defaultTestSetup :: [Command] +defaultTestSetup + = [ insertDefaultContext + , cmdInsertDoc brainDoc + ] + +defaultTestSetup' :: [Command] -> [Command] +defaultTestSetup' cmds = defaultTestSetup ++ cmds + +defaultTestSetup'' :: Command -> [Command] +defaultTestSetup'' cmd = defaultTestSetup ++ [cmd] + +-- fancy functions +-- characters were chosen without any reason +(@@@) :: Command -> (CmdResult -> IO b) -> TestCM b +a @@@ f = execCmd a >>= liftIO . f + +(@@=) :: Command -> CmdResult -> TestCM () +a @@= b = a @@@ (@?=b) + + +-- ----------------------------------------------------------- +-- General Interpreter API tests + +-- just checks the general workflow cx->doc->search +test_insert :: Assertion +test_insert = do + (res, _env) <- testRunCmd . cmdSequence + $ defaultTestSetup + True @=? isRight res + +-- +-- Word Search +-- + +-- insert document and search for it: case insensitive +test_search_nocase :: Assertion +test_search_nocase = do + res <- testCmd . cmdSequence + $ defaultTestSetup'' + $ search (setNoCaseSearch $ qWord "Bra") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + +test_search_nocase2 :: Assertion +test_search_nocase2 = do + res <- testCmd . cmdSequence + $ defaultTestSetup'' + $ search (setNoCaseSearch $ qWord "bra") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + +-- insert document and search for it: case sensitive +test_search_case :: Assertion +test_search_case = do + res <- testCmd . cmdSequence + $ defaultTestSetup'' + $ search (qWord "Bra") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + +test_search_case2 :: Assertion +test_search_case2 = do + res <- testCmd . cmdSequence + $ defaultTestSetup'' + $ search (qWord "bra") 0 1000 + [] @=? (searchResultUris . fromRight) res + + +-- +-- Phrase Search +-- + +-- insert document and search for it: case insensitive +test_phrase_nocase :: Assertion +test_phrase_nocase = do + res <- testCmd . cmdSequence + $ defaultTestSetup'' + $ search (setNoCaseSearch $ qPhrase "Brain") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + +test_phrase_nocase2 :: Assertion +test_phrase_nocase2 = do + res <- testCmd . cmdSequence + $ defaultTestSetup'' + $ search (setNoCaseSearch $ qPhrase "brain") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + +-- insert document and search for it: case sensitive +test_phrase_case :: Assertion +test_phrase_case = do + res <- testCmd . cmdSequence + $ defaultTestSetup'' + $ search (qPhrase "Brain") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + +test_phrase_case2 :: Assertion +test_phrase_case2 = do + res <- testCmd . cmdSequence + $ defaultTestSetup'' + $ search (qPhrase "brain") 0 1000 + [] @=? (searchResultUris . fromRight) res + +-- ----------------------------------------------------------- +-- test application of normalization + + +-- | test setup used in nomralizer tests +normalizerTestSetup :: [Command] +normalizerTestSetup + = [ cmdInsertContext "default" (ContextSchema Nothing [cnUpperCase] 1 True ctText) + , cmdInsertDoc brainDoc + ] + +normalizerTestSetup' :: [Command] -> [Command] +normalizerTestSetup' cmds = normalizerTestSetup ++ cmds + +normalizerTestSetup'' :: Command -> [Command] +normalizerTestSetup'' cmd = normalizerTestSetup ++ [cmd] + +-- +-- Word search +-- + +-- insert document and search for it: case insensitive +test_norm_search_nocase :: Assertion +test_norm_search_nocase = do + res <- testCmd . cmdSequence + $ normalizerTestSetup'' + $ search (setNoCaseSearch $ qWord "Bra") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + +test_norm_search_nocase2 :: Assertion +test_norm_search_nocase2 = do + res <- testCmd . cmdSequence + $ normalizerTestSetup'' + $ search (setNoCaseSearch $ qWord "bra") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + +-- insert document and search for it: case sensitive +test_norm_search_case :: Assertion +test_norm_search_case = do + res <- testCmd . cmdSequence + $ normalizerTestSetup'' + $ search (qWord "Bra") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + +-- NOTE: uppercase normalizer makes Case/NoCase irrelevant -> its the same +test_norm_search_case2 :: Assertion +test_norm_search_case2 = do + res <- testCmd . cmdSequence + $ normalizerTestSetup'' + $ search (qWord "bra") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + +-- +-- Phrase Search +-- + +-- insert document and search for it: case insensitive +test_norm_phrase_nocase :: Assertion +test_norm_phrase_nocase = do + res <- testCmd . cmdSequence + $ normalizerTestSetup'' + $ search (setNoCaseSearch $ qPhrase "Brain") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + +test_norm_phrase_nocase2 :: Assertion +test_norm_phrase_nocase2 = do + res <- testCmd . cmdSequence + $ normalizerTestSetup'' + $ search (setNoCaseSearch $ qPhrase "brain") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + +-- insert document and search for it: case sensitive +test_norm_phrase_case :: Assertion +test_norm_phrase_case = do + res <- testCmd . cmdSequence + $ normalizerTestSetup'' + $ search (qPhrase "Brain") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + +test_norm_phrase_case2 :: Assertion +test_norm_phrase_case2 = do + res <- testCmd . cmdSequence + $ normalizerTestSetup'' + $ search (qPhrase "brain") 0 1000 + ["test://0"] @=? (searchResultUris . fromRight) res + + +-- ----------------------------------------------------------- +-- test binary serialization + +test_binary :: Assertion +test_binary = withTmpFile $ \tmpfile -> testCM $ do + -- create contexts + insertDateContext @@= ResOK + insertDefaultContext @@= ResOK + insertGeoContext @@= ResOK + -- insert two docuemnts + cmdInsertDoc dateDoc @@= ResOK + cmdInsertDoc geoDoc @@= ResOK + -- searching for documents - expecting to find them + search (setContexts ["datecontext"] (setNoCaseSearch $ qWord "2013-01-01")) 0 10 + @@@ ((@?= ["test://1"]) . searchResultUris) + search (setContexts ["geocontext"] (setNoCaseSearch $ qWord "53.60000-10.00000")) 0 10 + @@@ ((@?= ["test://2"]) . searchResultUris) + -- store index + cmdStoreIndex tmpfile @@= ResOK + -- reset index + cmdDeleteDoc "test://1" @@= ResOK + cmdDeleteDoc "test://2" @@= ResOK + -- searching for documents - expecting to find none + search (setContexts ["datecontext"] (setNoCaseSearch $ qWord "2013-01-01")) 0 10 + @@@ ((@?= []) . searchResultUris) + search (setContexts ["geocontext"] (setNoCaseSearch $ qWord "53.60000-10.00000")) 0 10 + @@@ ((@?= []) . searchResultUris) + -- loading previously stored index + cmdLoadIndex tmpfile @@= ResOK + -- searching for documents - expecting to find them, + -- since we found them before we stored the index + search (setContexts ["datecontext"] (setNoCaseSearch $ qWord "2013-01-01")) 0 10 + @@@ ((@?= ["test://1"]) . searchResultUris) + search (setContexts ["geocontext"] (setNoCaseSearch $ qWord "53.60000-10.00000")) 0 10 + @@@ ((@?= ["test://2"]) . searchResultUris) + +test_binary2 :: Assertion +test_binary2 = withTmpFile $ \tmpfile -> testCM $ do + -- create contexts + insertDateContext @@= ResOK + insertDefaultContext @@= ResOK + insertGeoContext @@= ResOK + -- insert two docuemnts + cmdInsertDoc dateDoc @@= ResOK + -- searching for documents - first should be valid second should be invalid + search (setContexts ["datecontext"] (setNoCaseSearch $ qWord "2013-01-01")) 0 10 + @@@ ((@?= ["test://1"]) . searchResultUris) + (search (setContexts ["datecontext"] (setNoCaseSearch $ qWord "invalid")) 0 10 + -- new behaviour: just return empty result for invalid contexts + @@@ ((@?= []) . searchResultUris)) + -- old behaviour: throws error on validation failure + -- @@@ const (assertFailure "date validation failed")) + -- `catchError` const (return ()) + + -- store index + cmdStoreIndex tmpfile @@= ResOK + cmdLoadIndex tmpfile @@= ResOK + -- searching for documents - first should be valid second should be invalid + search (setContext "datecontext" (setNoCaseSearch $ qWord "2013-01-01")) 0 10 + @@@ ((@?= ["test://1"]) . searchResultUris) + (search (setContext "datecontext" (setNoCaseSearch $ qWord "invalid")) 0 10 + -- new behaviour: just return empty result for invalid contexts + @@@ ((@?= []) . searchResultUris)) + -- old behaviour: throws error on validation failure + -- @@@ const (assertFailure "date validation failed after store/load index")) + -- `catchError` const (return ()) + + +-- ----------------------------------------------------------- +-- index specific tests + +test_dates :: Assertion +test_dates = testCM $ do + -- create contexts + insertDateContext @@= ResOK + insertDefaultContext @@= ResOK + -- insert date containing document + cmdInsertDoc dateDoc @@= ResOK + -- searching for date + search (setContext "datecontext" (setNoCaseSearch $ qWord "2013-01-01")) 0 10 + @@@ ((@?= ["test://1"]) . searchResultUris) + + +test_geo :: Assertion +test_geo = testCM $ do + -- create contexts + insertGeoContext @@= ResOK + insertDefaultContext @@= ResOK + -- insert date containing document + cmdInsertDoc geoDoc @@= ResOK + -- searching for date + search (setContext "geocontext" (setNoCaseSearch $ qWord "53.60000-10.00000")) 0 10 + @@@ ((@?= ["test://2"]) . searchResultUris) + +test_geo2 :: Assertion +test_geo2 = testCM $ do + -- create contexts + insertGeoContext @@= ResOK + insertDefaultContext @@= ResOK + -- insert date containing document + cmdInsertDoc geoDoc @@= ResOK + -- searching for date + search (setContext "geocontext" (qRange "1-1" "80-80")) 0 10 + @@@ ((@?= ["test://2"]) . searchResultUris) + +test_geo2a :: Assertion +test_geo2a = testCM $ do + -- create contexts + insertGeoContext @@= ResOK + insertDefaultContext @@= ResOK + + cmdInsertDoc (geoDoc' "89.63-2.75") @@= ResOK + + search (setContext "geocontext" (qRange "9.40-2.25" "89.25-87.88")) 0 10 + @@@ ((@?= []) . searchResultUris) + +test_geo3 :: Assertion +test_geo3 = testCM $ do + -- create contexts + insertGeoContext @@= ResOK + insertDefaultContext @@= ResOK + -- insert date containing document + cmdInsertDoc geoDoc @@= ResOK + -- searching for date + search (setContext "geocontext" (qRange "-80--80" "1-1")) 0 10 + @@@ ((@?= []) . searchResultUris) + + search (setContext "geocontext" (qRange "60--80" "70--80")) 0 10 + @@@ ((@?= []) . searchResultUris) + + +test_geo_delete :: Assertion +test_geo_delete = testCM $ do + -- create contexts + insertDefaultContext @@= ResOK + insertGeoContext @@= ResOK + -- insert two docuemnts + cmdInsertDoc geoDoc @@= ResOK + -- searching for documents - expecting to find them + search (setContexts ["geocontext"] (setNoCaseSearch $ qWord "53.60000-10.00000")) 0 10 + @@@ ((@?= ["test://2"]) . searchResultUris) + -- reset index + cmdDeleteDoc "test://1" @@= ResOK + cmdDeleteDoc "test://2" @@= ResOK + -- searching for documents - expecting to find none + search (setContexts ["geocontext"] (setNoCaseSearch $ qWord "53.60000-10.00000")) 0 10 + @@@ ((@?= []) . searchResultUris) + + +test_multiple_context :: Assertion +test_multiple_context = testCM $ do + -- create contexts + insertDateContext @@= ResOK + insertDefaultContext @@= ResOK + insertGeoContext @@= ResOK + -- insert two docuemnts + cmdInsertDoc dateDoc @@= ResOK + cmdInsertDoc geoDoc @@= ResOK + -- searching for documents - expecting to find them + search (setContexts ["datecontext"] (setNoCaseSearch $ qWord "2013-01-01")) 0 10 + @@@ ((@?= ["test://1"]) . searchResultUris) + search (setContexts ["geocontext"] (setNoCaseSearch $ qWord "53.60000-10.00000")) 0 10 + @@@ ((@?= ["test://2"]) . searchResultUris) + -- reset index + cmdDeleteDoc "test://1" @@= ResOK + cmdDeleteDoc "test://2" @@= ResOK + -- searching for documents - expecting to find none + search (setContexts ["datecontext"] (setNoCaseSearch $ qWord "2013-01-01")) 0 10 + @@@ ((@?= []) . searchResultUris) + search (setContexts ["geocontext"] (setNoCaseSearch $ qWord "53.60000-10.00000")) 0 10 + @@@ ((@?= []) . searchResultUris) + +-- fancy - equivalent to 'test_alot' plus additional tests +test_everything :: Assertion +test_everything = testCM $ do + -- insert into non-existent context results in an error + (cmdInsertDoc brainDoc + @@@ const (assertFailure "insert into non-existent context succeeded")) + `catchError` const (return ()) + -- insert context succeeds + insertDefaultContext + @@= ResOK + + -- inserting the same context again fails + (insertDefaultContext + @@@ const (assertFailure "inserting a context twice succeeded")) + `catchError` const (return ()) + + -- insert yields the correct result value + cmdInsertDoc brainDoc + @@= ResOK + + -- searching "Brain" leads to the doc + search (setNoCaseSearch $ qWord "Brain") os pp + @@@ ((@?= ["test://0"]) . searchResultUris) + -- case-sensitive search too + search (qWord "Brain") os pp + @@@ ((@?= ["test://0"]) . searchResultUris) + -- case-sensitive search yields no result + search (qWord "brain") os pp + @@@ ((@?= []) . searchResultUris) + + -- insert with default does not update the description + (cmdInsertDoc brainDocUpdate + @@@ const (assertFailure "inserting twice succeeded")) + `catchError` const (return ()) + -- search yields the old description + search (qWord "Brain") os pp + @@@ ((@?= adDescr brainDoc) . desc . snd . unRD . head . lrResult . crRes) + + -- update the description + cmdUpdateDoc brainDocUpdate + @@= ResOK + -- search yields >merged< description + search (qWord "Brain") os pp + @@@ ((@?= adDescr brainDocMerged) . desc . snd . unRD . head . lrResult . crRes) + + -- delete return the correct result value + cmdDeleteDoc ("test://0") + @@= ResOK + -- the doc is gone + search (setNoCaseSearch $ qWord "Brain") os pp + @@@ ((@?= []) . searchResultUris) + where + os = 0 + pp = 1000 + +getFraction :: Double -> Double +getFraction x = (signum x) * (x - (Prelude.fromInteger $ x `div'` 1)) + +isInRect :: (Double, Double) -> (Double, Double) -> (Double, Double) -> Bool +--isInRect ne sw p = (unzip ^>> Control.Monad.join (***) (\x -> x == sort x) >>> uncurry (&&)) [ne, p, sw] +isInRect (x1,y1) (x3,y3) (x2,y2) = x1 <= x2 && x2 <= x3 && y1 <= y2 && y2 <= y3 + +toText :: (Double, Double) -> Text +toText (lat, lon) = (pack $ printf "%f" lat) <> "-" <> (pack $ printf "%f" lon) + +prop_position_range :: Double -> Double -> Double -> Double -> (Double, Double) -> Property +prop_position_range x1' x2' x3' x4' (lon', lat') = monadicIO $ do + res <- run $ do + env <- initHunt :: IO DefHuntEnv + res' <- flip runHunt env $ do + _ <- execCmd insertDefaultContext + _ <- execCmd insertGeoContext + _ <- execCmd $ cmdInsertDoc $ geoDoc' $ toText p + execCmd $ search (setContext "geocontext" (qRange (toText nw) (toText se))) 0 10 + -- print $ (show [nw, se, p]) ++ (show $ searchResultUris $ fromRight res') ++ show isIn + return res' + Test.QuickCheck.Monadic.assert $ isIn == (not $ null $ searchResultUris $ fromRight res) + where + [x1, x2, x3, x4, lon, lat] = map (abs . (`mod'` 90)) [x1', x2', x3', x4', lon', lat'] + nw = (min x1 x3, min x2 x4) + se = (max x1 x3, max x2 x4) + p = (x1 + getFraction lon, x2 + getFraction lat) + isIn = isInRect nw se p diff --git a/test/Hunt/QueryParserTests.hs b/test/Hunt/QueryParserTests.hs new file mode 100644 --- /dev/null +++ b/test/Hunt/QueryParserTests.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -fno-warn-orphans #-} +{-# OPTIONS -fno-warn-missing-signatures #-} +{-# OPTIONS -fno-warn-missing-methods #-} +{-# OPTIONS -fno-warn-unused-matches #-} +{-# OPTIONS -fno-warn-type-defaults #-} + +module Hunt.QueryParserTests +(queryParserTests) +where + +import Control.Applicative + +import Test.Framework hiding (Test) +import qualified Test.Framework as TF +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit +import Test.QuickCheck + +import Control.Monad +import Data.Text (Text) +import qualified Data.Text as T +import Hunt.ClientInterface +import qualified Hunt.Query.Language.Parser as P + +-- ---------------------------------------------------------------------------- +-- query parser tests +-- + +queryParserTests :: [TF.Test] +queryParserTests = [ allProperties + , allUnitTests + ] + + +allProperties = testGroup "Query Parser Properties" + [ testProperty "prop_ParseAnd" prop_ParseAnd + ] + +allUnitTests = testGroup "Query Parser Hunit tests" $ hUnitTestToTests $ TestList + [ TestLabel "And tests" andTests + , TestLabel "Or tests" orTests + , TestLabel "And Not tests" andNotTests + --, TestLabel "Not tests" notTests + , TestLabel "Specifier tests" specifierTests + , TestLabel "Case tests" caseTests + , TestLabel "Parenthese tests" parentheseTests + , TestLabel "Word tests" wordTests + , TestLabel "Phrase tests" phraseTests + , TestLabel "Fuzzy tests" fuzzyTests + , TestLabel "Range tests" rangeTests + , TestLabel "Boost tests" boostTests + ] + +---- ---------------------------------------------------------------------------- +-- helper +-- + +a :: Query -> Query -> Query +a = qAnd + +o :: Query -> Query -> Query +o = qOr + +an :: Query -> Query -> Query +an = qAndNot + +w :: Text -> Query +w = qWordNoCase + +p :: Text -> Query +p = qPhraseNoCase + +s :: [Text] -> Query -> Query +s = setContexts + +cw :: Text -> Query +cw = qWord + +cp :: Text -> Query +cp = qPhrase + +fw :: Text -> Query +fw = setFuzzySearch . qWord + +rg :: Text -> Text -> Query +rg = qRange + +bst :: Weight -> Query -> Query +bst = setBoost + +andTests :: Test +andTests = TestList + [ TestCase (assertEqual "Simple two term 'and' query" + (Right (a (w "abc") (w "def"))) + (P.parseQuery "abc def")) + + , TestCase (assertEqual "Concatenating 'and' terms" + (Right (a (w "abc") (a (w "def") (w "ghi")))) + (P.parseQuery "abc def ghi")) + + , TestCase (assertEqual "Ignoring whitespace" + (Right (a (w "abc") (a (w "def") (a (w "ghi") (w "jkl"))))) + (P.parseQuery " \rabc \r def \tghi \njkl \r\n ")) + + , TestCase (assertEqual "Priorities" + (Right (a (s ["wurst"] (w "abc")) (a (w "def") (a (w "ghi") (s ["wurst"] (w "jkl")))))) + (P.parseQuery "wurst:abc def ghi wurst:jkl")) + + , TestCase (assertEqual "Confusing operator" + (Right (a (w "Apple") (a (w "Anna") (w "ANDroid")))) + (P.parseQuery "Apple Anna ANDroid")) + + , TestCase (assertEqual "Explicit operator" + (Right (a (w "abc") (w "def"))) + (P.parseQuery "abc AND def")) + ] + +orTests :: Test +orTests = TestList + [ TestCase (assertEqual "Simple two term 'or' query" + (Right (o (w "abc") (w "def"))) + (P.parseQuery "abc OR def")) + + , TestCase (assertEqual "Concatenating 'or' terms" + (Right (o (w "abc") (o (w "def") (w "ghi")))) + (P.parseQuery "abc OR def OR ghi")) + + , TestCase (assertEqual "Ignoring whitespace" + (Right (o (w "abc") (o (w "def") (o (w "ghi") (w "jkl"))))) + (P.parseQuery " \rabc \rOR def OR \tghi OR\njkl \r\n ")) + + , TestCase (assertEqual "Priorities" + (Right (o (s ["wurst"] (w "abc")) (o (w "def") (o (w "ghi") (s ["wurst"] (w "jkl")))))) + (P.parseQuery "wurst:abc OR def OR ghi OR wurst:jkl")) + + , TestCase (assertEqual "Operator precedence" + (Right (o + (a + (s ["wurst"] (w "abc")) + (w "def") + ) + (a + (w "ghi") + (s ["wurst"] (w "jkl")) + ) + ) + ) + (P.parseQuery "wurst:abc def OR ghi wurst:jkl")) + + , TestCase (assertEqual "Confusing operator" + (Right (a (w "Operation") (w "ORganism"))) + (P.parseQuery "Operation ORganism")) + ] + +specifierTests :: Test +specifierTests = TestList + [ TestCase (assertEqual "Specifier with whitespace" + (Right (a (s ["wurst"] (w "abc")) (s ["batzen"] (w "def")))) + (P.parseQuery " wurst:\t abc \nbatzen : \r def ")) + + , TestCase (assertEqual "Specifier priority" + (Right (o (a (w "abc") (a (s ["wurst"] (w "def")) (s ["wurst"] (w "ghi")))) (s ["wurst"] (w "jkl")))) + (P.parseQuery "abc wurst: def wurst: ghi OR wurst: jkl")) + + ,TestCase (assertEqual "Specifier and brackets" + (Right (a (s ["wurst"] (a (w "abc") (a (w "def") (w "ghi")))) (s ["batzen"] (o (w "abc") (w "def"))))) + (P.parseQuery "wurst: (abc def ghi) batzen: (abc OR def)")) + + ,TestCase (assertEqual "Specifier and brackets" + (Right (a (s ["wurst"] (a (w "abc") (a (w "def") (w "ghi")))) (s ["batzen"] (o (w "abc") (w "def"))))) + (P.parseQuery "wurst: (abc def ghi) batzen: (abc OR def)")) + + ,TestCase (assertEqual "Specifier and space" + (Right (a (s ["wurst"] (a (w "abc") (a (w "def") (w "ghi")))) (s ["batzen"] (o (w "abc") (w "def"))))) + (P.parseQuery "wurst \t: (abc def ghi) batzen \n : (abc OR def)")) + + ,TestCase (assertEqual "Specifier lists" + (Right (s ["wurst","batzen","schinken"] (a (w "abc") (a (w "def") (w "ghi"))))) + (P.parseQuery "wurst,batzen,schinken: (abc def ghi)")) + + ,TestCase (assertEqual "Specifier lists with space" + (Right (s ["wurst","batzen","schinken"] (a (w "abc") (a (w "def") (w "ghi"))))) + (P.parseQuery "wurst , \n batzen \t, schinken: (abc def ghi)")) + + ,TestCase (assertEqual "Specifier lists with phrase" + (Right (s ["wurst","batzen","schinken"] (p "this is A Test"))) + (P.parseQuery "wurst , \n batzen \t, schinken: \"this is A Test\"")) + ] + +andNotTests :: Test +andNotTests = TestList + [ TestCase (assertEqual "Simple two term 'and not' query" + (Right (an (w "abc") (w "def"))) + (P.parseQuery "abc AND NOT def")) + + , TestCase (assertEqual "Concatenating 'and' terms" + (Right (an (an (w "abc") (w "def")) (w "ghi"))) + (P.parseQuery "abc AND NOT def AND NOT ghi")) + + , TestCase (assertEqual "Ignoring whitespace" + (Right (an (an (an (w "abc") (w "def")) (w "ghi")) (w "jkl"))) + (P.parseQuery " \rabc AND NOT\r def \tAND NOT ghi AND NOT \njkl \r\n ")) + + , TestCase (assertEqual "Priorities" + (Right (an (an (an (s ["wurst"] (w "abc")) (w "def")) (w "ghi")) (s ["wurst"] (w "jkl")))) + (P.parseQuery "wurst:abc AND NOT def AND NOT ghi AND NOT wurst:jkl")) + + , TestCase (assertEqual "Confusing operator" + (Right (an (w "Apple") (a (w "Anna") (w "ANDNOTtingham")))) + (P.parseQuery "Apple AND NOT Anna ANDNOTtingham")) + ] + +{- +notTests :: Test +notTests = TestList + [ TestCase (assertEqual "Simple not query" + (Right (n (w "batzen"))) + (P.parseQuery "NOT batzen")) + + , TestCase (assertEqual "Operator precedence" + (Right (a (n (w "batzen")) (w "wurst"))) + (P.parseQuery "NOT batzen wurst")) + + , TestCase (assertEqual "Operator precedence with and" + (Right (a (w "test") (a (n (w "batzen")) (w "wurst")))) + (P.parseQuery "test NOT batzen wurst")) + + , TestCase (assertEqual "Operator precedence with or" + (Right (o (w "test") (o (n (w "batzen")) (w "wurst")))) + (P.parseQuery "test OR NOT batzen OR wurst")) + + , TestCase (assertEqual "Confusing operator" + (Right (a (w "Nail") (a (w "NOrthpole") (w "NOTtingham")))) + (P.parseQuery "Nail NOrthpole NOTtingham")) + ] +-} + +caseTests :: Test +caseTests = TestList + [ TestCase (assertEqual "Simple case-sensitive word" + (Right (cw "batzen")) + (P.parseQuery "!batzen")) + + ,TestCase (assertEqual "Simple case-sensitive phrase" + (Right (cp "this is a test")) + (P.parseQuery "!\"this is a test\"")) + + ,TestCase (assertEqual "Case sensitive word with whitespace" + (Right (cw "test")) + (P.parseQuery " ! test")) + ] + +boostTests :: Test +boostTests = TestList + [ TestCase $ assertEqual "Boosting a word" + (Right (bst 9 $ w "word")) + ( P.parseQuery "word^9") + + , TestCase $ assertEqual "Boosting and more" + (Right (a (bst 2 $ w "foo") (w "bar"))) + ( P.parseQuery "foo^2 bar") + + , TestCase $ assertEqual "Boosting a word with a proper float" + (Right (bst 9.5 $ w "word")) + ( P.parseQuery "word^9.5") + + , TestCase $ assertEqual "Boosting a phrase" + (Right (bst 9 $ p "word")) + ( P.parseQuery "\"word\"^9") + + , TestCase $ assertEqual "Boosting a binary query with parantheses" + (Right (bst 9 $ (o (a (w "w") (w "k")) (w "p")))) + ( P.parseQuery "(w AND k OR p)^9") + + , TestCase $ assertEqual "Boosting a context" + (Right (bst 9 $ s ["con"] (w "word"))) + ( P.parseQuery "(con:word)^9") + + ] + +rangeTests :: Test +rangeTests = TestList + [ TestCase $ assertEqual "Simple Range Query without meta" + (Right (rg "30" "40")) + ( P.parseQuery "[30 TO 40]") + + , TestCase $ assertEqual "Range with context" + (Right (s ["con"] (rg "30" "40"))) + ( P.parseQuery "con:[30 TO 40]") + + , TestCase $ assertEqual "Range with contexts" + (Right (s ["con1", "con2"] (rg "30" "40"))) + ( P.parseQuery "con1,con2:[30 TO 40]") + + , TestCase $ assertEqual "complex query with ranges" + (Right (a (s ["con1"] (rg "30" "40")) (s ["con2"] (rg "59" "100")))) + ( P.parseQuery "con1:[30 TO 40] AND con2:[59 TO 100]") + + ] + + +parentheseTests :: Test +parentheseTests = TestList + [ TestCase (assertEqual "Parentheses with effect" + (Right (a (w "abc") (o (w "def") (w "ghi")))) + (P.parseQuery "abc (def OR ghi)")) + + , TestCase (assertEqual "Parentheses changing priority of OR" + (Right (a (o (w "abc") (w "def")) (w "ghi"))) + (P.parseQuery "(abc OR def) ghi")) + + , TestCase (assertEqual "Parentheses with whitespace and OR" + (Right (o (w "abc") (w "def"))) + (P.parseQuery " ( abc OR def ) ")) + + , TestCase (assertEqual "Parentheses with whitespace and AND" + (Right (a (w "abc") (w "def"))) + (P.parseQuery " ( abc def ) ")) + ] + +fuzzyTests :: Test +fuzzyTests = TestList + [ TestCase (assertEqual "Simple fuzzy query" + (Right (fw "test")) + (P.parseQuery "~test")) + + , TestCase (assertEqual "Fuzzy query with whitespace" + (Right (fw "test")) + (P.parseQuery " ~ test")) + ] + +wordTests :: Test +wordTests + = TestList + [ TestCase $ + assertEqual "Quoted word query" + (Right (w "abc")) + (P.parseQuery "'abc'") + , TestCase $ + assertEqual "Quoted word with whitespace query" + (Right (w "a b c")) + (P.parseQuery "'a b c'") + , TestCase $ + assertEqual "Quoted word with single quotes query" + (Right (w "a'b")) + (P.parseQuery "'a\\'b'") + ] + + +phraseTests :: Test +phraseTests = TestList + [ TestCase (assertEqual "Ignoring whitespace without case operator" + (Right (p "wurst schinken batzen")) + (P.parseQuery " \t \n \"wurst schinken batzen\" \t ")) + + , TestCase (assertEqual "Ignoring whitespace with case operator" + (Right (cp "wurst schinken batzen")) + (P.parseQuery " \t \n ! \"wurst schinken batzen\" \t ")) + ] +{-- +instance Arbitrary Char where + arbitrary = oneof [choose ('\65', '\90') ,choose ('\97', '\122')] + shrink c = [ c' | c' <- ['a','b','c'], c' < c || not (isLower c) ] +--} +instance Arbitrary Text where + arbitrary = T.pack <$> arbitrary + shrink xs = T.pack <$> shrink (T.unpack xs) + +instance Arbitrary Query where + arbitrary = sized query + +query :: Int -> Gen Query +query num | num == 0 = liftM qWord word + | num < 0 = query (abs num) + | num > 0 = frequency [ (4, (setNoCaseSearch . qWord) <$> word) + , (1, qWord <$> word) + , (1, (setFuzzySearch . qWord) <$> word) + , (2, (setNoCaseSearch . qPhrase) <$> phrase) + , (1, qPhrase <$> phrase) + , (1, setContexts <$> specs <*> subQuery) + , (4, op <*> subQuery <*> subQuery) + ] +query _ = error "Error in query generator!" + + + +op = frequency [ (3, return qAnd) + , (1, return qOr) + , (1, return qAndNot) + ] +subQuery = sized (\num -> query (num `div` 2)) + +specs = sequence [ word | i <- [1..2] ] + +word :: Gen Text +word = fmap T.pack . listOf1 . elements $ concat [['0'..'9'], ['A'..'Z'], ['a'..'z']] + +phrase = do + ws <- sequence [ word | i <- [1..3] ] + return (T.intercalate " " ws) + +prop_ParseAnd q = (printQuery <$> (P.parseQuery $ T.unpack $ printQuery q)) == Right (printQuery q) + diff --git a/test/Hunt/Strict/ContextIndex.hs b/test/Hunt/Strict/ContextIndex.hs new file mode 100644 --- /dev/null +++ b/test/Hunt/Strict/ContextIndex.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} + +module Hunt.Strict.ContextIndex +(contextIndexTests) +where + +import Hunt.TestHelper +import Hunt.Strict.Helper + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import Test.QuickCheck.Monadic (PropertyM, + monadicIO, + pick) + +import Hunt.Common +import Hunt.Common.IntermediateValue + +import qualified Data.Map.Strict as M +import Data.Default + +import qualified Hunt.Index as Ix +import Hunt.ContextIndex +import qualified Hunt.Index.IndexImpl as Impl +import qualified Hunt.Index.InvertedIndex as InvIx + +import qualified Hunt.DocTable as Dt +import qualified Hunt.DocTable.HashedDocTable as HDt + +-- ---------------------------------------------------------------------------- + +contextIndexTests :: [Test] +contextIndexTests = + [ testProperty "prop_strictness_insertList1" prop_cx_insertlist + , testProperty "prop_strictness_insertList2" prop_cx_insertlist2 + , testProperty "prop_strictness_insertList3" prop_cx_insertlist3 + ] + +-- ---------------------------------------------------------------------------- +-- context index implementation +-- ---------------------------------------------------------------------------- + +prop_cx_insertlist3 :: Property +prop_cx_insertlist3 = monadicIO $ do + -- generate list of distinct documents (in terms of uri) + documents <- pick mkDocuments + -- genearte mock ContextIndex to work with. + -- Use some of the documents to be initially stored in the + -- document table + cxIx <- pickContextIx $ take 10 documents + -- generate mock document-word pairs to insert. + -- use rest of documents for this list + insertData <- pick $ mkInsertList $ drop 10 documents + -- check resulting document table for strictness property + (ContextIndex _ dt') <- insertList insertData cxIx + assertNF' dt' + where + pickIx = do + val <- pick arbitrary + return $ Ix.insert "key" (toIntermediate (val :: Occurrences)) Ix.empty + pickContextIx docs = do + ix <- pickIx :: PropertyM IO InvIx.InvertedIndex + let cxmap = mkContextMap $ M.fromList [("context", (def, Impl.mkIndex ix))] + dt <- pick $ mkDocTable docs + return $ ContextIndex cxmap dt + +prop_cx_insertlist ::Property +prop_cx_insertlist = monadicIO $ do + (table, idsAndWords) <- pickRes :: PropertyM IO (HDt.Documents Document, [(DocId, Words)]) + assertNF' table + assertNF' idsAndWords + where + pickRes = pick mkInsertList' >>= createDocTableFromPartition + +prop_cx_insertlist2 ::Property +prop_cx_insertlist2 = monadicIO $ do + -- generate list of doctables and chekc if they are strict + dts <- pick mkDocTables + -- create input list to work with + let dt = if length dts > 0 then (head dts) else Dt.empty + input <- mapM (\dt' -> return (dt',[])) $ drop 1 dts + -- union doctables with insertLists reduce function and check result for strictness + (outDt,_) <- unionDocTables input dt + assertNF' outDt diff --git a/test/Hunt/Strict/DocTable.hs b/test/Hunt/Strict/DocTable.hs new file mode 100644 --- /dev/null +++ b/test/Hunt/Strict/DocTable.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} + +module Hunt.Strict.DocTable +(docTableTests) +where + +import Control.Monad (foldM) +import Hunt.TestHelper +import Hunt.Strict.Helper +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import Test.QuickCheck.Monadic (PropertyM, + monadicIO, + pick) + +import qualified Data.Set as S +import Data.Text (Text) + +import Hunt.Common +import qualified Hunt.Common.DocIdSet as IS +import qualified Hunt.Common.DocDesc as DD + +import qualified Hunt.DocTable as Dt +import qualified Hunt.DocTable.HashedDocTable as HDt + +-- ---------------------------------------------------------------------------- + +docTableTests :: [Test] +docTableTests = + -- tests for data-structures used in contexts of the document table + [ testProperty "prop_strictness_document" prop_doc + + , testProperty "prop_strictness_docdesc empty" prop_dd_empty + , testProperty "prop_strictness_docdesc fromList" prop_dd_fromList + , testProperty "prop_strictness_docdesc insert" prop_dd_insert + , testProperty "prop_strictness_docdesc union" prop_dd_union + + + -- strictness property for document table by function + , testProperty "prop_strictness union doctable" prop_dt_union + , testProperty "prop_strictness insert doctable" prop_dt_insert + , testProperty "prop_strictness update doctable" prop_dt_update + , testProperty "prop_strictness delete doctable" prop_dt_delete + , testProperty "prop_strictness delbyuri doctable" prop_dt_delete2 + , testProperty "prop_strictness adjust doctable" prop_dt_adjust + , testProperty "prop_strictness adjuri doctable" prop_dt_adjust2 + , testProperty "prop_strictness difference doctable" prop_dt_difference + , testProperty "prop_strictness diffusi doctable" prop_dt_difference2 + -- TODO: + -- map + -- filter + -- mapKeys + ] + +-- ---------------------------------------------------------------------------- +-- test data structures: Document +-- ---------------------------------------------------------------------------- + +prop_doc :: Property +prop_doc = monadicIO $ do + x <- pick arbitrary :: PropertyM IO Document + assertNF' $! x + +-- ---------------------------------------------------------------------------- +-- test data structures: Document description (DocDesc) +-- ---------------------------------------------------------------------------- + +prop_dd_empty :: Property +prop_dd_empty = monadicIO $ do + assertNF' $! DD.empty + +prop_dd_fromList :: Property +prop_dd_fromList = monadicIO $ do + v1 <- pick niceText1 + v2 <- pick niceText1 + k1 <- pick niceText1 + k2 <- pick niceText1 + assertNF' $! DD.fromList (list k1 v1 k2 v2) + where + list k1 v1 k2 v2 = [(k1,v1), (k2,v2)] :: [(Text,Text)] + +prop_dd_insert :: Property +prop_dd_insert = monadicIO $ do + assertNF' $! DD.insert "key" ("value"::String) DD.empty + +prop_dd_union :: Property +prop_dd_union = monadicIO $ do + x <- pick mkDescription + y <- pick mkDescription + assertNF' $! DD.union x y + + + +-- ---------------------------------------------------------------------------- +-- document table implementation +-- ---------------------------------------------------------------------------- + +prop_dt_insert :: Property +prop_dt_insert + = monadicIO $ do + (_,dt) <- pickIx :: PropertyM IO (DocId, HDt.Documents Document) + assertNF' dt + where + pickIx = pick arbitrary >>= \doc -> Dt.insert doc Dt.empty + +prop_dt_union :: Property +prop_dt_union + = monadicIO $ do + dt <- pick mkDocTables >>= foldM Dt.union Dt.empty + assertNF' dt + +prop_dt_update :: Property +prop_dt_update + = monadicIO $ do + doc1 <- pick mkDocument' + (docid, dt1) <- Dt.insert doc1 (Dt.empty :: HDt.Documents Document) + doc2 <- pick mkDocument' + Dt.update docid doc2 dt1 + +prop_dt_delete :: Property +prop_dt_delete + = monadicIO $ do + dt <- pickIx :: PropertyM IO (HDt.Documents Document) + assertNF' dt + where + pickIx = do + doc1 <- pick arbitrary + doc2 <- pick arbitrary + (docid, dt) <- Dt.insert doc1 Dt.empty + (_, dt') <- Dt.insert doc2 dt + Dt.delete docid dt' + +prop_dt_delete2 :: Property +prop_dt_delete2 + = monadicIO $ do + dt <- pickIx :: PropertyM IO (HDt.Documents Document) + assertNF' dt + where + pickIx = do + doc1@(Document u _ _) <- pick arbitrary + doc2 <- pick arbitrary + (_, dt) <- Dt.insert doc1 Dt.empty + (_, dt') <- Dt.insert doc2 dt + Dt.deleteByURI u dt' + +prop_dt_adjust :: Property +prop_dt_adjust + = monadicIO $ do + dt <- pickIx :: PropertyM IO (HDt.Documents Document) + assertNF' dt + where + pickIx = do + doc1 <- pick arbitrary + doc2 <- pick arbitrary + (docid, dt) <- Dt.insert doc1 Dt.empty + Dt.adjust (\_ -> return doc2) docid dt + + +prop_dt_adjust2 :: Property +prop_dt_adjust2 + = monadicIO $ do + dt <- pickIx :: PropertyM IO (HDt.Documents Document) + assertNF' dt + where + pickIx = do + doc1@(Document u _ _) <- pick arbitrary + doc2 <- pick arbitrary + (_, dt) <- Dt.insert doc1 Dt.empty + Dt.adjustByURI (\_ -> return doc2) u dt + + +prop_dt_difference :: Property +prop_dt_difference + = monadicIO $ do + dt <- pickIx :: PropertyM IO (HDt.Documents Document) + assertNF' dt + where + pickIx = do + doc1 <- pick arbitrary + doc2 <- pick arbitrary + (docid, dt) <- Dt.insert doc1 Dt.empty + (_, dt') <- Dt.insert doc2 dt + Dt.difference (IS.singleton docid) dt' + +prop_dt_difference2 :: Property +prop_dt_difference2 + = monadicIO $ do + dt <- pickIx :: PropertyM IO (HDt.Documents Document) + assertNF' dt + where + pickIx = do + doc1@(Document u _ _) <- pick arbitrary + doc2 <- pick arbitrary + (_, dt) <- Dt.insert doc1 Dt.empty + (_, dt') <- Dt.insert doc2 dt + Dt.differenceByURI (S.singleton u) dt' diff --git a/test/Hunt/Strict/Helper.hs b/test/Hunt/Strict/Helper.hs new file mode 100644 --- /dev/null +++ b/test/Hunt/Strict/Helper.hs @@ -0,0 +1,34 @@ +module Hunt.Strict.Helper where + +import Test.QuickCheck +import Test.QuickCheck.Monadic (PropertyM, + monitor, + run) +import GHC.AssertNF +import GHC.HeapView +import qualified System.Mem + +heapGraph :: Int -> a -> IO String +heapGraph d x = do + let box = asBox x + graph <- buildHeapGraph d () box + return $ ppHeapGraph graph + +isNFWithGraph :: Int -> a -> IO (Bool, String) +isNFWithGraph d x = do + b <- isNF $! x + -- XXX: does gc need a delay? + System.Mem.performGC + g <- heapGraph d x + return (b,g) + +-- depth is a constant +assertNF' :: a -> PropertyM IO () +assertNF' = assertNF'' 5 + +assertNF'' :: Int -> a -> PropertyM IO () +assertNF'' d x = do + (b,g) <- run $ isNFWithGraph d x + monitor $ const $ counterexample g b + + diff --git a/test/Hunt/Strict/Index.hs b/test/Hunt/Strict/Index.hs new file mode 100644 --- /dev/null +++ b/test/Hunt/Strict/Index.hs @@ -0,0 +1,527 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} + +module Hunt.Strict.Index +(indexTests) +where + +import Hunt.TestHelper () +import Hunt.Strict.Helper +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import Test.QuickCheck.Monadic (PropertyM, + monadicIO, + pick) + +import Data.Text (Text) + +import Hunt.Common +import qualified Hunt.Common.Positions as Pos +import qualified Hunt.Common.DocIdMap as DM +import qualified Hunt.Common.DocIdSet as DS + +import Hunt.Common.IntermediateValue + +import qualified Hunt.Index as Ix +import qualified Hunt.Index.InvertedIndex as InvIx +import qualified Hunt.Index.PrefixTreeIndex as PIx +import qualified Hunt.Index.PrefixTreeIndex2Dim as PIx2D +import qualified Hunt.Index.Proxy.KeyIndex as KeyProxy +import qualified Hunt.Index.RTreeIndex as RTree +-- ---------------------------------------------------------------------------- + +indexTests :: [Test] +indexTests = + -- strictness property for data-structures used in index and + -- document table + [ testProperty "prop_strictness_occurrences" prop_occs + + -- strictness property for index implementations by function + -- insert / insertList + , testProperty "prop_strictness insert prefixtreeindex" prop_ptix + , testProperty "prop_strictness insert prefixtreeindex2D" prop_ptix2d + , testProperty "prop_strictness insert textindex" prop_invix1 + , testProperty "prop_strictness insert numericindex" prop_invix2 + , testProperty "prop_strictness insert dateindex" prop_invix3 + , testProperty "prop_strictness insert geoindex" prop_invix4 + , testProperty "prop_strictness insert geoindex rtree" prop_insert_rtree + , testProperty "prop_strictness insert proxy" prop_proxy + -- delete / deleteDocs + , testProperty "prop_strictness delete prefixtreeindex" prop_ptix_del + , testProperty "prop_strictness delete prefixtreeindex2D" prop_ptix2d_del + , testProperty "prop_strictness delete textindex" prop_invix1_del + , testProperty "prop_strictness delete numericindex" prop_invix2_del + , testProperty "prop_strictness delete dateindex" prop_invix3_del + , testProperty "prop_strictness delete geoindex" prop_invix4_del + , testProperty "prop_strictness delete geoindex rtree" prop_rtree_del + , testProperty "prop_strictness delete proxy" prop_proxy_del + -- map + , testProperty "prop_strictness map prefixtreeindex" prop_ptix_map + , testProperty "prop_strictness map prefixtreeindex2D" prop_ptix2d_map + , testProperty "prop_strictness map textindex" prop_invix1_map + , testProperty "prop_strictness map numericindex" prop_invix2_map + , testProperty "prop_strictness map dateindex" prop_invix3_map + , testProperty "prop_strictness map geoindex" prop_invix4_map + , testProperty "prop_strictness map geoindex rtree" prop_rtree_map + , testProperty "prop_strictness map proxy" prop_proxy_map + -- mapMaybe + , testProperty "prop_strictness mapMaybe prefixtreeindex" prop_ptix_map2 + , testProperty "prop_strictness mapMaybe prefixtreeinde2d" prop_ptix2d_map2 + , testProperty "prop_strictness mapMaybe textindex" prop_invix1_map2 + , testProperty "prop_strictness mapMaybe numericindex" prop_invix2_map2 + , testProperty "prop_strictness mapMaybe dateindex" prop_invix3_map2 + , testProperty "prop_strictness mapMaybe geoindex" prop_invix4_map2 + , testProperty "prop_strictness mapMaybe geoindex rtree" prop_rtree_map2 + , testProperty "prop_strictness mapMaybe proxy" prop_proxy_map2 + -- unionWith + , testProperty "prop_strictness unionWith prefixtreeindex" prop_ptix_union + , testProperty "prop_strictness unionWith prefixtreeind2d" prop_ptix2d_union + , testProperty "prop_strictness unionWith textindex" prop_invix1_union + , testProperty "prop_strictness unionWith numericindex" prop_invix2_union + , testProperty "prop_strictness unionWith dateindex" prop_invix3_union + , testProperty "prop_strictness unionWith geoindex" prop_invix4_union + , testProperty "prop_strictness unionWith geoindex rtree" prop_rtree_union + , testProperty "prop_strictness unionWith proxy" prop_proxy_union + ] + +-- ---------------------------------------------------------------------------- +-- test data structures +-- ---------------------------------------------------------------------------- + +prop_occs :: Property +prop_occs = monadicIO $ do + x <- pick arbitrary :: PropertyM IO Occurrences + assertNF' $! x + +-- ---------------------------------------------------------------------------- +-- index implementations: insert function +-- ---------------------------------------------------------------------------- + +prop_ptix :: Property +prop_ptix + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.DmPrefixTree Occurrences) + assertNF' ix + where + pickIx = pick arbitrary >>= \val -> return $ Ix.insert "key" (toIntermediate (val::Occurrences)) Ix.empty + +prop_ptix2d :: Property +prop_ptix2d + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx2D.DmPrefixTree Occurrences) + assertNF' ix + where + pickIx = pick arbitrary >>= \val -> return $ Ix.insert "11" (toIntermediate (val::Occurrences)) Ix.empty + +prop_invix1 :: Property +prop_invix1 + = monadicIO $ do + ix <- pickIx :: PropertyM IO (InvIx.InvertedIndex) + assertNF' ix + where + pickIx = pick arbitrary >>= \val -> return $ Ix.insert "key" (toIntermediate (val::Occurrences)) Ix.empty + +prop_invix2 :: Property +prop_invix2 + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.PrefixTreeIndexInt) + assertNF' ix + where + pickIx = pick arbitrary >>= \val -> return $ Ix.insert "1" (toIntermediate (val::Occurrences)) Ix.empty + +prop_invix3 :: Property +prop_invix3 + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.PrefixTreeIndexDate) + assertNF' ix + where + pickIx = pick arbitrary >>= \val -> return $ Ix.insert "2013-01-01" (toIntermediate (val::Occurrences)) Ix.empty + +prop_invix4 :: Property +prop_invix4 + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx2D.PrefixTreeIndexPosition) + assertNF' ix + where + pickIx = pick arbitrary >>= \val -> return $ Ix.insert "1-1" (toIntermediate (val::Occurrences)) Ix.empty + +prop_insert_rtree :: Property +prop_insert_rtree + = monadicIO $ do + ix <- pickIx :: PropertyM IO (RTree.RTreeIndex Occurrences) + assertNF' ix + where + pickIx = pick arbitrary >>= \val -> return $ Ix.insert (RTree.readPosition "1-1") (toIntermediate (val::Occurrences)) Ix.empty + +prop_proxy :: Property +prop_proxy + = monadicIO $ do + ix <- pickIx :: PropertyM IO (KeyProxy.KeyProxyIndex Text (PIx.DmPrefixTree Occurrences)) + assertNF' ix + where + pickIx = pick arbitrary >>= \val -> return $ Ix.insert "key" (toIntermediate (val::Occurrences)) Ix.empty + +-- ---------------------------------------------------------------------------- +-- index implementations: delete function +-- ---------------------------------------------------------------------------- + +prop_ptix_del :: Property +prop_ptix_del + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.DmPrefixTree Occurrences) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_delete "key" + + +prop_ptix2d_del :: Property +prop_ptix2d_del + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx2D.DmPrefixTree Occurrences) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_delete "11" + +prop_invix1_del :: Property +prop_invix1_del + = monadicIO $ do + ix <- pickIx :: PropertyM IO (InvIx.InvertedIndex) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_delete "key" + +prop_invix2_del :: Property +prop_invix2_del + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.PrefixTreeIndexInt) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_delete "1" + +prop_invix3_del :: Property +prop_invix3_del + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.PrefixTreeIndexDate) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_delete "2013-01-01" + +prop_invix4_del :: Property +prop_invix4_del + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx2D.PrefixTreeIndexPosition) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_delete "1-1" + +prop_rtree_del :: Property +prop_rtree_del + = monadicIO $ do + ix <- pickIx :: PropertyM IO (RTree.RTreeIndex Occurrences) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_delete (RTree.readPosition "1-1") + +prop_proxy_del :: Property +prop_proxy_del + = monadicIO $ do + ix <- pickIx :: PropertyM IO (KeyProxy.KeyProxyIndex Text (PIx.DmPrefixTree Occurrences)) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_delete "key" + +insert_and_delete :: forall (m :: * -> *) a. + (Ix.ICon a, Monad m, IndexValue (Ix.IVal a), Ix.Index a) => + Ix.IKey a -> DocIdMap Positions -> m a +insert_and_delete key v + = return $ Ix.delete docId + $ Ix.insert key (toIntermediate (v::Occurrences)) + $ Ix.empty + where + docId = case DM.toList v of + ((did,_):_) -> did + _ -> mkDocId (0::Int) + +-- ---------------------------------------------------------------------------- +-- index implementations: map function +-- ---------------------------------------------------------------------------- + +prop_ptix_map :: Property +prop_ptix_map + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.DmPrefixTree Occurrences) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map "key" + +prop_ptix2d_map :: Property +prop_ptix2d_map + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx2D.DmPrefixTree Occurrences) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map "11" + +prop_invix1_map :: Property +prop_invix1_map + = monadicIO $ do + ix <- pickIx :: PropertyM IO (InvIx.InvertedIndex) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map "key" + +prop_invix2_map :: Property +prop_invix2_map + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.PrefixTreeIndexInt) + assertNF' ix + where + pickIx = pick arbitrary >>= \val -> insert_and_map_withSet "1" (val :: DocIdSet) + +prop_invix3_map :: Property +prop_invix3_map + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.PrefixTreeIndexDate) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map_withSet "2013-01-01" + +prop_invix4_map :: Property +prop_invix4_map + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx2D.PrefixTreeIndexPosition) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map_withSet "1-1" + +prop_rtree_map :: Property +prop_rtree_map + = monadicIO $ do + ix <- pickIx :: PropertyM IO (RTree.RTreeIndex Occurrences) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map (RTree.readPosition "1-1") + +prop_proxy_map :: Property +prop_proxy_map + = monadicIO $ do + ix <- pickIx :: PropertyM IO (KeyProxy.KeyProxyIndex Text (PIx.DmPrefixTree Occurrences)) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map "key" + +insert_and_map :: forall (m :: * -> *) a. + (Ix.ICon a, Monad m, Ix.Index a, Ix.IVal a ~ DocIdMap Positions) => + Ix.IKey a -> Occurrences -> m a +insert_and_map key v + = return $ Ix.map (DM.insert (mkDocId (1 :: Int)) (Pos.singleton 1)) + $ Ix.insert key (toIntermediate (v::Occurrences)) Ix.empty + +insert_and_map_withSet :: forall (m :: * -> *) a. + (Ix.ICon a, Monad m, Ix.Index a, Ix.IVal a ~ DocIdSet) => + Ix.IKey a -> DocIdSet -> m a +insert_and_map_withSet key v + = return $ Ix.map (DS.union (DS.singleton $ mkDocId (1 :: Int))) + $ Ix.insert key (toIntermediate (v::DocIdSet)) Ix.empty + + + +-- ---------------------------------------------------------------------------- +-- index implementations: mapMaybe function +-- ---------------------------------------------------------------------------- + +prop_ptix_map2 :: Property +prop_ptix_map2 + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.DmPrefixTree Occurrences) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map2 "key" + +prop_ptix2d_map2 :: Property +prop_ptix2d_map2 + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx2D.DmPrefixTree Occurrences) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map2 "11" + +prop_invix1_map2 :: Property +prop_invix1_map2 + = monadicIO $ do + ix <- pickIx :: PropertyM IO (InvIx.InvertedIndex) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map2 "key" + +prop_invix2_map2 :: Property +prop_invix2_map2 + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.PrefixTreeIndexInt) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map2_withSet "1" + +prop_invix3_map2 :: Property +prop_invix3_map2 + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.PrefixTreeIndexDate) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map2_withSet "2013-01-01" + +prop_invix4_map2 :: Property +prop_invix4_map2 + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx2D.PrefixTreeIndexPosition) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map2_withSet "1-1" + + +prop_rtree_map2 :: Property +prop_rtree_map2 + = monadicIO $ do + ix <- pickIx :: PropertyM IO (RTree.RTreeIndex Occurrences) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map2 (RTree.readPosition "1-1") + +prop_proxy_map2 :: Property +prop_proxy_map2 + = monadicIO $ do + ix <- pickIx :: PropertyM IO (KeyProxy.KeyProxyIndex Text (PIx.DmPrefixTree Occurrences)) + assertNF' ix + where + pickIx = pick arbitrary >>= insert_and_map2 "key" + +insert_and_map2 :: forall (m :: * -> *) a. + (Ix.ICon a, Monad m, Ix.Index a, Ix.IVal a ~ DocIdMap Positions) => + Ix.IKey a -> Occurrences -> m a +insert_and_map2 key v + = return $ Ix.mapMaybe (Just . DM.insert (mkDocId (1 :: Int)) (Pos.singleton 1)) + $ Ix.insert key (toIntermediate (v::Occurrences)) Ix.empty + +insert_and_map2_withSet :: forall (m :: * -> *) a. + (Ix.ICon a, Monad m, Ix.Index a, Ix.IVal a ~ DocIdSet) => + Ix.IKey a -> DocIdSet -> m a +insert_and_map2_withSet key v + = return $ Ix.mapMaybe (Just . DS.union (DS.singleton $ mkDocId (1 :: Int))) + $ Ix.insert key (toIntermediate (v::DocIdSet)) Ix.empty + +-- ---------------------------------------------------------------------------- +-- index implementations: unionWith function +-- ---------------------------------------------------------------------------- + +prop_ptix_union :: Property +prop_ptix_union + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.DmPrefixTree Occurrences) + assertNF' ix + where + pickIx = do + val1 <- pick arbitrary + val2 <- pick arbitrary + insert_and_union "key" val1 val2 + +prop_ptix2d_union :: Property +prop_ptix2d_union + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx2D.DmPrefixTree Occurrences) + assertNF' ix + where + pickIx = do + val1 <- pick arbitrary + val2 <- pick arbitrary + insert_and_union "11" val1 val2 + +prop_invix1_union :: Property +prop_invix1_union + = monadicIO $ do + ix <- pickIx :: PropertyM IO (InvIx.InvertedIndex) + assertNF' ix + where + pickIx = do + val1 <- pick arbitrary + val2 <- pick arbitrary + insert_and_union "key" val1 val2 + +prop_invix2_union :: Property +prop_invix2_union + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.PrefixTreeIndexInt) + assertNF' ix + where + pickIx = do + val1 <- pick arbitrary + val2 <- pick arbitrary + insert_and_union_withSet "1" val1 val2 + +prop_invix3_union :: Property +prop_invix3_union + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx.PrefixTreeIndexDate) + assertNF' ix + where + pickIx = do + val1 <- pick arbitrary :: PropertyM IO DocIdSet + val2 <- pick arbitrary :: PropertyM IO DocIdSet + insert_and_union_withSet "2013-01-01" val1 val2 + +prop_invix4_union :: Property +prop_invix4_union + = monadicIO $ do + ix <- pickIx :: PropertyM IO (PIx2D.PrefixTreeIndexPosition) + assertNF' ix + where + pickIx = do + val1 <- pick arbitrary :: PropertyM IO DocIdSet + val2 <- pick arbitrary :: PropertyM IO DocIdSet + insert_and_union_withSet "1-1" val1 val2 + +prop_rtree_union :: Property +prop_rtree_union + = monadicIO $ do + ix <- pickIx :: PropertyM IO (RTree.RTreeIndex Occurrences) + assertNF' ix + where + pickIx = do + val1 <- pick arbitrary :: PropertyM IO Occurrences + val2 <- pick arbitrary :: PropertyM IO Occurrences + insert_and_union (RTree.readPosition "1-1") val1 val2 + +prop_proxy_union :: Property +prop_proxy_union + = monadicIO $ do + ix <- pickIx :: PropertyM IO (KeyProxy.KeyProxyIndex Text (PIx.DmPrefixTree Occurrences)) + assertNF' ix + where + pickIx = do + val1 <- pick arbitrary :: PropertyM IO Occurrences + val2 <- pick arbitrary :: PropertyM IO Occurrences + insert_and_union "key" val1 val2 + +insert_and_union :: forall (m :: * -> *) a v. + (Ix.ICon a, Monad m, IndexValue (DocIdMap v), Ix.Index a, + Ix.IVal a ~ DocIdMap v) => + Ix.IKey a -> Occurrences -> Occurrences -> m a +insert_and_union key v1 v2 + = return $ Ix.unionWith (DM.union) + (Ix.insert key (toIntermediate (v1::Occurrences)) Ix.empty) + (Ix.insert key (toIntermediate (v2::Occurrences)) Ix.empty) + +insert_and_union_withSet :: forall (m :: * -> *) a. + (Ix.ICon a, Monad m, Ix.Index a, Ix.IVal a ~ DocIdSet) => + Ix.IKey a -> DocIdSet -> DocIdSet -> m a +insert_and_union_withSet key v1 v2 + = return $ Ix.unionWith (DS.union) + (Ix.insert key (toIntermediate (v1::DocIdSet)) Ix.empty) + (Ix.insert key (toIntermediate (v2::DocIdSet)) Ix.empty) + diff --git a/test/Hunt/TestHelper.hs b/test/Hunt/TestHelper.hs new file mode 100644 --- /dev/null +++ b/test/Hunt/TestHelper.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS -fno-warn-orphans #-} + +-- ---------------------------------------------------------------------------- +{- | + Helper and generator for test suites. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.TestHelper where + +import System.Random +import Test.QuickCheck +import Test.QuickCheck.Gen +import Test.QuickCheck.Random +import Test.QuickCheck.Monadic +import Control.Monad (foldM) + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Default +import qualified Control.Monad.Parallel as Par + +import Hunt.Common +import qualified Hunt.Common.Positions as Pos +import qualified Hunt.Common.Occurrences as Occ +import qualified Hunt.Common.DocDesc as DD +import qualified Hunt.Common.DocIdSet as DS + +import Hunt.Interpreter.Command +import Hunt.ClientInterface hiding (mkDescription) + +import qualified Hunt.Index as Ix +import Hunt.Index.IndexImpl +import qualified Hunt.ContextIndex as ConIx +import qualified Hunt.Index.InvertedIndex as InvIx +import qualified Hunt.DocTable as Dt +import qualified Hunt.DocTable.HashedDocTable as HDt +import Hunt.Utility + +import Data.Time +import System.Locale + +instance Par.MonadParallel (PropertyM IO) where + +insertCx :: Context -> ConIx.ContextIndex (HDt.Documents Document) +insertCx cx + = ConIx.insertContext cx (mkIndex ix) def ConIx.empty + where + ix :: InvIx.InvertedIndex + ix = Ix.empty + + +mkInsertList' :: Gen [(Document, Words)] +mkInsertList' = mkDocuments >>= mkInsertList + +mkInsertList :: [Document] -> Gen [(Document, Words)] +mkInsertList docs = mapM (\doc -> mkWords >>= \wrds -> return (doc, wrds)) docs + +-- -------------------- +-- Arbitrary Words + +-- using context1 .. context5 as fixed contexts +-- arbitrary context names would not work well in tests +mkWords :: Gen Words +mkWords = mapM addWordsToCx cxs >>= return . M.fromList + where + addWordsToCx cx = mkWordList >>= \l -> return (cx,l) + cxs = map (\i -> T.pack $ "context" ++ (show i)) ([1..5] :: [Int]) + +mkWordList :: Gen WordList +mkWordList = listOf pair >>= return . M.fromList + where + pair = do + word <- niceText1 + pos <- listOf arbitrary :: Gen [Int] + return (word, pos) + +instance Arbitrary (HDt.Documents Document) where + arbitrary = mkDocTable' + +mkDocTables :: Gen [(HDt.Documents Document)] +mkDocTables = do + -- generate list of distinct documents so + -- that generated doctables are disjunct. + -- Thats important for some testcases + docs <- mkDocuments + mapM mkDocTable $ partitionListByLength 10 docs + +mkDocTable' :: Gen (HDt.Documents Document) +mkDocTable' = do + docs <- mkDocuments + mkDocTable docs + +mkDocTable :: [Document] -> Gen (HDt.Documents Document) +mkDocTable docs = foldM (\dt doc -> Dt.insert doc dt >>= return . snd) Dt.empty docs + +instance Arbitrary [Document] where + arbitrary = mkDocuments + +mkDocuments :: Gen [Document] +mkDocuments = do + numberOfDocuments <- arbitrary :: Gen Int + mapM mkDocument [1..numberOfDocuments] + +instance Arbitrary Document where + arbitrary = mkDocument' + +mkDocument' :: Gen Document +mkDocument' = arbitrary >>= mkDocument + +mkDocument :: Int -> Gen Document +mkDocument uri' = do + d <- mkDescription + w <- arbitrary + return $ Document (T.pack . show $ uri') d (SC w) + +mkDescription :: Gen Description +mkDescription = do + txt <- niceText1 + txt2 <- niceText1 + return $ DD.fromList [ ("key1", txt) + , ("key2", txt2) + ] +-- -------------------- +-- Arbitrary Occurrences + +instance Arbitrary Occurrences where + arbitrary = mkOccurrences + +mkOccurrences :: Gen Occurrences +mkOccurrences = listOf mkPositions >>= foldM foldOccs Occ.empty + where + foldOccs occs ps = do + docId <- arbitrary :: Gen Int + return $ Occ.insert' (mkDocId docId) ps occs + +mkPositions :: Gen Positions +mkPositions = listOf arbitrary >>= return . Pos.fromList + +instance Arbitrary DocIdSet where + arbitrary = mkDocIdSet + +instance Arbitrary DocId where + arbitrary = arbitrary >>= \i -> return . mkDocId $ (i :: Int) + +mkDocIdSet :: Gen DocIdSet +mkDocIdSet = listOf arbitrary >>= return . DS.fromList + + +-- -------------------- +-- Arbitrary ApiDocument + +apiDocs :: Int -> Int -> IO [ApiDocument] +apiDocs = mkData apiDocGen + + +mkData :: (Int -> Gen a) -> Int -> Int -> IO [a] +mkData gen minS maxS = + do rnd0 <- newQCGen --newStdGen + let rnds rnd = rnd1 : rnds rnd2 where (rnd1,rnd2) = System.Random.split rnd + return [unGen (gen i) r n | ((r,n),i) <- rnds rnd0 `zip` cycle [minS..maxS] `zip` [1..]] -- simple cycle + + +apiDocGen :: Int -> Gen ApiDocument +apiDocGen n = do + desc_ <- descriptionGen + let ix = mkIndexData n desc_ + return $ ApiDocument uri_ ix desc_ 1.0 + where uri_ = T.pack . ("rnd://" ++) . show $ n + +niceText1 :: Gen Text +niceText1 = fmap T.pack . listOf1 . elements $ concat [" ", ['A'..'Z'], ['a'..'z']] + + +descriptionGen :: Gen Description +descriptionGen = do + tuples <- listOf kvTuples + return $ DD.fromList tuples + where + kvTuples = do + a <- resize 15 niceText1 -- keys are short + b <- niceText1 + return (a,b) + + +mkIndexData :: Int -> Description -> Map Context Content +mkIndexData i d = M.fromList + $ map (\c -> ("context" `T.append` (T.pack $ show c), prefixx c)) [0..i] + where +-- index = T.pack $ show i + prefixx n = T.intercalate " " . map (T.take n . T.filter (/=' ')) $ values + values = map (T.pack . show . snd) $ DD.toList d + +-- -------------------------------------- +-- Other + +dateYYYYMMDD :: Gen Text +dateYYYYMMDD = arbitrary >>= \x -> return . T.pack $ formatTime defaultTimeLocale "%Y-%m-%d" (newDate x) + where + newDate x = addDays (-x) (fromGregorian 2013 12 31) + +-- ------------------------------------------------------------ +-- Example documents and contexts + +-- | test document with "brain" document description +-- and term "brain" added to index +brainDoc' :: URI -> ApiDocument +brainDoc' uri' + = addBrainDescAndIx + $ mkApiDoc uri' + +brainDoc :: ApiDocument +brainDoc + = brainDoc' "test://0" + + +addBrainDescAndIx :: ApiDocument -> ApiDocument +addBrainDescAndIx + = setDescription descr + . setIndex (M.fromList [("default", td)]) + where + td = "Brain" + descr = DD.fromList [ ("name", "Brain" :: String) + , ("mission", "take over the world") + , ("legs", "4") + ] + +-- | test document with "brain" description and also a value +-- added to the datecontext +dateDoc' :: URI -> ApiDocument +dateDoc' uri' + = addToIndex "datecontext" "2013-01-01" + $ addBrainDescAndIx + $ mkApiDoc uri' + +dateDoc :: ApiDocument +dateDoc + = dateDoc' "test://1" + +-- | test document with "brain" description and also a value +-- added to the geocontext +geoDoc'' :: URI -> Text -> ApiDocument +geoDoc'' uri' position + = addToIndex "geocontext" position + $ addBrainDescAndIx + $ mkApiDoc uri' + +geoDoc' :: Text -> ApiDocument +geoDoc' pos + = geoDoc'' "test://2" pos + +geoDoc :: ApiDocument +geoDoc = geoDoc' "53.60000-10.00000" + +-- example apidoc +brainDocUpdate :: ApiDocument +brainDocUpdate = setDescription descr $ brainDoc + where + descr = DD.fromList [("name", "Pinky" :: String), ("mission", "ask stupid questions")] + +brainDocMerged :: ApiDocument +brainDocMerged + = changeDescription (`DD.union` (getDescription brainDoc)) + $ brainDocUpdate + +-- | insert default text context command +insertDefaultContext :: Command +insertDefaultContext = uncurry cmdInsertContext defaultContextInfo + +-- | insert geo context command +insertGeoContext :: Command +insertGeoContext = uncurry cmdInsertContext geoContextInfo + +-- | insert date context command +insertDateContext :: Command +insertDateContext = uncurry cmdInsertContext dateContextInfo + +-- | default text context +defaultContextInfo :: (Context, ContextSchema) +defaultContextInfo = ("default", ContextSchema Nothing [] 1 True ctText) + +-- | default date context +dateContextInfo :: (Context, ContextSchema) +dateContextInfo = ("datecontext", ContextSchema Nothing [] 1 True ctDate) + +-- | default geo context +geoContextInfo :: (Context, ContextSchema) +geoContextInfo = ("geocontext", ContextSchema Nothing [] 1 True ctPosition) + +