Document.hs

{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}
{-# LINE 1 "Text/HyperEstraier/Document.hsc" #-}
-- #prune
{-# LINE 2 "Text/HyperEstraier/Document.hsc" #-}

-- |An interface to manipulate documents of the HyperEstraier.

module Text.HyperEstraier.Document
    ( -- * Types
      Document
    , DocumentID

    , ESTDOC -- private
    , wrapDoc -- private
    , withDocPtr -- private

      -- * Creating and parsing document
    , newDocument
    , parseDraft

      -- * Setting contents and attributes of document
    , addText
    , addHiddenText
    , setAttribute
    , setURI
    , setKeywords
    , setScore

      -- * Getting contents and attributes of document
    , getId
    , getAttrNames
    , getAttribute
    , getText
    , getURI
    , getKeywords
    , getScore

      -- * Dumping document
    , dumpDraft

      -- * Making snippet of document
    , makeSnippet
    )
    where

import qualified Data.ByteString.Char8    as B8
import           Data.Encoding
import           Data.Encoding.UTF8
import           Data.Maybe
import qualified Database.QDBM.Cabin.List as CL
import qualified Database.QDBM.Cabin.Map  as CM
import           Foreign.C.String
import           Foreign.ForeignPtr
import           Foreign.Ptr
import           Text.HyperEstraier.Utils
import           Network.URI

-- |'Document' is an opaque object representing a document of
-- HyperEstraier.
newtype Document = Document (ForeignPtr ESTDOC)
data ESTDOC

-- |'DocumentID' is just an alias to 'Prelude.Int'. It represents a
-- document ID.
type DocumentID = Int


foreign import ccall unsafe "estraier.h est_doc_new"
        _new :: IO (Ptr ESTDOC)

foreign import ccall unsafe "estraier.h est_doc_new_from_draft"
        _new_from_draft :: CString -> IO (Ptr ESTDOC)

foreign import ccall unsafe "estraier.h &est_doc_delete"
        _delete :: FunPtr (Ptr ESTDOC -> IO ())

foreign import ccall unsafe "estraier.h est_doc_add_attr"
        _add_attr :: Ptr ESTDOC -> CString -> CString -> IO ()

foreign import ccall unsafe "estraier.h est_doc_add_text"
        _add_text :: Ptr ESTDOC -> CString -> IO ()

foreign import ccall unsafe "estraier.h est_doc_add_hidden_text"
        _add_hidden_text :: Ptr ESTDOC -> CString -> IO ()

foreign import ccall unsafe "estraier.h est_doc_set_keywords"
        _set_keywords :: Ptr ESTDOC -> Ptr CM.CBMAP -> IO ()

foreign import ccall unsafe "estraier.h est_doc_set_score"
        _set_score :: Ptr ESTDOC -> Int -> IO ()

foreign import ccall unsafe "estraier.h est_doc_id"
        _id :: Ptr ESTDOC -> IO Int

foreign import ccall unsafe "estraier.h est_doc_attr_names"
        _attr_names :: Ptr ESTDOC -> IO (Ptr CL.CBLIST)

foreign import ccall unsafe "estraier.h est_doc_attr"
        _attr :: Ptr ESTDOC -> CString -> IO CString

foreign import ccall unsafe "estraier.h est_doc_cat_texts"
        _cat_texts :: Ptr ESTDOC -> IO CString

foreign import ccall unsafe "estraier.h est_doc_keywords"
        _keywords :: Ptr ESTDOC -> IO (Ptr CM.CBMAP)

foreign import ccall unsafe "estraier.h est_doc_score"
        _score :: Ptr ESTDOC -> IO Int

foreign import ccall unsafe "estraier.h est_doc_dump_draft"
        _dump_draft :: Ptr ESTDOC -> IO CString

foreign import ccall unsafe "estraier.h est_doc_make_snippet"
        _make_snippet :: Ptr ESTDOC -> Ptr CL.CBLIST -> Int -> Int -> Int -> IO CString


wrapDoc :: Ptr ESTDOC -> IO Document
wrapDoc docPtr = newForeignPtr _delete docPtr >>= return . Document


withDocPtr :: Document -> (Ptr ESTDOC -> IO a) -> IO a
withDocPtr (Document doc) = withForeignPtr doc

-- |'newDocument' creates an empty document.
newDocument :: IO Document
newDocument = _new >>= wrapDoc

-- |'parseDraft' parses a document in the \"draft\" format.
parseDraft :: String -> IO Document
parseDraft draft
    = withUTF8CString draft $ \ draftPtr ->
      _new_from_draft draftPtr >>= wrapDoc

-- |Set an attribute value of a document.
setAttribute :: Document     -- ^ The document.
             -> String       -- ^ An attribute name.
             -> Maybe String -- ^ An attribute value. If this is
                             --   'Prelude.Nothing', the attribute
                             --   will be deleted.
             -> IO ()
setAttribute doc name value
    = withDocPtr       doc   $ \ docPtr   ->
      withUTF8CString  name  $ \ namePtr  ->
      withUTF8CString' value $ \ valuePtr ->
      _add_attr docPtr namePtr valuePtr

-- |Add a block of text to a document.
addText :: Document -> String -> IO ()
addText doc text
    = withDocPtr      doc  $ \ docPtr  ->
      withUTF8CString text $ \ textPtr ->
      _add_text docPtr textPtr

-- |Add a block of hidden text to a document.
addHiddenText :: Document -> String -> IO ()
addHiddenText doc text
    = withDocPtr      doc  $ \ docPtr  ->
      withUTF8CString text $ \ textPtr ->
      _add_hidden_text docPtr textPtr

-- |Set an URI of a document. This is a special case of
-- 'setAttribute'.
setURI :: Document -> Maybe URI -> IO ()
setURI doc uri = setAttribute doc "@uri" (fmap uri2str uri)
    where
      uri2str uri = uriToString id uri ""

-- |Set keywords of a document.
setKeywords :: Document            -- ^ The document.
            -> [(String, Integer)] -- ^ A list of @(keyword, score)@.
            -> IO ()
setKeywords doc keywords
    = withDocPtr doc    $ \ docPtr ->
      withKeywordMapPtr $ \ mapPtr ->
      _set_keywords docPtr mapPtr
    where
      withKeywordMapPtr :: (Ptr CM.CBMAP -> IO a) -> IO a
      withKeywordMapPtr f = do m <- CM.fromList $ map encodeKeyword keywords
                               CM.withMapPtr m f

      encodeKeyword (word, score) = (encode UTF8 word, B8.pack $ show score)

-- |Set an alternative score of a document.
setScore :: Document -> Maybe Int -> IO ()
setScore doc score
    = withDocPtr doc $ \ docPtr ->
      _set_score docPtr (fromMaybe (-1) score)

-- |Get the ID of document.
getId :: Document -> IO DocumentID
getId doc
    = withDocPtr doc $ \ docPtr ->
      _id docPtr

-- |Get a list of all attribute names in a document.
getAttrNames :: Document -> IO [String]
getAttrNames doc
    = withDocPtr doc $ \ docPtr ->
      _attr_names docPtr
           >>= CL.wrapList
           >>= CL.toList
           >>= return . map (decode UTF8)

-- |Get an attribute value of a document.
getAttribute :: Document -> String -> IO (Maybe String)
getAttribute doc name
    = withDocPtr doc $ \ docPtr ->
      withUTF8CString name $ \ namePtr ->
      do valuePtr <- _attr docPtr namePtr
         if valuePtr == nullPtr then
             return Nothing
           else
             copyUTF8CString valuePtr >>= return . Just

-- |Get the text in a document.
getText :: Document -> IO String
getText doc
    = withDocPtr doc $ \ docPtr ->
      _cat_texts docPtr
           >>= packMallocUTF8CString

-- |Get the URI of a document.
getURI :: Document -> IO (Maybe URI)
getURI doc = getAttribute doc "@uri" >>= return . fmap parse
    where
      parse :: String -> URI
      parse = fromJust . parseURIReference

-- |Get the keywords of a document.
getKeywords :: Document -> IO [(String, Integer)]
getKeywords doc
    = withDocPtr doc $ \ docPtr ->
      _keywords docPtr
           >>= CM.unsafePeekMap
           >>= CM.toList
           -- ここまで正格。次の行は遲延される。
           >>= return . map decodeKeyword
    where
      decodeKeyword (word, score) = (decode UTF8 word, read $ B8.unpack score)

-- |Get an alternative score of a document.
getScore :: Document -> IO (Maybe Int)
getScore doc
    = withDocPtr doc $ \ docPtr ->
      _score docPtr >>= \ n ->
          case n of
            -1 -> return Nothing
            _  -> return (Just n)
            
-- |Dump a document in the \"draft\" format.
dumpDraft :: Document -> IO String
dumpDraft doc
    = withDocPtr doc $ \ docPtr ->
      _dump_draft docPtr >>= packMallocUTF8CString

-- |Make a snippet from a document.
makeSnippet
    :: Document -- ^ The document.
    -> [String] -- ^ Words to be highlighted.
    -> Int      -- ^ Maximum width of the whole result.
    -> Int      -- ^ Width of the heading text to be shown.
    -> Int      -- ^ Width of the text surrounding each highlighted words.
    -> IO [Either String (String, String)] -- ^ A list of either
                                           -- @('Prelude.Left'
                                           -- non-highlighted text)@
                                           -- or @('Prelude.Right'
                                           -- (highlighted word, its
                                           -- normalized form))@.
makeSnippet doc words wwidth hwidth awidth
    = do wordsList <- CL.fromList $ map (encode UTF8) words
         withDocPtr doc $ \ docPtr ->
             CL.withListPtr wordsList $ \ wordsPtr ->
             _make_snippet docPtr wordsPtr wwidth hwidth awidth
                  >>= packMallocUTF8CString
                  >>= return . parseSnippet
    where
      parseSnippet :: String -> [Either String (String, String)]
      parseSnippet = map parseLine . lines

      parseLine :: String -> Either String (String, String)
      parseLine line = case break (== '\t') line of
                         (x, ""    ) -> Left   x
                         (x, '\t':y) -> Right (x, y)