{-# 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)