hunt-searchengine 0.3.0.0 → 0.3.0.1
raw patch · 14 files changed
+2756/−1 lines, 14 filesdep ~textPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: text
API changes (from Hackage documentation)
Files
- hunt-searchengine.cabal +16/−1
- test/Hunt/AnalyzerTests.hs +255/−0
- test/Hunt/Index/ContextIndexTests.hs +65/−0
- test/Hunt/Index/Default.hs +131/−0
- test/Hunt/Index/Helper.hs +50/−0
- test/Hunt/Index/IndexValueTests.hs +93/−0
- test/Hunt/IndexTests.hs +22/−0
- test/Hunt/InterpreterTests.hs +562/−0
- test/Hunt/QueryParserTests.hs +405/−0
- test/Hunt/Strict/ContextIndex.hs +92/−0
- test/Hunt/Strict/DocTable.hs +204/−0
- test/Hunt/Strict/Helper.hs +34/−0
- test/Hunt/Strict/Index.hs +527/−0
- test/Hunt/TestHelper.hs +300/−0
hunt-searchengine.cabal view
@@ -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
+ test/Hunt/AnalyzerTests.hs view
@@ -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"
+ test/Hunt/Index/ContextIndexTests.hs view
@@ -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
+ test/Hunt/Index/Default.hs view
@@ -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]
+ test/Hunt/Index/Helper.hs view
@@ -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))+++
+ test/Hunt/Index/IndexValueTests.hs view
@@ -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
+ test/Hunt/IndexTests.hs view
@@ -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+ ]
+ test/Hunt/InterpreterTests.hs view
@@ -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
+ test/Hunt/QueryParserTests.hs view
@@ -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)+
+ test/Hunt/Strict/ContextIndex.hs view
@@ -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
+ test/Hunt/Strict/DocTable.hs view
@@ -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'
+ test/Hunt/Strict/Helper.hs view
@@ -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++
+ test/Hunt/Strict/Index.hs view
@@ -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)+
+ test/Hunt/TestHelper.hs view
@@ -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)++