content: {-# LANGUAGE CPP                        #-}
  {-# LANGUAGE DeriveDataTypeable         #-}
  {-# LANGUAGE FlexibleInstances          #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE MultiParamTypeClasses      #-}
  
  -- ----------------------------------------------------------------------------
  
  {- |
    Module     : Holumbus.Index.HashedDocuments
    Copyright  : Copyright (C) 2012 Uwe Schmidt
    License    : MIT
  
    Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
    Stability  : experimental
  
    A more space efficient substitute for Holumbus.Index.Documents
    and a more flexible implementation than Holumbus.Index.CompactDocuments.
  
    DocIds are computed by a hash function, so the inverse map from URIs to DocIds
    is substituted by the hash function
  -}
  
  -- ----------------------------------------------------------------------------
  
  module Holumbus.Index.HashedDocuments
      (
        -- * Documents type
        Documents (..)
      , CompressedDoc(..)
      , DocMap
  
        -- * Construction
      , emptyDocuments
      , singleton
  
        -- * Conversion
      , toDocument
      , fromDocument
      , fromDocMap
      , toDocMap
      )
  where
  
  import qualified Codec.Compression.BZip as BZ
  
  import           Control.DeepSeq
  
  import           Data.Binary            (Binary)
  import qualified Data.Binary            as B
  import qualified Data.ByteString.Lazy   as BL
  import           Data.Digest.Pure.SHA
  import           Data.Typeable
  
  import           Holumbus.Index.Common
  
  import           Text.XML.HXT.Core
  
  #if sizeable == 1
  import           Data.Size
  #endif
  
  -- ----------------------------------------------------------------------------
  
  -- | The table which is used to map a document to an artificial id and vice versa.
  
  newtype Documents a
      = Documents { idToDoc :: DocMap a }   -- ^ A mapping from a document id to
                                            --   the document itself.
        deriving (Eq, Show, NFData, Typeable)
  
  -- ----------------------------------------------------------------------------
  -- | The hash function from URIs to DocIds
  
  docToId :: URI -> DocId
  docToId = mkDocId . integerDigest . sha1 . B.encode
  
  -- ----------------------------------------------------------------------------
  
  instance (Binary a, HolIndex i) => HolDocIndex Documents a i where
      unionDocIndex dt1 ix1 dt2 ix2
          | s1 == 0
              = (dt2, ix2)
          | s2 == 0
              = (dt1, ix1)
          | s1 < s2
              = unionDocIndex dt2 ix2 dt1 ix1
          | otherwise
              = (dt, ix)
          where
            dt = unionDocs'    dt1  dt2   -- the unchecked version of union of doctables
            ix = mergeIndexes  ix1  ix2
            s1 = sizeDocs dt1
            s2 = sizeDocs dt2
  
  -- ----------------------------------------------------------------------------
  
  instance Binary a => HolDocuments Documents a where
    sizeDocs
        = sizeDocIdMap . idToDoc
  
    lookupById  d i
        = maybe (fail "") return
          . fmap toDocument
          . lookupDocIdMap i
          . idToDoc
          $ d
  
    lookupByURI d u
        = maybe (fail "") (const $ return i)
          . lookupDocIdMap i
          . idToDoc
          $ d
          where
            i = docToId u
  
    disjointDocs dt1 dt2
        = nullDocIdMap $ intersectionDocIdMap (idToDoc dt1) (idToDoc dt2)
  
    unionDocs dt1 dt2
        | disjointDocs dt1 dt2
            = unionDocs' dt1 dt2
        | otherwise
            = error $
              "HashedDocuments.unionDocs: doctables are not disjoint"
  
    makeEmpty _
        = emptyDocuments
  
    insertDoc ds d
        = maybe reallyInsert (const (newId, ds)) (lookupById ds newId)
          where
            newId = docToId . uri $ d
            d'    = fromDocument d
            reallyInsert
                = newDocs `seq` (newId, newDocs)
                where
                  newDocs = Documents {idToDoc = insertDocIdMap newId d' $ idToDoc ds}
  
    updateDoc ds i d
        = Documents {idToDoc = insertDocIdMap i d' $ idToDoc ds}
        where
          d'                      = fromDocument d
  
    removeById ds d
        = Documents {idToDoc = deleteDocIdMap d $ idToDoc ds}
  
  
    updateDocuments f d
        = Documents {idToDoc = mapDocIdMap (mapDocument f) (idToDoc d)}
  
  
    filterDocuments p d
        = Documents {idToDoc = filterDocIdMap (p . toDocument) (idToDoc d)}
  
  
    fromMap itd'
        = Documents {idToDoc = toDocMap itd'}
  
    toMap
        = fromDocMap . idToDoc
  
  -- ----------------------------------------------------------------------------
  
  instance (Binary a, XmlPickler a) => XmlPickler (Documents a) where
      xpickle
          = xpElem "documents" $
            xpWrap convertDoctable $
            xpWrap (fromListDocIdMap, toListDocIdMap) $
            xpList xpDocumentWithId
          where
          convertDoctable
              = (Documents, idToDoc)
          xpDocumentWithId
              = xpElem "doc" $
                xpPair (xpAttr "id" xpDocId) xpickle
  
  -- ----------------------------------------------------------------------------
  
  instance Binary a => Binary (Documents a) where
      put = B.put . idToDoc
      get = fmap Documents B.get
  
  -- ----------------------------------------------------------------------------
  
  -- | Create an empty table.
  
  emptyDocuments :: Documents a
  emptyDocuments
      = Documents emptyDocIdMap
  
  unionDocs' :: Documents a -> Documents a -> Documents a
  unionDocs' dt1 dt2
      = Documents
        { idToDoc = unionDocIdMap (idToDoc dt1) (idToDoc dt2) }
  
  -- | Create a document table containing a single document.
  
  singleton :: (Binary a) => Document a -> Documents a
  singleton d
      = Documents {idToDoc = singletonDocIdMap (docToId . uri $ d) d'}
      where
        d' = fromDocument d
  
  -- ------------------------------------------------------------
  
  newtype CompressedDoc a
      = CDoc { unCDoc :: BL.ByteString }
        deriving (Eq, Show, NFData, Typeable)
  
  mkCDoc                          :: BL.ByteString -> CompressedDoc a
  mkCDoc s                        = CDoc $!! s
  
  instance (Binary a, XmlPickler a) => XmlPickler (CompressedDoc a) where
      xpickle
          = xpWrap (fromDocument , toDocument) $
            xpickle
  
  instance Binary a => Binary (CompressedDoc a) where
      put = B.put . unCDoc
      get = B.get >>= return . mkCDoc
  
  toDocument      :: (Binary a) => CompressedDoc a -> Document a
  toDocument      = B.decode . BZ.decompress . unCDoc
  
  fromDocument    :: (Binary a) => Document a -> CompressedDoc a
  fromDocument    = CDoc . BZ.compress . B.encode
  
  mapDocument     :: (Binary a) => (Document a -> Document a) -> CompressedDoc a -> CompressedDoc a
  mapDocument f   = fromDocument . f . toDocument
  
  -- ------------------------------------------------------------
  
  type DocMap a
      = DocIdMap (CompressedDoc a)
  
  toDocMap        :: (Binary a) => DocIdMap (Document a) -> DocMap a
  toDocMap        = mapDocIdMap fromDocument
  
  fromDocMap      :: (Binary a) => DocMap a -> DocIdMap (Document a)
  fromDocMap      = mapDocIdMap toDocument
  
  -- ------------------------------------------------------------
  #if sizeable==1
  
  instance (Typeable a, Sizeable a) => Sizeable (Documents a) where
      dataOf                      = dataOf  . idToDoc
      bytesOf                     = bytesOf . idToDoc
      statsOf                     = statsOf . idToDoc
  
  instance Sizeable a => Sizeable (CompressedDoc a) where
      dataOf                      = dataOf  . unCDoc
      bytesOf                     = bytesOf . unCDoc
      statsOf                     = statsOf . unCDoc
  
  #endif
  -- ------------------------------------------------------------
  