content: {-# LANGUAGE DeriveDataTypeable         #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE TypeFamilies               #-}
  
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  -- ----------------------------------------------------------------------------
  {- |
    Text index using the 'DocIdMap' based on the 'StringMap' implementation.
  -}
  -- ----------------------------------------------------------------------------
  
  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.DocIdSet                 (DocIdSet)
  import           Hunt.Index.Schema.Normalize.Position (position)
  
  import           Text.Parsec
  
  -- ------------------------------------------------------------
  
  -- | Index adapter for 'Data.RTree' data structure
  
  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 mappend k' (fromOccurrences v') m') rt kvs
  
      {- same problem as in PrefixTreeIndex, the k' in kvs don't need to be unique
  
         mkDmRT $ RT.unionWith op rt (RT.fromList kvs)
      -}
  
    deleteDocs ks (DmRT rt)
      = mkDmRT $ RT.mapMaybe (diffValues ks) rt
  
    empty
      = mkDmRT $ RT.empty
  
    fromList
      = mkDmRT . RT.fromList . fromOccurrenceList
  
    toList (DmRT rt)
      = toSearchResults . RT.toList $ rt
  
    -- MBBs don't have any case or prefix
    search _ k (DmRT rt)
      = toSearchResults $ RT.lookupRangeWithKey k rt
  
    lookupRange k1 k2 (DmRT rt)
      = toSearchResults $ 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
  
    -- prohibitiv expensive.
    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)
  
  -- ------------------------------------------------------------
  -- Index using RTree for indexing positions and bounding boxes
  -- ------------------------------------------------------------
  
  -- | Newtype to allow date normalization 'Bijection' instance.
  
  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
  
  -- ------------------------------------------------------------
  