module Holumbus.Index.CompactSmallDocuments
(
SmallDocuments (..)
, emptyDocuments
, singleton
, docTable2smallDocTable
)
where
import Control.DeepSeq
import Data.Binary ( Binary )
import qualified Data.Binary as B
import Holumbus.Index.Common
import qualified Holumbus.Index.CompactDocuments as CD
import Text.XML.HXT.Core
newtype SmallDocuments a = SmallDocuments
{ idToSmallDoc :: CD.DocMap a
}
instance (Binary a, HolIndex i) => HolDocIndex SmallDocuments a i where
defragmentDocIndex = notImpl
unionDocIndex dt1 ix1 dt2 ix2
= (dt, ix)
where
dt = unionDocs dt1 dt2
ix = mergeIndexes ix1 ix2
instance Binary a => HolDocuments SmallDocuments a where
sizeDocs = sizeDocIdMap . idToSmallDoc
lookupById d i = maybe (fail "") return
. fmap CD.toDocument
. lookupDocIdMap i
. idToSmallDoc
$ d
makeEmpty _ = emptyDocuments
disjointDocs dt1 dt2
| nullDocs dt1
||
nullDocs dt2 = True
| otherwise = disjoint ( minKeyDocIdMap . idToSmallDoc $ dt1
, maxKeyDocIdMap . idToSmallDoc $ dt1
)
( minKeyDocIdMap . idToSmallDoc $ dt2
, maxKeyDocIdMap . idToSmallDoc $ dt2
)
where
disjoint p1@(x1, y1) p2@(x2, _y2)
| x1 <= x2 = y1 < x2
| otherwise = disjoint p2 p1
unionDocs dt1 dt2
| disjointDocs dt1 dt2 = SmallDocuments
{ idToSmallDoc = unionDocIdMap (idToSmallDoc dt1) (idToSmallDoc dt2)
}
| otherwise = error $
"unionDocs: doctables are not disjoint: " ++
show (didIntervall dt1) ++ ", " ++ show (didIntervall dt2)
where
didIntervall dt = ( minKeyDocIdMap . idToSmallDoc $ dt
, maxKeyDocIdMap . idToSmallDoc $ dt
)
editDocIds f d = SmallDocuments
{ idToSmallDoc = newIdToDoc
}
where
newIdToDoc = foldWithKeyDocIdMap (insertDocIdMap . f) emptyDocIdMap
$ idToSmallDoc d
fromMap = SmallDocuments . CD.toDocMap
toMap = CD.fromDocMap . idToSmallDoc
lookupByURI = notImpl
insertDoc = notImpl
updateDoc = notImpl
removeById = notImpl
updateDocuments = notImpl
filterDocuments = notImpl
instance NFData a => NFData (SmallDocuments a)
where
rnf (SmallDocuments i2d) = rnf i2d
instance (Binary a, XmlPickler a) =>
XmlPickler (SmallDocuments a)
where
xpickle = xpElem "documents" $
xpWrap convertDoctable $
xpWrap (fromListDocIdMap, toListDocIdMap) $
xpList xpDocumentWithId
where
convertDoctable = ( SmallDocuments
, idToSmallDoc
)
xpDocumentWithId = xpElem "doc" $
xpPair (xpAttr "id" xpDocId) xpickle
instance Binary a => Binary (SmallDocuments a)
where
put (SmallDocuments i2d) = B.put i2d
get = do
i2d <- B.get
return $ SmallDocuments i2d
notImpl :: a
notImpl = error "operation not implemented for SmallDocuments data type"
emptyDocuments :: SmallDocuments a
emptyDocuments = SmallDocuments emptyDocIdMap
singleton :: (Binary a) => Document a -> SmallDocuments a
singleton d = SmallDocuments (singletonDocIdMap firstDocId (CD.fromDocument d))
docTable2smallDocTable :: CD.Documents a -> SmallDocuments a
docTable2smallDocTable = SmallDocuments . CD.idToDoc