module Hunt.Index.RTreeIndex
( RTreeIndex(..)
, SimpleRTreeIndex(..)
, readPosition
, showPosition
)
where
import Control.DeepSeq
import Data.Binary (Binary (..))
import qualified Data.List as L
import Data.Monoid ((<>))
import qualified Data.RTree.Strict as RT
import Data.RTree.MBB
import Data.Text (Text)
import qualified Data.Text as T (pack, unpack)
import Data.Typeable
import Data.Bijection
import Hunt.Index
import qualified Hunt.Index as Ix
import Hunt.Index.Proxy.KeyIndex
import Hunt.Common.IntermediateValue
import Hunt.Common.DocIdSet (DocIdSet)
import Hunt.Index.Schema.Normalize.Position (position)
import Text.Parsec
newtype RTreeIndex v
= DmRT { dmRT :: RT.RTree v }
deriving (Eq, Show, NFData, Typeable)
mkDmRT :: RT.RTree v -> RTreeIndex v
mkDmRT v = DmRT $! v
instance IndexValue x => Binary (RTreeIndex x) where
put = put . dmRT
get = get >>= return . mkDmRT
instance IndexValue v => Index (RTreeIndex v) where
type IKey (RTreeIndex v) = RT.MBB
type IVal (RTreeIndex v) = v
insertList kvs (DmRT rt) =
mkDmRT $ L.foldl' (\ m' (k', v') -> RT.insertWith mergeValues k' v' m') rt (fromIntermediates kvs)
deleteDocs ks (DmRT rt)
= mkDmRT $ RT.mapMaybe (diffValues ks) rt
empty
= mkDmRT $ RT.empty
fromList
= mkDmRT . RT.fromList . fromIntermediates
toList (DmRT rt)
= toIntermediates . RT.toList $ rt
search _ k (DmRT rt)
= toIntermediates $ RT.lookupRangeWithKey k rt
lookupRange k1 k2 (DmRT rt)
= toIntermediates $ RT.lookupRangeWithKey (unionMBB k1 k2) rt
unionWith op (DmRT rt1) (DmRT rt2)
= mkDmRT $ RT.unionWith op rt1 rt2
map f (DmRT rt)
= mkDmRT $ fmap f rt
mapMaybe f (DmRT rt)
= mkDmRT $ RT.mapMaybe f rt
keys (DmRT rt)
= RT.keys rt
readPosition :: Text -> MBB
readPosition t
= case parse position "" $ T.unpack t of
Right (la,lo) -> mbb la lo la lo
Left _ -> error "readPosition positon: invalid"
showPosition :: MBB -> Text
showPosition (MBB la lo _ _ ) = T.pack (show la) <> "-" <> T.pack (show lo)
instance Bijection MBB Text where
to = showPosition
from = readPosition
newtype SimpleRTreeIndex
= InvRTreeIx { invRTreeIx :: KeyProxyIndex Text (RTreeIndex DocIdSet)}
deriving (Eq, Show, NFData, Typeable)
mkInvRTreeIx :: KeyProxyIndex Text (RTreeIndex DocIdSet) -> SimpleRTreeIndex
mkInvRTreeIx x = InvRTreeIx $! x
instance Binary SimpleRTreeIndex where
put = put . invRTreeIx
get = get >>= return . mkInvRTreeIx
instance Index SimpleRTreeIndex where
type IKey SimpleRTreeIndex = Text
type IVal SimpleRTreeIndex = DocIdSet
insertList wos (InvRTreeIx i)
= mkInvRTreeIx $ insertList wos i
deleteDocs docIds (InvRTreeIx i)
= mkInvRTreeIx $ deleteDocs docIds i
empty
= mkInvRTreeIx $ empty
fromList l
= mkInvRTreeIx $ fromList l
toList (InvRTreeIx i)
= toList i
search t k (InvRTreeIx i)
= search t k i
lookupRange k1 k2 (InvRTreeIx i)
= lookupRange k1 k2 i
unionWith op (InvRTreeIx i1) (InvRTreeIx i2)
= mkInvRTreeIx $ unionWith op i1 i2
map f (InvRTreeIx i)
= mkInvRTreeIx $ Ix.map f i
mapMaybe f (InvRTreeIx i)
= mkInvRTreeIx $ Ix.mapMaybe f i
keys (InvRTreeIx i)
= keys i