diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +The MIT License (MIT) + +Copyright (c) 2007 Timo B. Hübel, Sebastian M. Schlatt, + 2014 Chris Reumann, Ulf Sauer + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/runhaskell + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/hunt-searchengine.cabal b/hunt-searchengine.cabal new file mode 100644 --- /dev/null +++ b/hunt-searchengine.cabal @@ -0,0 +1,189 @@ +name: hunt-searchengine +version: 0.3.0.0 +license: MIT +license-file: LICENSE +author: Chris Reumann, Ulf Sauer, Uwe Schmidt +copyright: Chris Reumann, Ulf Sauer, Uwe Schmidt +maintainer: Chris Reumann, Ulf Sauer, Uwe Schmidt +stability: experimental +category: Text, Data +synopsis: A search and indexing engine. +homepage: http://github.com/hunt-framework/ +description: The Hunt-Searchengine library provides a toolkit to + create fast and flexible searchengines. +cabal-version: >=1.8 +build-type: Simple +-- tested-with: ghc-7.6.3 + +-- extra-source-files: +-- README + +-- enable with cabal test -ftest-strict +flag test-strict + default: False + manual: True + +source-repository head + type: git + location: https://github.com/hunt-framework/hunt-searchengine.git + +library + + build-depends: base >= 4.5 && < 5 + , aeson >= 0.6 + , aeson-pretty >= 0.7 + , binary >= 0.5 && < 1 + , bytestring < 1 + , containers >= 0.5 + , data-r-tree >= 0.0.5.0 + , data-stringmap >= 1.0.1.1 && < 2 + , data-default + , deepseq >= 1.2 + , dlist + , filepath >= 1 + , hslogger >= 1 && < 2 + , hxt-regex-xmlschema >= 9.1 + , monad-parallel >= 0.7 + , mtl >= 1.1 && < 3 + , murmur-hash + , parsec >= 2.1 && < 4 + , text >= 1 && < 1.2 + , time >= 1.4 && < 2 + , transformers >= 0.3 + , unordered-containers >= 0.2 + , vector >= 0.10 + + exposed-modules: + Control.Concurrent.XMVar + + Data.Bijection + Data.Bijection.Instances + Data.IntMap.BinTree.Strict + Data.IntSet.Cache + Data.LimitedPriorityQueue + Data.Text.Binary + Data.Typeable.Binary + + GHC.Fingerprint.Binary + GHC.Stats.Json + + Hunt.ClientInterface + + Hunt.Common + Hunt.Common.ApiDocument + Hunt.Common.BasicTypes + Hunt.Common.DocDesc + Hunt.Common.DocId + Hunt.Common.DocIdMap + Hunt.Common.DocIdSet + Hunt.Common.Document + Hunt.Common.Occurrences + Hunt.Common.Positions + Hunt.Common.RawResult + Hunt.Common.IntermediateValue + + Hunt.Index.Schema + Hunt.Index.Schema.Analyze + Hunt.Index.Schema.Normalize.Date + Hunt.Index.Schema.Normalize.Position + Hunt.Index.Schema.Normalize.Int + + Hunt.Index + Hunt.Index.IndexImpl + Hunt.Index.PrefixTreeIndex + Hunt.Index.PrefixTreeIndex2Dim + Hunt.Index.RTreeIndex + Hunt.Index.InvertedIndex + + Hunt.Index.Proxy.KeyIndex + + Hunt.DocTable + Hunt.DocTable.HashedDocTable + + Hunt.ContextIndex + + Hunt.Interpreter + Hunt.Interpreter.BasicCommand + Hunt.Interpreter.Command + + Hunt.Query.Fuzzy + Hunt.Query.Intermediate + Hunt.Query.Language.Grammar + Hunt.Query.Language.Parser + Hunt.Query.Language.Builder + Hunt.Query.Processor + Hunt.Query.Ranking + Hunt.Query.Result + + Hunt.Utility + Hunt.Utility.Log + Hunt.Utility.Output + + hs-source-dirs: src + + ghc-options: -Wall -funbox-strict-fields -fwarn-tabs -threaded + + extensions: MultiParamTypeClasses + FlexibleContexts + OverloadedStrings + TypeFamilies + ConstraintKinds + KindSignatures + CPP + +test-suite Hunt-Tests + hs-source-dirs: test + main-is: Hunt.hs + type: exitcode-stdio-1.0 + ghc-options: -Wall + extensions: OverloadedStrings + + build-depends: base + , containers + , HUnit + , QuickCheck + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , text + , old-locale + , time + , aeson + , binary + , hunt-searchengine + , mtl + , random + , directory + , data-default + , data-r-tree + , monad-parallel + +test-suite Hunt-Strictness + hs-source-dirs: test + main-is: Strictness.hs + type: exitcode-stdio-1.0 + ghc-options: -Wall + extensions: OverloadedStrings + + if !flag(test-strict) + buildable: False + else + build-depends: base + , containers + , deepseq + , ghc-heap-view >= 0.5 + , HUnit + , hunt-searchengine + , mtl + , QuickCheck + , random >= 1.0 + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , text + , aeson + , unordered-containers + , time + , old-locale + , monad-parallel + , data-default diff --git a/src/Control/Concurrent/XMVar.hs b/src/Control/Concurrent/XMVar.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/XMVar.hs @@ -0,0 +1,94 @@ +-- ---------------------------------------------------------------------------- +{- | + An 'MVar' variation that only blocks for modification. + Readers are never blocked but write access is carried out in sequence. + + This is done with two 'MVar's. + While modification is done, the readers use the old value. + When the modification is done, the old (unmodified) value is replaced with the new one. + For this to work, the writers have to block each other which is done with the second 'MVar'. + This process is encapsulated in 'modifyXMVar' and 'modifyXMVar_'. + + /Note/: This may increase the memory usage since there may be two value present at a time. + This is intended to be used with (big) data structures where small changes are made. +-} +-- ---------------------------------------------------------------------------- + +module Control.Concurrent.XMVar + ( XMVar + , newXMVar + , readXMVar, modifyXMVar, modifyXMVar_ + , takeXMVarWrite, putXMVarWrite + , takeXMVarLock, putXMVarLock + ) +where + +import Control.Concurrent.MVar +import Control.Exception + +-- ------------------------------------------------------------ + +-- | An 'MVar' variation that only blocks for modification. +-- It consists of two 'MVar's. One for the value which can always be read and the second one +-- to block writers so that modifications are done sequentially. +data XMVar a = XMVar (MVar a) (MVar ()) + +-- ------------------------------------------------------------ + +-- | Create a new 'XMVar' with the supplied value. +newXMVar :: a -> IO (XMVar a) +newXMVar v = do + m <- newMVar v + l <- newMVar () + return $ XMVar m l + +-- | Read the value. +readXMVar :: XMVar a -> IO a +readXMVar (XMVar m _) + = readMVar m + +-- | Modify the content. +modifyXMVar :: XMVar a -> (a -> IO (a, b)) -> IO b +modifyXMVar (XMVar m l) f + = mask $ \restore -> do + _ <- takeMVar l + v <- readMVar m + (v',a) <- restore (f v) `onException` putMVar l () + _ <- swapMVar m v' + putMVar l () + return a + +-- | Like 'modifyXMVar' but without a return value. +modifyXMVar_ :: XMVar a -> (a -> IO a) -> IO () +modifyXMVar_ (XMVar m l) f + = mask $ \restore -> do + _ <- takeMVar l + v <- readMVar m + v' <- restore (f v) `onException` putMVar l () + _ <- swapMVar m v' + putMVar l () + +-- | Locks for writes and reads the value. Readers do not block each other. +-- 'modifyXMVar' encapsulates 'takeXMVarWrite' and 'putXMVarWrite' and also handles exceptions. +takeXMVarWrite :: XMVar a -> IO a +takeXMVarWrite (XMVar m l) + = takeMVar l >> readMVar m + +-- | Replaces the value (since it was locked for potential writers) and unlocks writers. +putXMVarWrite :: XMVar a -> a -> IO () +putXMVarWrite (XMVar m l) v + = swapMVar m v >> putMVar l () + +-- | Locks for both reads and writes ('MVar' behaviour). +-- This may be useful to save space because the old @a@ does not have to be kept in memory for +-- read access. Note that references to the old @a@ might still lead to memory leaks/issues. +takeXMVarLock :: XMVar a -> IO a +takeXMVarLock (XMVar m l) + = takeMVar l >> takeMVar m + +-- | Replaces the value (since it was locked for potential writers) and unlocks writers. +putXMVarLock :: XMVar a -> a -> IO () +putXMVarLock (XMVar m l) v + = putMVar m v >> putMVar l () + +-- ------------------------------------------------------------ diff --git a/src/Data/Bijection.hs b/src/Data/Bijection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bijection.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- ---------------------------------------------------------------------------- +{- | +'Bijection' instances represent a bijection between two types and allow conversion to and from. +-} +-- ---------------------------------------------------------------------------- + +module Data.Bijection where + +-- | Bijection between two types @a@ and @b@. +-- 'to' and 'from' represent the bijective function. +-- +-- For a proper bijection between x and y, two instances need to be defined (@Bijection x y@ and +-- @Bijection y x@). +class Bijection a b where + to :: a -> b + from :: b -> a + +-- This works, but requires XFlexibleInstances XUndecidableInstances which causes errors not being +-- checked by the compiler. Probably because the constraint is not smaller than the head (Paterson- +-- Condition?), which is allowed with XUndecidableInstances. +{- +-- | Only one way needs to be defined. +instance Bijection a b => Bijection b a where + to = from + from = to +-} + +-- ------------------------------------------------------------ diff --git a/src/Data/Bijection/Instances.hs b/src/Data/Bijection/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bijection/Instances.hs @@ -0,0 +1,30 @@ +{-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} + +-- ---------------------------------------------------------------------------- +{- | + Default 'Bijection' instances. +-} +-- ---------------------------------------------------------------------------- + +module Data.Bijection.Instances where + +import Data.Text + +import Data.Bijection + +-- ------------------------------------------------------------ + +-- | 'Text' to 'String'. +instance Bijection Text String where + to = unpack + from = pack + +-- | 'String' to 'Text'. +instance Bijection String Text where + to = pack + from = unpack + +-- ------------------------------------------------------------ diff --git a/src/Data/IntMap/BinTree/Strict.hs b/src/Data/IntMap/BinTree/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Data/IntMap/BinTree/Strict.hs @@ -0,0 +1,700 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Data.IntMap.BinTree.Strict where + +import Control.Applicative (Applicative (..), (<$>)) +import Control.DeepSeq +import Control.Monad + +import Data.Binary (Binary (..), getWord8) +import qualified Data.Foldable as F +import qualified Data.IntSet as S +import qualified Data.List as L +import Data.Traversable (Traversable (..)) +import Data.Typeable +import Data.Word (Word8) + +import Prelude hiding (foldl, foldr, lookup, map, null) + +moduleName :: String +moduleName = "Data.IntMap.BinTree.Strict" + +error' :: String -> a +error' = error . ((moduleName ++": ") ++) + +-- ------------------------------------------------------------ + +type Key = Int + +type IntMap v = Tree v + +data Tree v = Empty + | Node !Key !v !(Tree v) !(Tree v) + | Lt !Key !v !(Tree v) -- Lt, Gt and Leaf are special cases + | Gt !Key !v !(Tree v) -- of Node to get rid of the empty trees + | Leaf !Key !v -- Empty occurs only as root, never as subtree + deriving (Show, Typeable) -- This saves 20% of space, average size of + -- objects is 4 instead of 5 words + +-- ------------------------------------------------------------ +-- +-- instances for NFData and Binary + +instance Eq v => Eq (Tree v) where + (==) = equal + +instance NFData v => NFData (Tree v) where + rnf (Node _k v l r) = rnf v `seq` rnf l `seq` rnf r + rnf (Lt _k v l ) = rnf v `seq` rnf l + rnf (Gt _k v r) = rnf v `seq` rnf r + rnf (Leaf _k v ) = rnf v + rnf Empty = () + +instance Binary v => Binary (Tree v) where + put (Empty ) = put (0::Word8) + put (Node k v l r) = put (1::Word8) >> put k >> put v >> put l >> put r + put (Lt k v l ) = put (2::Word8) >> put k >> put v >> put l + put (Gt k v r) = put (3::Word8) >> put k >> put v >> put r + put (Leaf k v ) = put (4::Word8) >> put k >> put v + + get = do tag <- getWord8 + case tag of + 0 -> return Empty + 1 -> Node <$> get <*> get <*> get <*> get + 2 -> Lt <$> get <*> get <*> get + 3 -> Gt <$> get <*> get <*> get + 4 -> Leaf <$> get <*> get + _ -> error' "error in \"get\" while decoding BinTree" + +instance Functor Tree where + fmap = map + +instance F.Foldable Tree where + foldr = foldr + foldl = foldl + foldr' = foldr' + foldl' = foldl' + + {-# INLINE foldr #-} + {-# INLINE foldl #-} + {-# INLINE foldr' #-} + {-# INLINE foldl' #-} + +instance Traversable Tree where + traverse f (Node k v l r) = Node k <$> f v <*> traverse f l <*> traverse f r + traverse f (Lt k v l ) = Lt k <$> f v <*> traverse f l + traverse f (Gt k v r) = Gt k <$> f v <*> traverse f r + traverse f (Leaf k v ) = Leaf k <$> f v + traverse _ (Empty ) = pure Empty + +traverseWithKey :: Applicative t => (Key -> a -> t b) -> Tree a -> t (Tree b) +traverseWithKey f + = go + where + go Empty = pure Empty + go t = mkNode k <$> f k v <*> go l <*> go r + where + (k, v, l, r) = unNode t + +-- = (pure DIM <*>) . IM.traverseWithKey f . unDIM + +-- ------------------------------------------------------------ +-- +-- the smart constructor generating Lt, Gt and Leaf nodes + +mkNode :: Key -> v -> Tree v -> Tree v -> Tree v +mkNode k v Empty Empty = Leaf k v +mkNode k v Empty r = Gt k v r +mkNode k v l Empty = Lt k v l +mkNode k v l r = Node k v l r + +{-# INLINE mkNode #-} + + +-- the smart destructor for normalization of Lt, Gt and Leaf nodes + +unNode :: Tree v -> (Key, v, Tree v, Tree v) +unNode (Node k v l r) = (k, v, l, r ) +unNode (Lt k v l ) = (k, v, l, Empty) +unNode (Gt k v r) = (k, v, Empty, r ) +unNode (Leaf k v ) = (k, v, Empty, Empty) +unNode Empty = error' "\"unNode\" with empty tree" + +{-# INLINE unNode #-} + +-- ------------------------------------------------------------ +-- +-- the work horses + +split' :: Key -> Tree v -> (Maybe v, Tree v, Tree v) +split' _ Empty + = (Nothing, Empty, Empty) + +split' k t + = case compare k k' of + LT -> let (v', l', r') = split' k l + in (v', l', mkNode k' v r' r) + + EQ -> (Just v, l, r) + + GT -> let (v', l', r') = split' k r + in (v', mkNode k' v l l', r') + where + (k', v, l, r) = unNode t + +join' :: Maybe (Key, v) -> Tree v -> Tree v -> Tree v +join' (Just (k, v)) t1 t2 + = mkNode k v t1 t2 + +join' Nothing t1 t2 + = case minViewWithKey t2 of -- get smallest key in t2 + Nothing -> t1 -- and return t1 + Just ((k, v), r) -> mkNode k v t1 r -- or take that key as new root + +{- disabled due to unbalancing of result tree + +join' Nothing t1 t2 + = go t1 + where + go Empty = t2 -- insert whole t2 at the rightmost node in t1 + go t = mkNode k v l (go r) -- balancing ??? + where + (k, v, l, r) = unNode t +-- -} + +{-# INLINE join' #-} + +-- ------------------------------------------------------------ +{- +-- lookup, insert and delete with split' and join' +-- insert and delete change the root +-- and can lead to stronger unbalancing than trad. insert and delete + +lookup :: Key -> Tree v -> Maybe v +lookup k t + = v + where + (v, _l, _r) = split' k t + +insertWith :: (v -> v -> v) -> Key -> v -> Tree v -> Tree v +insertWith f k v t + = join' (Just (k, f' v')) l r + where + (v', l, r) = split' k t + f' Nothing = v + f' (Just v'') = f v'' v + +delete :: Key -> Tree v -> Tree v +delete k t + = join' Nothing l r + where + (_, l, r) = split' k t + +{-# INLINE lookup #-} +{-# INLINE insertWith #-} +{-# INLINE delete #-} + +-- -} +-- ------------------------------------------------------------ +-- {- +-- traditional lookup, insert and remove + +lookup :: Key -> Tree v -> Maybe v +lookup k + = go + where + go Empty = Nothing + go t = case compare k k' of + LT -> go l + EQ -> Just v + GT -> go r + where + (k', v, l, r) = unNode t + +insertWith :: (v -> v -> v) -> Key -> v -> Tree v -> Tree v +insertWith f k v + = ins + where + ins Empty = mkNode k v Empty Empty + ins t = case compare k k' of + LT -> mkNode k' v' (ins l) r + EQ -> mkNode k (f v v') l r + GT -> mkNode k' v' l (ins r) + where + (k', v', l, r) = unNode t + +delete :: Key -> Tree v -> Tree v +delete k + = del + where + del Empty = Empty + del t = case compare k k' of + LT -> mkNode k' v' (del l) r + EQ -> case minViewWithKey r of + Nothing -> Empty + Just ((k'', v''), r') -> mkNode k'' v'' l r' + GT -> mkNode k' v' l (del r) + where + (k', v', l, r) = unNode t + +{-# INLINE lookup #-} +{-# INLINE insertWith #-} +{-# INLINE delete #-} + +-- -} +-- ------------------------------------------------------------ +-- +-- derived lookup and insert functions + +find :: Key -> Tree v -> v +find k = maybe notThere id . lookup k + where + notThere = error' ( "error in find: key " + ++ show k + ++ " is not an element of the map" + ) + +findWithDefault :: v -> Key -> Tree v -> v +findWithDefault v k = maybe v id . lookup k + +member :: Key -> Tree v -> Bool +member k = maybe False (const True) . lookup k + +notMember :: Key -> Tree v -> Bool +notMember k = maybe True (const False) . lookup k + + +insert :: Key -> v -> Tree v -> Tree v +insert = insertWith const + + +{-# INLINE find #-} +{-# INLINE findWithDefault #-} +{-# INLINE member #-} +{-# INLINE notMember #-} +{-# INLINE insert #-} + +-- ------------------------------------------------------------ +-- +-- primitive operations + +empty :: Tree v +empty = Empty + +null :: Tree v -> Bool +null Empty = True +null _ = False + +size :: Tree v -> Int +size = foldl' (\ cnt _ -> cnt + 1) 0 + +-- | retuns the size of a tree or Nothing if @size t > limit@ +-- +-- limits the computation time to O(limit), not O(size) + +sizeWithLimit :: Int -> Tree v -> Maybe Int +sizeWithLimit limit + = go 0 + where + go !i Empty + = return i + go !i t + | i == limit + = mzero + | otherwise + = do i' <- go (i+1) l + go i' r + where + (_k, _v, l, r) = unNode t + +-- ------------------------------------------------------------ + +union :: Tree v -> Tree v -> Tree v +union = unionWith const + +unionWith :: (v -> v -> v) -> Tree v -> Tree v -> Tree v +unionWith op + = unionWithKey (const op) + +unionWithKey' :: (Key -> v -> v -> v) -> Tree v -> Tree v -> Tree v +unionWithKey' _ x1 Empty + = x1 +unionWithKey' f x1 x2 + = uni x1 x2 + where + uni Empty t2 = t2 + uni t1 t2 = join' (Just (k, v')) (uni l l') (uni r r') + where + (k, v, l, r) = unNode t1 + (m', l', r') = split' k t2 + v' = maybe v (f k v) m' + +unionsWith :: (v -> v -> v) -> [Tree v] -> Tree v +unionsWith f = L.foldl' (\ acc t -> unionWith f acc t) empty + +{-# INLINE union #-} +{-# INLINE unionWith #-} +{-# INLINE unionWithKey' #-} + +-- ------------------------------------------------------------ + +difference :: Tree a -> Tree b -> Tree a +difference = differenceWith (const (const Nothing)) + +differenceWith :: (a -> b -> Maybe a) -> Tree a -> Tree b -> Tree a +differenceWith op + = differenceWithKey (const op) + +differenceWithKey' :: (Key -> a -> b -> Maybe a) -> Tree a -> Tree b -> Tree a +differenceWithKey' _ x1 Empty + = x1 + +differenceWithKey' f x1 x2 + = diff x1 x2 + where + diff Empty _ = Empty + diff t1 t2 = join' v' (diff l l') (diff r r') + where + (k, v, l, r) = unNode t1 + (m', l', r') = split' k t2 + v' = case m' of + Nothing -> Just (k, v) + Just x -> case f k v x of + Nothing -> Nothing + Just y -> Just (k, y) + +{-# INLINE difference #-} +{-# INLINE differenceWith #-} +{-# INLINE differenceWithKey' #-} + +-- ------------------------------------------------------------ + +intersection :: Tree a -> Tree b -> Tree a +intersection = intersectionWith const + +intersectionWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c +intersectionWith op + = intersectionWithKey (const op) + +intersectionWithKey' :: (Key -> a -> b -> c) -> Tree a -> Tree b -> Tree c +intersectionWithKey' _ _ Empty + = Empty +intersectionWithKey' f x1 x2 + = intersect x1 x2 + where + intersect Empty _ = Empty + intersect t1 t2 = join' kv' (intersect l l') (intersect r r') + where + (k, v, l, r) = unNode t1 + (m', l', r') = split' k t2 + kv' = (\ y -> (k, f k v y)) <$> m' + +{-# INLINE intersection #-} +{-# INLINE intersectionWith #-} +{-# INLINE intersectionWithKey' #-} + +equal :: Eq v => Tree v -> Tree v -> Bool +equal Empty Empty = True +equal Empty _t2 = False +equal _t1 Empty = False +equal t1 t2 = Just v1 == m2 + && l1 `equal` l2 + && r1 `equal` r2 + where + (k1, v1, l1, r1) = unNode t1 + (m2, l2, r2) = split' k1 t2 + +-- ------------------------------------------------------------ +-- +-- maps + +map :: (a -> b) -> Tree a -> Tree b +map f = mapWithKey (const f) + +mapWithKey :: (Key -> a -> b) -> Tree a -> Tree b +mapWithKey f + = mp + where + mp Empty = Empty + mp t = mkNode k (f k v) (mp l) (mp r) + where + (k, v, l, r) = unNode t + +{-# INLINE map #-} +{-# INLINE mapWithKey #-} + +-- ------------------------------------------------------------ +-- filter + +filter :: (a -> Bool) -> Tree a -> Tree a +filter p = filterWithKey (\ _k v -> p v) + +filterWithKey :: (Key -> a -> Bool) -> Tree a -> Tree a +filterWithKey p + = go + where + go Empty = Empty + go t = join' res (go l) (go r) + where + (k, v, l, r) = unNode t + res | p k v = Just (k, v) + | otherwise = Nothing + +{-# INLINE filter #-} +{-# INLINE filterWithKey #-} + +-- ------------------------------------------------------------ +-- +-- foldr's + +foldr :: (a -> b -> b) -> b -> Tree a -> b +foldr op = foldrWithKey (const op) + +foldr' :: (a -> b -> b) -> b -> Tree a -> b +foldr' op = foldrWithKey' (const op) + +foldrWithKey :: (Key -> a -> b -> b) -> b -> Tree a -> b +foldrWithKey f + = fold + where + fold acc Empty = acc + fold acc t = fold (f k v (fold acc r)) l + where + (k, v, l, r) = unNode t + +foldrWithKey' :: (Key -> a -> b -> b) -> b -> Tree a -> b +foldrWithKey' f + = fold + where + fold !acc Empty = acc + fold !acc t = fold (f k v (fold acc r)) l + where + (k, v, l, r) = unNode t + +-- ------------------------------------------------------------ +-- +-- foldl's + +foldl :: (b -> a -> b) -> b -> Tree a -> b +foldl op = foldlWithKey (\ x _k v -> op x v) + +foldl' :: (b -> a -> b) -> b -> Tree a -> b +foldl' op = foldlWithKey (\ x _k v -> op x v) + +foldlWithKey :: (b -> Key -> a -> b) -> b -> Tree a -> b +foldlWithKey f + = fold + where + fold acc Empty = acc + fold acc t = fold (f (fold acc l) k v) r + where + (k, v, l, r) = unNode t + +foldlWithKey' :: (b -> Key -> a -> b) -> b -> Tree a -> b +foldlWithKey' f + = fold + where + fold !acc Empty = acc + fold !acc t = fold (f (fold acc l) k v) r + where + (k, v, l, r) = unNode t + +{-# INLINE foldr #-} +{-# INLINE foldrWithKey #-} +{-# INLINE foldl #-} +{-# INLINE foldlWithKey #-} + +-- ------------------------------------------------------------ + +fromList :: [(Key, v)] -> Tree v +fromList = L.foldl' (\ acc (k, v) -> insert k v acc) Empty + +fromSet :: (Key -> v) -> S.IntSet -> Tree v +fromSet f = fromAscList . L.map (\ k -> (k, f k)) . S.elems + +fromAscList :: [(Key, v)] -> Tree v +fromAscList = toTr 0 Empty + +-- accumulates a balanced tree from a list +-- by scanning the list just once +-- the input tree t has depth i + +toTr :: Int -> Tree v -> [(Key, v)] -> Tree v +toTr _ t [] = t +toTr i t (x : xs) + | L.null xs1 = t' + | otherwise = toTr (i + 1) t' xs1 + where + (r, xs1) = scan i xs + t' = join' (Just x) t r + +-- builds a tree of depth i from the first 2^i - 1 elements of xs +-- and returns the tree and the remaining list + +scan :: Int -> [(Key, v)] -> (Tree v, [(Key, v)]) +scan 0 xs = (Empty, xs) +scan _ [] = (Empty, []) +scan i xs + | L.null xs1 = (l, []) + | otherwise = (join' (Just x) l r, xs3) + where + (l, xs1) = scan (i - 1) xs + (x : xs2) = xs1 + (r, xs3) = scan (i - 1) xs2 + +-- ------------------------------------------------------------ +-- +-- conversions to lists + +toAscList :: Tree v -> [(Key, v)] +toAscList = foldrWithKey (\ k v res -> (k, v) : res) [] + +toList :: Tree v -> [(Key, v)] +toList = toAscList + +assocs :: Tree v -> [(Key, v)] +assocs = toAscList + +elems :: Tree v -> [v] +elems = foldr (:) [] + +keys :: Tree v -> [Key] +keys = foldrWithKey (\ k _v r -> k : r) [] + +{-# INLINE toAscList #-} +{-# INLINE toList #-} +{-# INLINE assocs #-} +{-# INLINE elems #-} +{-# INLINE keys #-} + +-- ------------------------------------------------------------ +-- +-- min/max + +minView :: Tree v -> Maybe (v, Tree v) +minView t = first snd <$> minViewWithKey t + +minViewWithKey :: Tree v -> Maybe ((Key, v), Tree v) +minViewWithKey Empty = Nothing +minViewWithKey x = Just $ go x + where + go t = case l of + Empty -> ((k, v), r) + _ -> substLeft $ go l + where + (k, v, l, r) = unNode t + substLeft (kv, l') = (kv, mkNode k v l' r) + +maxView :: Tree v -> Maybe (v, Tree v) +maxView t = first snd <$> maxViewWithKey t + +maxViewWithKey :: Tree v -> Maybe ((Key, v), Tree v) +maxViewWithKey Empty = Nothing +maxViewWithKey x = Just $ go x + where + go t = case r of + Empty -> ((k, v), l) + _ -> substRight $ go r + where + (k, v, l, r) = unNode t + substRight (kv, r') = (kv, mkNode k v l r') + +{-# INLINE minView #-} +{-# INLINE maxView #-} +{-# INLINE minViewWithKey #-} +{-# INLINE maxViewWithKey #-} + +first :: (a -> c) -> (a, b) -> (c, b) +first f (x,y) = (f x,y) + +{-# INLINE first #-} + +-- ------------------------------------------------------------ + +unionWithKey :: (Key -> v -> v -> v) -> Tree v -> Tree v -> Tree v +intersectionWithKey :: (Key -> a -> b -> c) -> Tree a -> Tree b -> Tree c +differenceWithKey :: (Key -> a -> b -> Maybe a) -> Tree a -> Tree b -> Tree a + +-- {- +unionWithKey = unionWithKey' +intersectionWithKey = intersectionWithKey' +differenceWithKey = differenceWithKey' + +-- -} + +{- union, interect and diff operations with assertions + +unionWithKey op + = assertBin "unionWithKey" keys keys keys union'keys $ unionWithKey' op + where + union'keys x y = L.sort $ x `L.union` y + +differenceWithKey op + = assertBin "differenceWithKeys" keys keys keys diff'keys $ differenceWithKey' op + where + diff'keys x y = L.sort $ x L.\\ y + +intersectionWithKey op + = assertBin "intersectionWithKey" keys keys keys intersection'keys $ intersectionWithKey' op + where + intersection'keys x y = L.sort $ x `L.intersect` y + +assertBin :: (Eq r, Show r) => + String -> (a -> r) -> (b -> r) -> (c -> r) -> (r -> r -> r) -> + (a -> b -> c) -> (a -> b -> c) +assertBin opn retrX retrY retrR op' op x y + = assert msg' retrR res' res + where + res = x `op` y + res' = x' `op'` y' + x' = retrX x + y' = retrY y + msg' = unlines [ "operation: " ++ opn + , "arg1: " ++ show x' + , "arg2: " ++ show y' + ] + +assert :: (Eq r, Show r) => String -> (a -> r) -> r -> a -> a +assert args retr exp' res + | exp' == res' = res + | otherwise = error msg + where + res' = retr res + msg = unlines [ "assertion failed" + , args + , "expected: " ++ show exp' + , "got: " ++ show res' + ] +-- -} + +-- ------------------------------------------------------------ +{- + +main :: IO () +main = return () + +fromList' :: [Key] -> Tree String +fromList' = fromAscList . L.map (\ x -> (x, "")) +fromList'' :: [Key] -> Tree String +fromList'' = fromList . L.map (\ x -> (x, show $ x+1)) + +s1 :: Tree String +s1 = fromList' [2,4..10] +s2 :: Tree String +s2 = fromList' [1,3..10] +s3 :: Tree String +s3 = fromList'' [0,3..10] + + +arg1 = fromList' [-9019555248142772964,-6161526110399673733,-5962998868550245357,-5723094145863444326,-5358586818353638861,-4957792663758460317,-1038248931000888297,1160546946948583692,1945733972938829115,2251145106674145554,3000418586234587927,4084681012873670518,5287472037333007190,7296040159437125633,8079593536333253132,8492044343351169705] +arg2 = fromList' [-9019555248142772964,-6161526110399673733,-5358586818353638861,-4957792663758460317,-1038248931000888297,1160546946948583692,1945733972938829115,2251145106674145554,3000418586234587927,4084681012873670518,5287472037333007190,7296040159437125633,8079593536333253132,8492044343351169705] + +expected = fromList' [-9019555248142772964,-6161526110399673733,-5358586818353638861,-4957792663758460317,-1038248931000888297,1160546946948583692,1945733972938829115,2251145106674145554,3000418586234587927,4084681012873670518,5287472037333007190,7296040159437125633,8079593536333253132,8492044343351169705] +got = fromList' [-9019555248142772964,-6161526110399673733,-5358586818353638861,-4957792663758460317,-1038248931000888297] + + +-- -} + +-- ------------------------------------------------------------ diff --git a/src/Data/IntSet/Cache.hs b/src/Data/IntSet/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Data/IntSet/Cache.hs @@ -0,0 +1,42 @@ +-- ---------------------------------------------------------------------------- +{- | +A cache for single element 'IntSet's with elements 0 <= i < cacheSize (1024) +These single element sets occur very frequently in position sets +in occurrence maps, so sharing becomes available with this cache. + +Usage: substitute all singleton calls with @cacheAt@ calls +and all @fromList@ calls with @IS.unions . map cacheAt@. +-} +-- ---------------------------------------------------------------------------- + +module Data.IntSet.Cache + ( cache + , cacheAt + ) +where +import Control.DeepSeq + +import qualified Data.IntSet as S +import qualified Data.Vector as V + +-- ------------------------------------------------------------ + +-- | Size of the cache. +cacheSize :: Int +cacheSize = 1024 + +-- | Initialize the 'IntSet' cache. +cache :: V.Vector S.IntSet +cache = id $!! V.generate cacheSize S.singleton + +-- | A (cached) 'IntSet' singleton. +cacheAt :: Int -> S.IntSet +cacheAt i + | 0 <= i + && + i < cacheSize + = id $! cache V.! i + | otherwise + = id $! S.singleton i + +-- ------------------------------------------------------------ diff --git a/src/Data/LimitedPriorityQueue.hs b/src/Data/LimitedPriorityQueue.hs new file mode 100644 --- /dev/null +++ b/src/Data/LimitedPriorityQueue.hs @@ -0,0 +1,137 @@ +-- ---------------------------------------------------------------------------- + +{- | + Intermediate data structure for sorting and paging a result set + + When sorting a result set by priority and knowing how many + results are requested and which "page" of the result set + is requested, a priority queue with limited capacity can be used + for efficient sorting and paging. + +-} + +module Data.LimitedPriorityQueue + ( Queue + , mkQueue + , insert + , reduce + , toList + , fromList + , pageList + ) +where + +import Prelude hiding (drop, take) + +-- ---------------------------------------------------------------------------- + +data Queue v + = Q { _capacity :: !Int + , _size :: !Int + , _elems :: (Heap v) + } + deriving (Show) + +data Heap v + = E + | T v (Heap v) (Heap v) + deriving (Show) + +-- | Create an empty priority queue with a limited capacity. +-- If capacity is < 0, no limit is set + +mkQueue :: Int -> Queue v +mkQueue c + | c >= 0 + = Q c 0 E + | otherwise + = Q maxBound 0 E + +-- | Insert an element if there is space in the queue +-- or if the element is larger than the smallest element. + +insert :: Ord v => v -> Queue v -> Queue v +insert x q@(Q c s h) + | s < c -- capacity not reached: insert + = Q c (s + 1) (merge h (T x E E)) + | x' >= x -- queue full, score < min score: don't insert + = q + | otherwise -- queue full, score >= min: throw min away and insert + = Q c s (merge (merge l r) (T x E E)) + where + (T x' l r) = h + +-- | Reduce size and capacity of queue +-- by throwing away small elements. + +reduce :: Ord v => Int -> Queue v -> Queue v +reduce i (Q _ s h) + | i >= s + = Q i s h + | otherwise -- i < s + = Q i i (drop (s - i) h) + +toList :: Ord v => Int -> Int -> Queue v -> [v] +toList start len (Q _ s h) + | len < 0 -- no limit on the length, take all except the first elems + = take (s - start) h + | len' < s -- more elements in queue than needed, drop some elems + = take len $ drop (s - len') h + | otherwise -- less elements in queue, take them + = take (len - (len' - s)) h + where + len' = start + len + +fromList :: Ord v => Int -> [v] -> Queue v +fromList c + = foldl (\ q x -> insert x q) (mkQueue c) + +-- | Take a list of scored values, sort it and return a page of the result. +-- +-- @pageList 10 5 xs == take 5 . drop 10 . sortBy snd $ xs@ +-- +-- If the length is set to @-1@ no limit on the page length is set. + +pageList :: Ord v => Int -> Int -> [v] -> [v] +pageList start len + = toList start len . fromList len' + where + len' + | len >= 0 = start + len + | otherwise = len + +-- ---------------------------------------------------------------------------- +-- skew heap operations + +take :: Ord v => Int -> Heap v -> [v] +take i0 h0 + = take' i0 h0 [] + where + take' i (T x l r) acc + | i <= 0 + = acc + | otherwise + = take' (i - 1) (merge l r) (x : acc) + take' _ E acc + = acc + +drop :: Ord v => Int -> Heap v -> Heap v +drop i h + | i <= 0 + = h + | otherwise + = drop (i - 1) (merge l r) + where + (T _x l r) = h + +merge :: Ord v => Heap v -> Heap v -> Heap v +merge E q2 = q2 +merge q1 E = q1 +merge q1@(T x1 l1 r1) q2@(T x2 l2 r2) + | x1 <= x2 + = T x1 r1 (merge l1 q2) + | otherwise + = T x2 r2 (merge l2 q1) + +-- ---------------------------------------------------------------------------- + diff --git a/src/Data/Text/Binary.hs b/src/Data/Text/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Binary.hs @@ -0,0 +1,23 @@ +{-# OPTIONS -fno-warn-orphans #-} + +-- ---------------------------------------------------------------------------- +{- | +Default 'Binary' instance for 'Text' using UTF-8. +-} +-- ---------------------------------------------------------------------------- + +module Data.Text.Binary +where + +import Control.Monad (liftM) +import Data.Binary (Binary (..)) +import Data.Text +import Data.Text.Encoding + +-- ------------------------------------------------------------ + +instance Binary Text where + put = put . encodeUtf8 + get = liftM decodeUtf8 get + +-- ------------------------------------------------------------ diff --git a/src/Data/Typeable/Binary.hs b/src/Data/Typeable/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Data/Typeable/Binary.hs @@ -0,0 +1,28 @@ +{-# OPTIONS -fno-warn-orphans #-} + +-- ---------------------------------------------------------------------------- +{- | +'Binary' instance for 'TypeRep'. +-} +-- ---------------------------------------------------------------------------- + +module Data.Typeable.Binary where + +import Control.Applicative + +import Data.Binary +import Data.Typeable.Internal + +import GHC.Fingerprint.Binary () + +-- ------------------------------------------------------------ + +instance Binary TypeRep where + put (TypeRep fp tyCon ts) = put fp >> put tyCon >> put ts + get = TypeRep <$> get <*> get <*> get + +instance Binary TyCon where + put (TyCon hash package modul name) = put hash >> put package >> put modul >> put name + get = TyCon <$> get <*> get <*> get <*> get + +-- ------------------------------------------------------------ diff --git a/src/GHC/Fingerprint/Binary.hs b/src/GHC/Fingerprint/Binary.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Fingerprint/Binary.hs @@ -0,0 +1,23 @@ +{-# OPTIONS -fno-warn-orphans #-} + +-- ---------------------------------------------------------------------------- +{- | +'Binary' instance for 'Fingerprint'. +-} +-- ---------------------------------------------------------------------------- + +module GHC.Fingerprint.Binary where + +import Control.Applicative + +import Data.Binary + +import GHC.Fingerprint.Type + +-- ------------------------------------------------------------ + +instance Binary Fingerprint where + put (Fingerprint hi lo) = put hi >> put lo + get = Fingerprint <$> get <*> get + +-- ------------------------------------------------------------ diff --git a/src/GHC/Stats/Json.hs b/src/GHC/Stats/Json.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stats/Json.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -fno-warn-orphans #-} + +-- ---------------------------------------------------------------------------- +{- | +'ToJSON' instance for 'GCStats'. +-} +-- ---------------------------------------------------------------------------- + +module GHC.Stats.Json where + +import Data.Aeson + +import GHC.Stats + +-- ------------------------------------------------------------ + +instance ToJSON GCStats where + toJSON o = object + [ "bytesAllocated" .= bytesAllocated o + , "numGcs" .= numGcs o + , "maxBytesUsed" .= maxBytesUsed o + , "numByteUsageSamples" .= numByteUsageSamples o + , "cumulativeBytesUsed" .= cumulativeBytesUsed o + , "bytesCopied" .= bytesCopied o + , "currentBytesUsed" .= currentBytesUsed o + , "currentBytesSlop" .= currentBytesSlop o + , "maxBytesSlop" .= maxBytesSlop o + , "peakMegabytesAllocated" .= peakMegabytesAllocated o + , "mutatorCpuSeconds" .= mutatorCpuSeconds o + , "mutatorWallSeconds" .= mutatorWallSeconds o + , "gcCpuSeconds" .= gcCpuSeconds o + , "gcWallSeconds" .= gcWallSeconds o + , "cpuSeconds" .= cpuSeconds o + , "wallSeconds" .= wallSeconds o + , "parTotBytesCopied" .= parTotBytesCopied o + , "parMaxBytesCopied" .= parMaxBytesCopied o + ] + +-- ------------------------------------------------------------ diff --git a/src/Hunt/ClientInterface.hs b/src/Hunt/ClientInterface.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/ClientInterface.hs @@ -0,0 +1,520 @@ +{- | + Module : Hunt.ClientInterface + License : MIT + + Maintainer : Uwe Schmidt + Stability : experimental + Portability: none portable + + Common data types and and smart constructors + for calling a hunt server from a client. + + Values of the Command datatype and its component types, e.g + Query, ApiDocument, and others + can be constructed with the "smart" construtors + defined in this module + + The module is intended to be imported qualified, + eg like @import qualified Hunt.ClientInterface as HI@. + +-} + +-- ---------------------------------------------------------------------------- + +module Hunt.ClientInterface + ( + -- * types used in commands + Command + , ApiDocument(..) -- also used in results + , Huntable(..) + , Content + , Context + , ContextSchema + , Description + , IndexMap + , RegEx + , StatusCmd + , URI + , Weight + + -- * types used in results + , CmdError(..) + , CmdRes(..) + , CmdResult(..) + , LimitedResult(..) + , Score + + -- * command construction + , cmdSearch + , cmdCompletion + , cmdSelect + , cmdInsertDoc + , cmdUpdateDoc + , cmdDeleteDoc + , cmdDeleteDocsByQuery + , cmdLoadIndex + , cmdStoreIndex + , cmdInsertContext + , cmdDeleteContext + , cmdStatus + , cmdSequence + , cmdNOOP + + -- ** configuration options for search and completion + , setSelectedFields + , setMaxResults + , setResultOffset + , setWeightIncluded + + -- ** Misc + , createContextCommands + + + -- * ApiDocument construction, configuration and access + , mkApiDoc + , setDescription + , getDescription + , addDescription + , remDescription + , changeDescription + , lookupDescription + , lookupDescriptionText + , setIndex + , addToIndex + , getFromIndex + , changeIndex + , setDocWeight + + -- ** Misc + , listToApiDoc + , insertCmdsToDocuments + + -- ** description construction + , mkDescription + , mapToDescr + , insDescription + , emptyDescription + , fromDescription + + -- * Queries + , Query + -- ** query parsing + , parseQuery + -- ** query construction + , module Hunt.Query.Language.Builder + + + -- ** pretty printing + , printQuery + + -- ** query completion + , completeQueries + + -- * schema definition + , mkSchema + , setCxNoDefault + , setCxWeight + , setCxRegEx + , setCxUpperCase + , setCxLowerCase + , setCxZeroFill + , setCxText + , setCxInt + , setCxDate + , setCxPosition + + -- * Weights and Scores + , noScore + , defScore + , mkScore + , getScore + +-- -- * Output to server and file +-- , sendCmdToServer + , sendCmdToFile +-- , defaultServer + ) +where + +import Control.Applicative ((<$>)) +import Data.Aeson (FromJSON (..), ToJSON (..), Value(..)) +import Data.Default +import Data.List (nub) +import qualified Data.Map.Strict as SM +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified Data.Text as T + +import Hunt.Common.ApiDocument (ApiDocument (..), IndexMap, + LimitedResult (..), + emptyApiDocDescr, + emptyApiDocIndexMap) +import Hunt.Common.BasicTypes (Content, Context, Description, + RegEx, Score, URI, Weight, + defScore, getScore, mkScore, + noScore) +import qualified Hunt.Common.DocDesc as DD +import Hunt.Index.Schema +import Hunt.Interpreter.Command +import Hunt.Query.Language.Builder +import Hunt.Query.Language.Grammar +import Hunt.Query.Language.Parser (parseQuery) +import Hunt.Utility.Output (outputValue) + +-- ------------------------------------------------------------ +-- lookup commands + +class Huntable x where + huntURI :: x -> URI + + huntIndexMap :: x -> IndexMap + huntIndexMap _ = emptyApiDocIndexMap + + huntDescr :: x -> Description + huntDescr _ = emptyApiDocDescr + + toApiDocument :: x -> ApiDocument + toApiDocument x = setDescription (huntDescr x) $ + setIndex (huntIndexMap x) $ + mkApiDoc $ (huntURI x) + + +-- | create simple search command + +cmdSearch :: Query -> Command +cmdSearch q + = Search { icQuery = q + , icOffsetSR = 0 + , icMaxSR = (-1) -- unlimited + , icWeight = False + , icFields = Nothing + } + +-- | Create simple completion command + +cmdCompletion :: Query -> Command +cmdCompletion q + = Completion { icPrefixCR = q + , icMaxCR = (-1) -- unlimited + } + +cmdSelect :: Query -> Command +cmdSelect = Select + +-- ------------------------------------------------------------ +-- modifying commands + +-- | insert document + +cmdInsertDoc :: ApiDocument -> Command +cmdInsertDoc = Insert + +-- | update document + +cmdUpdateDoc :: ApiDocument -> Command +cmdUpdateDoc = Update + +-- | delete document identified by an URI + +cmdDeleteDoc :: URI -> Command +cmdDeleteDoc = Delete + +-- | delete all documents idenitfied by a query + +cmdDeleteDocsByQuery :: Query -> Command +cmdDeleteDocsByQuery = DeleteByQuery + +-- ------------------------------------------------------------ +-- index schema manipulation + +cmdInsertContext :: Context -> ContextSchema -> Command +cmdInsertContext cx sc + = InsertContext { icIContext = cx + , icSchema = sc + } + +cmdDeleteContext :: Context -> Command +cmdDeleteContext cx + = DeleteContext { icDContext = cx } + +-- ------------------------------------------------------------ +-- index persistance + +cmdLoadIndex :: FilePath -> Command +cmdLoadIndex = LoadIx + +cmdStoreIndex :: FilePath -> Command +cmdStoreIndex = StoreIx + +-- ------------------------------------------------------------ +-- status and control commands + +cmdStatus :: StatusCmd -> Command +cmdStatus = Status + +cmdSequence :: [Command] -> Command +cmdSequence [] = cmdNOOP +cmdSequence [c] = c +cmdSequence cs = Sequence cs + +cmdNOOP :: Command +cmdNOOP = NOOP + +-- ------------------------------------------------------------ + +-- | configure search and completion command: set the max # of results + +setMaxResults :: Int -> Command -> Command +setMaxResults mx q@Search{} + = q { icMaxSR = mx } +setMaxResults mx q@Completion{} + = q { icMaxCR = mx } +setMaxResults _ q + = q + +-- | configure search command: set the starting offset of the result list +setResultOffset :: Int -> Command -> Command +setResultOffset off q@Search{} + = q { icOffsetSR = off } +setResultOffset _ q + = q + +-- | configure search command: set the list of attributes of the document decription +-- to be included in the result list +-- +-- example: @setSelectedFields ["title", "date"]@ restricts the documents +-- attributes to these to fields + +setSelectedFields :: [Text] -> Command -> Command +setSelectedFields fs q@Search{} + = q { icFields = Just fs } + +setSelectedFields _ q + = q + +-- | configure search command: include document weight in result list + +setWeightIncluded :: Command -> Command +setWeightIncluded q@Search{} + = q { icWeight = True } +setWeightIncluded q + = q + + +-- | create InsertContext Commands by a list of Insert Commands +-- These contexts are not optimized and shoudn't be used in production code. +createContextCommands :: [ApiDocument] -> Command +createContextCommands docs = cmdSequence cmds + where + names = nub $ docs >>= (LM.keys . adIndex) + cmds = (\name -> cmdInsertContext name mkSchema) <$> names +-- ------------------------------------------------------------ + +-- | build an api document with an uri as key and a description +-- map as contents + +mkApiDoc :: URI -> ApiDocument +mkApiDoc u + = ApiDocument + { adUri = u + , adIndex = emptyApiDocIndexMap + , adDescr = emptyApiDocDescr + , adWght = noScore + } + +-- | add an index map containing the text parts to be indexed + +setDescription :: Description -> ApiDocument -> ApiDocument +setDescription descr d + = d { adDescr = descr } + +getDescription :: ApiDocument -> Description +getDescription = adDescr + +lookupDescription :: FromJSON v => Text -> ApiDocument -> Maybe v +lookupDescription k + = DD.lookup k . adDescr + +lookupDescriptionText :: Text -> ApiDocument -> Text +lookupDescriptionText k + = DD.lookupText k . adDescr + +addDescription :: ToJSON v => Text -> v -> ApiDocument -> ApiDocument +addDescription k v + = changeDescription $ DD.insert k v + +remDescription :: Text -> ApiDocument -> ApiDocument +remDescription k + = changeDescription $ DD.delete k + +changeDescription :: (Description -> Description) -> ApiDocument -> ApiDocument +changeDescription f a = a { adDescr = f . adDescr $ a } + +-- | add an index map containing the text parts to be indexed + +setIndex :: IndexMap -> ApiDocument -> ApiDocument +setIndex im d + = d { adIndex = im } + +addToIndex :: Context -> Content -> ApiDocument -> ApiDocument +addToIndex cx ct d + | T.null ct = d + | otherwise = changeIndex (SM.insert cx ct) d + +getFromIndex :: Context -> ApiDocument -> Text +getFromIndex cx d + = maybe "" id . SM.lookup cx . adIndex $ d + +changeIndex :: (IndexMap -> IndexMap) -> ApiDocument -> ApiDocument +changeIndex f a = a { adIndex = f $ adIndex a } + +-- | add a document weight + +setDocWeight :: Score -> ApiDocument -> ApiDocument +setDocWeight w d + = d { adWght = w } + +-- | wrapper for building an ApiDocument by lists +listToApiDoc + :: Text -- ^ The uri + -> [(Text, Text)] -- ^ The index + -> [(Text, Text)] -- ^ The description + -> ApiDocument +listToApiDoc uri k v = setDescription (mkDescription v) $ setIndex (LM.fromList k) $ mkApiDoc $ uri + + +-- ------------------------------------------------------------ +-- document description + +-- build a document description from a list of key-value pairs with +-- simple text values + +mkDescription :: [(Text, Text)] -> Description +mkDescription + = DD.fromList . filter (not . T.null . snd) + +mapToDescr :: LM.Map Text Text -> DD.DocDesc +mapToDescr src = mkDescription $ LM.toList src + +-- insert a key-value pair with an arbitrary value into +-- a document description + +insDescription :: ToJSON v => Text -> v -> Description -> Description +insDescription + = DD.insert + +emptyDescription :: Description +emptyDescription = DD.empty + +fromDescription :: Description -> [(Text, Value)] +fromDescription = DD.toList + +insertCmdsToDocuments :: Command -> [ApiDocument] +insertCmdsToDocuments (Insert d) = [d] +insertCmdsToDocuments (Sequence cs) = cs >>= insertCmdsToDocuments +insertCmdsToDocuments _ = [] + +-- ------------------------------------------------------------ + + + + +-- ------------------------------------------------------------ +-- context schema construction + +-- | the default schema: context type is text, no normalizers, +-- weigth is 1.0, context is always searched by queries without context spec + +mkSchema :: ContextSchema +mkSchema = def + +-- | prevent searching in context, when not explicitly set in query + +setCxNoDefault :: ContextSchema -> ContextSchema +setCxNoDefault sc + = sc { cxDefault = False } + +-- | set the regex for splitting a text into words + +setCxWeight :: Float -> ContextSchema -> ContextSchema +setCxWeight w sc + = sc { cxWeight = mkScore w } + +-- | set the regex for splitting a text into words + +setCxRegEx :: RegEx -> ContextSchema -> ContextSchema +setCxRegEx re sc + = sc { cxRegEx = Just re } + +-- | add a text normalizer for transformation into uppercase + +setCxUpperCase :: ContextSchema -> ContextSchema +setCxUpperCase sc + = sc { cxNormalizer = cnUpperCase : cxNormalizer sc } + +-- | add a text normalizer for transformation into lowercase + +setCxLowerCase :: ContextSchema -> ContextSchema +setCxLowerCase sc + = sc { cxNormalizer = cnLowerCase : cxNormalizer sc } + +-- | add a text normalizer for transformation into lowercase + +setCxZeroFill :: ContextSchema -> ContextSchema +setCxZeroFill sc + = sc { cxNormalizer = cnZeroFill : cxNormalizer sc } + +-- | set the type of a context to text + +setCxText :: ContextSchema -> ContextSchema +setCxText sc + = sc { cxType = ctText } + +-- | set the type of a context to Int + +setCxInt :: ContextSchema -> ContextSchema +setCxInt sc + = sc { cxType = ctInt } + +-- | set the type of a context to Date + +setCxDate :: ContextSchema -> ContextSchema +setCxDate sc + = sc { cxType = ctDate } + +-- | set the type of a context to Int + +setCxPosition :: ContextSchema -> ContextSchema +setCxPosition sc + = sc { cxType = ctPosition } + +-- ------------------------------------------------------------ + +completeQueries :: Query -> [Text] -> [Query] +completeQueries (QWord t _) comps = (\c -> QWord t (c)) <$> comps +completeQueries (QFullWord t _) comps = (\c -> QFullWord t (c))<$> comps +completeQueries (QPhrase t _) comps = (\c -> QPhrase t (c)) <$> comps +completeQueries (QContext cxs q) comps = (QContext cxs) <$> (completeQueries q comps) +completeQueries (QBinary op q1 q2) comps = (QBinary op q1) <$> (completeQueries q2 comps) +completeQueries (QSeq op qs) comps = (QSeq op) <$> (completeLast qs) + where + completeLast [] = [] + completeLast [q] = sequence [completeQueries q comps] + completeLast (q:qs') = (q :) <$> completeLast qs' +completeQueries (QBoost w q) comps = (QBoost w) <$> (completeQueries q comps) +completeQueries (QRange t1 t2) _ = [QRange t1 t2] -- TODO + +-- ------------------------------------------------------------ + +-- client output + +-- | send command as JSON into a file +-- +-- the JSON is pretty printed with aeson-pretty, +-- @""@ and @"-"@ are used for output to stdout + +sendCmdToFile :: String -> Command -> IO () +sendCmdToFile fn cmd + = outputValue fn cmd + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Common.hs b/src/Hunt/Common.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Common.hs @@ -0,0 +1,39 @@ +{- | + Module : Hunt.Index.Common + License : MIT + + Maintainer : Ulf Sauer + Stability : experimental + Portability: none portable + + Common data types shared by all index types and a unified interface for + all different index types. This module defines the common interfaces of + indexes and their document tables as well as full-text caches. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Common + ( + module Hunt.Common.BasicTypes + , module Hunt.Common.DocId + , module Hunt.Common.DocIdMap + , module Hunt.Common.DocIdSet + , module Hunt.Common.Document + , module Hunt.Common.Occurrences + , module Hunt.Common.Positions + , module Hunt.Common.RawResult + , module Hunt.Common.ApiDocument + , module Hunt.Index.Schema + ) +where + +import Hunt.Common.ApiDocument (ApiDocument (..)) +import Hunt.Common.BasicTypes +import Hunt.Common.DocId +import Hunt.Common.DocIdMap (DocIdMap) +import Hunt.Common.DocIdSet (DocIdSet) +import Hunt.Common.Document (Document (..)) +import Hunt.Common.Occurrences (Occurrences) +import Hunt.Common.Positions (Positions) +import Hunt.Common.RawResult +import Hunt.Index.Schema diff --git a/src/Hunt/Common/ApiDocument.hs b/src/Hunt/Common/ApiDocument.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Common/ApiDocument.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- ---------------------------------------------------------------------------- + +{- | + Document format for the interpreter and JSON API. + It includes the document description, the index data and additional metadata. +-} + +-- ---------------------------------------------------------------------------- + +module Hunt.Common.ApiDocument where + +import Control.Applicative +import Control.DeepSeq +import Control.Monad (mzero) + +import Data.Aeson +import Data.Binary (Binary (..)) +import Data.Map.Strict (Map ()) +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Binary () + +import Hunt.Common.BasicTypes +import qualified Hunt.Common.DocDesc as DD + +import Hunt.Utility.Log + +-- ------------------------------------------------------------ + +-- | The document accepted by the interpreter and JSON API. + +data ApiDocument = ApiDocument + { adUri :: URI -- ^ The unique identifier. + , adIndex :: IndexMap -- ^ The data to index according to schema associated with the context. + , adDescr :: Description -- ^ The document description (a simple key-value map). + , adWght :: Score -- ^ An optional document boost, (internal default is @1.0@). + } + deriving (Show) + +-- | Context map +type IndexMap = Map Context Content + +-- | Multiple 'ApiDocument's. +type ApiDocuments = [ApiDocument] + +-- | Text analysis function +type AnalyzerFunction = Text -> [(Position, Text)] + +-- | Types of analyzer +data AnalyzerType = DefaultAnalyzer + deriving (Show) + + +-- | Paginated result with an offset and chunk size. +data LimitedResult x = LimitedResult + { lrResult :: [x] -- ^ The list with at most 'lrMax' elements. + , lrOffset :: Int -- ^ The offset of the result. + , lrMax :: Int -- ^ The limit for the result. + , lrCount :: Int -- ^ The size of the complete result. + } + deriving (Show, Eq) + +instance NFData x => NFData (LimitedResult x) where + rnf (LimitedResult r o m c) = r `seq` o `seq` m `seq` c `seq` () + +-- ------------------------------------------------------------ + +-- | Create a paginated result with an offset and a chunk size. +-- The result also includes the size of the complete result. + +mkLimitedResult :: Int -> Int -> [x] -> LimitedResult x +mkLimitedResult offset mx xs = LimitedResult + { lrResult = ( if mx < 0 + then id + else take mx + ) . drop offset $ xs + , lrOffset = offset + , lrMax = mx + , lrCount = length xs + } + + +-- | Empty index content. +emptyApiDocIndexMap :: IndexMap +emptyApiDocIndexMap = M.empty + +-- | Empty 'Document' description. +emptyApiDocDescr :: Description +emptyApiDocDescr = DD.empty + +-- | Empty 'ApiDocument'. +emptyApiDoc :: ApiDocument +emptyApiDoc = ApiDocument "" emptyApiDocIndexMap emptyApiDocDescr noScore + +-- ------------------------------------------------------------ + +instance NFData ApiDocument where + --default + +-- ------------------------------------------------------------ + +instance Binary ApiDocument where + put (ApiDocument a b c d) + = put a >> put b >> put c >> put d + get = ApiDocument <$> get <*> get <*> get <*> get + +-- ------------------------------------------------------------ + +instance LogShow ApiDocument where + logShow o = "ApiDocument {adUri = \"" ++ (T.unpack . adUri $ o) ++ "\", ..}" + +-- ------------------------------------------------------------ +-- JSON instances +-- ------------------------------------------------------------ + +instance (ToJSON x) => ToJSON (LimitedResult x) where + toJSON (LimitedResult res offset mx cnt) = object + [ "result" .= res + , "offset" .= offset + , "max" .= mx + , "count" .= cnt + ] + +instance (FromJSON x) => FromJSON (LimitedResult x) where + parseJSON (Object v) = do + res <- v .: "result" + offset <- v .: "offset" + mx <- v .: "max" + cnt <- v .: "count" + return $ LimitedResult res offset mx cnt + parseJSON _ = mzero + +instance FromJSON ApiDocument where + parseJSON (Object o) = do + parsedUri <- o .: "uri" + indexMap <- o .:? "index" .!= emptyApiDocIndexMap + descrMap <- o .:? "description" .!= emptyApiDocDescr + weight <- mkScore <$> + o .:? "weight" .!= 0.0 + return ApiDocument + { adUri = parsedUri + , adIndex = indexMap + , adDescr = descrMap + , adWght = weight + } + parseJSON _ = mzero + +instance ToJSON ApiDocument where + toJSON (ApiDocument u im dm wt) + = object $ + ( maybe [] (\ x -> ["weight" .= x]) $ getScore wt ) + ++ + ( if M.null im + then [] + else ["index" .= im] + ) + ++ + ( if DD.null dm + then [] + else ["description" .= dm] + ) + ++ + ["uri" .= u] + +instance FromJSON AnalyzerType where + parseJSON (String s) = + case s of + "default" -> return DefaultAnalyzer + _ -> mzero + parseJSON _ = mzero + +instance ToJSON AnalyzerType where + toJSON (DefaultAnalyzer) = + "default" + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Common/BasicTypes.hs b/src/Hunt/Common/BasicTypes.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Common/BasicTypes.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +-- ---------------------------------------------------------------------------- + +{- | + Common types used within Hunt. +-} + +-- ---------------------------------------------------------------------------- + +module Hunt.Common.BasicTypes + ( module Hunt.Common.BasicTypes + , Monoid(..) + , (<>) + ) +where + +import Control.Applicative +import Control.Monad (mzero) +import Control.DeepSeq + +import Data.Aeson +import Data.Binary hiding (Word) +import Data.Map +import Data.Monoid (Monoid (..), (<>)) +import Data.Text + +import Hunt.Common.DocDesc (DocDesc) + +import Prelude as P + +-- ------------------------------------------------------------ + +-- | The URI describing the location of the original document. +type URI = Text + +-- | The description of a document is a generic key value map. +type Description = DocDesc + +-- | The title of a document. +type Title = Text + +-- | The content of a document. +type Content = Text + +-- | The position of a word in the document. +type Position = Int + +-- | The name of a context. +type Context = Text + +-- | A single word. +type Word = Text + +-- | Positions of Words for each context. +type Words = Map Context WordList + +-- | Positions of words in the document. +type WordList = Map Word [Position] + +-- | Text index +data TextSearchOp = Case | NoCase | PrefixCase | PrefixNoCase + deriving (Eq, Show) + +-- | Weight (for ranking). +type Weight = Score + +-- | Regular expression. +type RegEx = Text + +-- | The score of a hit (either a document hit or a word hit). +-- type Score = Float + +-- ------------------------------------------------------------ + +-- | Weight or score of a documents, +-- @0.0@ indicates: not set, so there is no need to work with Maybe's +-- wrapped in newtype to not mix up with Score's and Weight's in documents + +newtype Score = SC {unScore :: Float} + deriving (Eq, Ord, Num, Fractional, Show) + +instance NFData Score where + rnf (SC f) = f `seq` () + +noScore :: Score +noScore = SC 0.0 + +mkScore :: Float -> Score +mkScore x + | x > 0.0 = SC x + | otherwise = noScore + +getScore :: Score -> Maybe Float +getScore (SC 0.0) = Nothing +getScore (SC x ) = Just x + +defScore :: Score +defScore = SC 1.0 + +toDefScore :: Score -> Score +toDefScore (SC 0.0) = defScore +toDefScore sc = sc + +fromDefScore :: Score -> Score +fromDefScore (SC 1.0) = noScore +fromDefScore sc = sc + +accScore :: [Score] -> Score +accScore [] = defScore +accScore xs = mkScore $ sum (P.map unScore xs) / fromIntegral (P.length xs) + +-- the Monoid instance is used to accumulate scores +-- in query results, so tune it here when sum is not appropriate + +instance Monoid Score where + mempty = noScore + mappend = (+) + +-- ------------------------------------------------------------ +-- JSON instances +-- ------------------------------------------------------------ + +instance FromJSON Score where + parseJSON x = mkScore <$> parseJSON x + +instance ToJSON Score where + toJSON (SC x) = toJSON x + +instance FromJSON TextSearchOp where + parseJSON (String s) + = case s of + "case" -> return Case + "noCase" -> return NoCase + "prefixCase" -> return PrefixCase + "prefixNoCase" -> return PrefixNoCase + _ -> mzero + parseJSON _ = mzero + +instance ToJSON TextSearchOp where + toJSON o = case o of + Case -> "case" + NoCase -> "noCase" + PrefixCase -> "prefixCase" + PrefixNoCase -> "prefixNoCase" + +-- ------------------------------------------------------------ +-- Binary instances +-- ------------------------------------------------------------ + +instance Binary Score where + put (SC x) = put x + get = SC <$> get + +instance Binary TextSearchOp where + put (Case) = put (0 :: Word8) + put (NoCase) = put (1 :: Word8) + put (PrefixCase) = put (2 :: Word8) + put (PrefixNoCase) = put (3 :: Word8) + + get = do + t <- get :: Get Word8 + case t of + 0 -> return Case + 1 -> return NoCase + 2 -> return PrefixCase + 3 -> return PrefixNoCase + _ -> fail "enum out of bounds: TextSearchOp" + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Common/DocDesc.hs b/src/Hunt/Common/DocDesc.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Common/DocDesc.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Hunt.Common.DocDesc +where + +import Prelude hiding (lookup) + +import Control.Arrow (second) +import Control.DeepSeq +import Control.Monad (mzero) + +import Data.Aeson (FromJSON (..), Object, Result (..), + ToJSON (..), Value (..), decode, encode, + fromJSON) +import Data.Binary (Binary (..)) +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text.Binary () +import Data.Typeable + +-- ------------------------------------------------------------ +-- {- the new DocDesc with JSON values as attributes + +newtype DocDesc + = DocDesc { unDesc :: Object } + deriving (Eq, Show, NFData, Typeable) + +-- | Smart constructor for document descriptions. + +mkDocDesc :: Object -> DocDesc +mkDocDesc o + = DocDesc $!! o + +instance Binary DocDesc where + put = put . encode . unDesc + get = do bs <- get + case decode bs of + Nothing -> fail "DocDesc.get: error in decoding from JSON" + Just x -> return $! (mkDocDesc x) + +instance ToJSON DocDesc where + toJSON = Object . unDesc + +instance FromJSON DocDesc where + parseJSON (Object o) = return $! (mkDocDesc o) + parseJSON _ = mzero + +-- | The empty description. + +empty :: DocDesc +empty = mkDocDesc HM.empty + +-- | Check if document description is empty. + +null :: DocDesc -> Bool +null (DocDesc m) = HM.null m + +-- | Insert key value pair into description. + +insert :: ToJSON v => Text -> v -> DocDesc -> DocDesc +insert k v (DocDesc m) + = mkDocDesc $ HM.insert k (toJSON v) m + +-- | Remove a key value pair + +delete :: Text -> DocDesc -> DocDesc +delete k (DocDesc m) + = mkDocDesc $ HM.delete k m + +-- | Union of two descriptions. + +union :: DocDesc -> DocDesc -> DocDesc +union (DocDesc m1) (DocDesc m2) + = mkDocDesc $ HM.union m1 m2 + +-- | restrict a DocDesc map to a set of fields + +restrict :: [Text] -> DocDesc -> DocDesc +restrict ks (DocDesc m) + = mkDocDesc $ HM.filterWithKey sel m + where + sel k _v = k `elem` ks + +deleteNull :: DocDesc -> DocDesc +deleteNull (DocDesc m) + = mkDocDesc $ HM.filter notNull m + where + notNull Null = False + notNull _ = True + +lookupValue :: Text -> DocDesc -> Value +lookupValue k (DocDesc m) + = fromMaybe Null $ HM.lookup k m + +lookup :: FromJSON v => Text -> DocDesc -> Maybe v +lookup k d + = toMaybe . fromJSON . lookupValue k $ d + where + toMaybe (Success v) = Just v + toMaybe _ = Nothing + +lookupText :: Text -> DocDesc -> Text +lookupText k d + = fromMaybe "" . lookup k $ d + +-- | Create a document description from as list + +fromList :: ToJSON v => [(Text, v)] -> DocDesc +fromList l = mkDocDesc $ HM.fromList (map (second toJSON) l) + +-- | Create a list from a document description. + +toList :: DocDesc -> [(Text, Value)] +toList (DocDesc m) = HM.toList m + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Common/DocId.hs b/src/Hunt/Common/DocId.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Common/DocId.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Hunt.Index.Common.DocId + Copyright : Copyright (C) 2014 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + + The document identifier type DocId and the newtype DocId' with Show and ToJSOn instances +-} + +-- ---------------------------------------------------------------------------- + +module Hunt.Common.DocId +where + +import Control.Applicative + +import Data.Aeson +import Data.Binary (Binary (..)) +import qualified Data.Binary as B +import Data.Digest.Murmur64 + +-- ------------------------------------------------------------ +{- +-- | The unique identifier of a document. +type DocId = Int + +-- ------------------------------------------------------------ + +-- | Create the null-identifier. +mkNull :: DocId +mkNull = 0 + +-- | Create the first identifier. +mkFirst :: DocId +mkFirst = 1 + +-- | Create a 'DocId' from an 'Integer'. +fromInteger :: Integer -> DocId +fromInteger = fromIntegral + +-- ------------------------------------------------------------ + +{-# INLINE mkNull #-} +{-# INLINE mkFirst #-} +{-# INLINE fromInteger #-} + +-- -} +-- ------------------------------------------------------------ + +-- the wrapped DocId +-- currently only used for JSON debug output + +newtype DocId = DocId {unDocId :: Int} + deriving (Eq, Ord) + +instance Show DocId where + show = toHex . unDocId + +instance Binary DocId where + put = put . unDocId + get = DocId <$> get + +instance ToJSON DocId where + toJSON (DocId i) = toJSON $ toHex i + +mkDocId :: Binary a => a -> DocId +mkDocId = DocId . fromIntegral . asWord64 . hash64 . B.encode + +toHex :: Int -> String +toHex !y = "0x" ++ toX 16 "" y + where + toX :: Int -> String -> Int -> String + toX !0 !acc _ = acc + toX !n !acc x = toX (n - 1) (d : acc) x' + where + (!x', !r) = x `divMod` 16 + !d | r < 10 = toEnum (fromEnum '0' + r) + | otherwise = toEnum (fromEnum 'a' + r - 10) + +fromHex :: String -> Maybe Int +fromHex i@('0' : 'x' : xs) + | length xs == 16 + && + all (`elem` "0123456789abcdef") xs + = Just . read $ i + | otherwise + = Nothing + +fromHex _ + = Nothing + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Common/DocIdMap.hs b/src/Hunt/Common/DocIdMap.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Common/DocIdMap.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Hunt.Index.Common.DocIdMap + Copyright : Copyright (C) 2012 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt + License : MIT + Maintainer : Uwe Schmidt + + Efficient Map implementation for 'DocId's. +-} + +-- ---------------------------------------------------------------------------- + +module Hunt.Common.DocIdMap + ( DocIdMap(..) + , empty + , singleton + , null + , member + , lookup + , insert + , delete + , insertWith + , size + , sizeWithLimit + , union + , intersection + , difference + , diffWithSet + , unionWith + , intersectionWith + , differenceWith + , unionsWith + , map + , filter + , filterWithKey + , mapWithKey + , traverseWithKey + , foldr + , foldrWithKey + , foldl + , fromList + , fromDocIdSet + , fromAscList + , toList + , keys + , elems + ) +where + +import Prelude hiding (filter, foldl, foldr, + lookup, map, null) +import qualified Prelude as P + +import Control.Applicative (Applicative (..), (<$>)) +import Control.Arrow (first) +import Control.DeepSeq +import Control.Monad (foldM, mzero) + +import Data.Aeson +import Data.Binary (Binary (..)) +import Data.Foldable hiding (fold, foldl, foldr, toList) +import qualified Data.HashMap.Strict as HM +import qualified Data.IntMap.BinTree.Strict as IM +import qualified Data.List as L +import Data.Monoid (Monoid (..), (<>)) +import qualified Data.Text as T +import Data.Typeable + +import Hunt.Common.DocId +import Hunt.Common.DocIdSet (DocIdSet (..), toIntSet) + +-- ------------------------------------------------------------ + +-- | An efficient Map implementation for 'DocId's. + +newtype DocIdMap v + = DIM { unDIM :: IM.IntMap v } + deriving (Eq, Show, Foldable, {-Traversable,-} Functor, NFData, Typeable) + +-- ------------------------------------------------------------ + +instance Monoid v => Monoid (DocIdMap v) where + mempty = DIM IM.empty + mappend = unionWith (<>) + +instance Binary v => Binary (DocIdMap v) where + put = put . unDIM + get = get >>= return . DIM + +instance ToJSON v => ToJSON (DocIdMap v) where + toJSON = object . L.map toJ . IM.toList . unDIM + where + toJ (k, v) = (T.pack . toHex $ k) .= toJSON v + +instance FromJSON v => FromJSON (DocIdMap v) where + parseJSON (Object o) = DIM <$> foldM parsePair IM.empty (HM.toList o) + where + parsePair res (k, v) + = case fromHex . T.unpack $ k of + Nothing -> mzero + Just k' -> do + v' <- parseJSON v + return $ IM.insert k' v' res + + parseJSON _ = mzero + +-- ------------------------------------------------------------ + +liftDIM :: (IM.IntMap v -> IM.IntMap r) -> + DocIdMap v -> DocIdMap r +liftDIM f = DIM . f . unDIM + +liftDIM2 :: (IM.IntMap v -> IM.IntMap w -> IM.IntMap x) -> + DocIdMap v -> DocIdMap w -> DocIdMap x +liftDIM2 f x y = DIM $ f (unDIM x) (unDIM y) + +-- | The empty map. +empty :: DocIdMap v +empty = DIM $ IM.empty + +-- | A map with a single element. +singleton :: DocId -> v -> DocIdMap v +singleton d v = insert d v empty + +-- | Is the map empty? +null :: DocIdMap v -> Bool +null = IM.null . unDIM + +-- | Is the 'DocId' member of the map? +member :: DocId -> DocIdMap v -> Bool +member x = IM.member (unDocId x) . unDIM + +-- | Lookup the value at a 'DocId' in the map. + +-- The function will return the corresponding value as @('Just' value)@, +-- or 'Nothing' if the 'DocId' isn't in the map. +lookup :: DocId -> DocIdMap v -> Maybe v +lookup x = IM.lookup (unDocId x) . unDIM + +-- | Insert a 'DocId' and value in the map. +-- If the 'DocId' is already present in the map, the associated value is replaced with the supplied +-- value. 'insert' is equivalent to 'insertWith' 'const'. +insert :: DocId -> v -> DocIdMap v -> DocIdMap v +insert x y = liftDIM $ IM.insert (unDocId x) y + +-- | Delete a 'DocId' and its value from the map. +-- When the 'DocId' is not a member of the map, the original map is returned. +delete :: DocId -> DocIdMap v -> DocIdMap v +delete x = liftDIM $ IM.delete (unDocId x) + +-- | Insert with a function, combining new value and old value. +-- @insertWith f docId value mp@ will insert the pair @(docId, value)@ into @mp@ if @docId@ does +-- not exist in the map. If the 'DocId' does exist, the function will insert the pair +-- @(docId, f new_value old_value)@. +insertWith :: (v -> v -> v) -> DocId -> v -> DocIdMap v -> DocIdMap v +insertWith f x y = liftDIM $ IM.insertWith f (unDocId x) y + +-- | The number of elements in the map. +size :: DocIdMap v -> Int +size = IM.size . unDIM + +-- | The number of elements limited up to a maximum +sizeWithLimit :: Int -> DocIdMap v -> Maybe Int +sizeWithLimit limit = IM.sizeWithLimit limit . unDIM + +-- | The (left-biased) union of two maps. +-- It prefers the first map when duplicate 'DocId' are encountered, +-- i.e. @(union == unionWith const)@. +union :: DocIdMap v -> DocIdMap v -> DocIdMap v +union = liftDIM2 $ IM.union + +-- | The (left-biased) intersection of two maps (based on 'DocId's). +intersection :: DocIdMap v -> DocIdMap v -> DocIdMap v +intersection = liftDIM2 $ IM.intersection + +-- | Difference between two maps (based on 'DocId's). +difference :: DocIdMap v -> DocIdMap w -> DocIdMap v +difference = liftDIM2 $ IM.difference + +-- | Difference between the map and a set of 'DocId's. +diffWithSet :: DocIdMap v -> DocIdSet -> DocIdMap v +diffWithSet m s = m `difference` (DIM $ IM.fromSet (const ()) (unDIS s)) + +-- | The union with a combining function. +unionWith :: (v -> v -> v) -> DocIdMap v -> DocIdMap v -> DocIdMap v +unionWith f = liftDIM2 $ IM.unionWith f + +-- | The intersection with a combining function. +intersectionWith :: (v -> v -> v) -> DocIdMap v -> DocIdMap v -> DocIdMap v +intersectionWith f = liftDIM2 $ IM.intersectionWith f + +-- | Difference with a combining function. +differenceWith :: (v -> v -> Maybe v) -> DocIdMap v -> DocIdMap v -> DocIdMap v +differenceWith f = liftDIM2 $ IM.differenceWith f + +-- | The union of a list of maps, with a combining operation. +unionsWith :: (v -> v -> v) -> [DocIdMap v] -> DocIdMap v +unionsWith f = DIM . IM.unionsWith f . P.map unDIM + +-- | Map a function over all values in the map. +map :: (v -> r) -> DocIdMap v -> DocIdMap r +map f = liftDIM $ IM.map f + +-- | Map a function over all values in the map. +mapWithKey :: (DocId -> v -> r) -> DocIdMap v -> DocIdMap r +mapWithKey f = liftDIM $ IM.mapWithKey (f . DocId) + +-- | Filter all values that satisfy some predicate. +filter :: (v -> Bool) -> DocIdMap v -> DocIdMap v +filter p = liftDIM $ IM.filter p + +-- | Filter all 'DocId's/values that satisfy some predicate. +filterWithKey :: (DocId -> v -> Bool) -> DocIdMap v -> DocIdMap v +filterWithKey p = liftDIM $ IM.filterWithKey (p . DocId) + +-- | @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ +-- That is, behaves exactly like a regular 'traverse' except that the traversing +-- function also has access to the 'DocId' associated with a value. +-- +-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) +-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing +traverseWithKey :: Applicative t => (DocId -> a -> t b) -> DocIdMap a -> t (DocIdMap b) +traverseWithKey f = (pure DIM <*>) . IM.traverseWithKey (f . DocId) . unDIM + +-- | Fold the values in the map using the given right-associative binary operator, such that +-- @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. +-- +-- For example, +-- +-- > elems map = foldr (:) [] map +-- +-- > let f a len = len + (length a) +-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 +foldr :: (v -> b -> b) -> b -> DocIdMap v -> b +foldr f u = IM.foldr f u . unDIM + +-- | Fold the 'DocId's and values in the map using the given right-associative +-- binary operator, such that +-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. +-- +-- For example, +-- +-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map +-- +-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" +-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" +foldrWithKey :: (DocId -> v -> b -> b) -> b -> DocIdMap v -> b +foldrWithKey f u = IM.foldrWithKey (f . DocId) u . unDIM + +foldl :: (b -> v -> b) -> b -> DocIdMap v -> b +foldl f u = IM.foldl f u . unDIM + +-- | Create a map from a list of 'DocId'\/value pairs. +fromList :: [(DocId, v)] -> DocIdMap v +fromList = DIM . IM.fromList . L.map (first unDocId) + +-- | Create a map from a set of 'DocId' values +fromDocIdSet :: (Int -> v) -> DocIdSet -> DocIdMap v +fromDocIdSet f s = DIM $ IM.fromSet f (toIntSet s) + +-- | Build a map from a list of 'DocId'\/value pairs where the 'DocId's are in ascending order. +fromAscList :: [(DocId, v)] -> DocIdMap v +fromAscList = DIM . IM.fromAscList . L.map (first unDocId) + +-- | Convert the map to a list of 'DocId'\/value pairs. +-- Subject to list fusion. +toList :: DocIdMap v -> [(DocId, v)] +toList = L.map (first DocId) . IM.toList . unDIM + +-- | Return all 'DocId's of the map in ascending order. +-- Subject to list fusion. +keys :: DocIdMap v -> [DocId] +keys = L.map DocId . IM.keys . unDIM + +-- | Return all elements of the map in the ascending order of their 'DocId's. +-- Subject to list fusion. +elems :: DocIdMap v -> [v] +elems = IM.elems . unDIM + +-- ------------------------------------------------------------ + +{-# INLINE liftDIM #-} +{-# INLINE liftDIM2 #-} +{-# INLINE empty #-} +{-# INLINE singleton #-} +{-# INLINE null #-} +{-# INLINE member #-} +{-# INLINE lookup #-} +{-# INLINE insert #-} +{-# INLINE delete #-} +{-# INLINE insertWith #-} +{-# INLINE size #-} +{-# INLINE union #-} +{-# INLINE difference #-} +{-# INLINE unionWith #-} +{-# INLINE intersectionWith #-} +{-# INLINE differenceWith #-} +{-# INLINE unionsWith #-} +{-# INLINE map #-} +{-# INLINE filter #-} +{-# INLINE filterWithKey #-} +{-# INLINE mapWithKey #-} +{-# INLINE foldr #-} +{-# INLINE foldrWithKey #-} +{-# INLINE fromList #-} +{-# INLINE toList #-} +{-# INLINE keys #-} +{-# INLINE elems #-} + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Common/DocIdSet.hs b/src/Hunt/Common/DocIdSet.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Common/DocIdSet.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Hunt.Index.Common.DocIdSet + Copyright : Copyright (C) 2014 Uwe Schmidt + License : MIT + Maintainer : Uwe Schmidt + + Efficient Set implementation for 'DocId's. +-} + +-- ---------------------------------------------------------------------------- + +module Hunt.Common.DocIdSet + ( DocIdSet(..) + , singleton + , null + , member + , fromList + , toIntSet + , toList + , difference + , union + , intersection + ) +where + +import Prelude hiding (null) + +import Control.DeepSeq +import Control.Monad (mzero) + +import Data.Aeson +import qualified Data.IntSet as S +import qualified Data.List as L +import Data.Monoid (Monoid (..)) +import Data.Typeable +import Data.Binary (Binary (..)) +import Hunt.Common.DocId + +-- ------------------------------------------------------------ +-- +-- the wrapped DocId set + +newtype DocIdSet = DIS { unDIS :: S.IntSet } + deriving (Eq, Show, NFData, Typeable) + +instance Binary DocIdSet where + put = put . unDIS + get = get >>= return . DIS + +instance Monoid DocIdSet where + mempty + = DIS S.empty + mappend (DIS s1) (DIS s2) + = DIS (S.union s1 s2) + +instance ToJSON DocIdSet where + toJSON = toJSON . L.map DocId . S.toList . unDIS + +instance FromJSON DocIdSet where + parseJSON x = do l <- parseJSON x + case fromL l of + Nothing -> mzero + Just s -> return $ DIS s + where + fromL :: [String] -> Maybe S.IntSet + fromL = L.foldr ins (Just S.empty) + where + ins _ Nothing = Nothing + ins xs (Just s) = case fromHex xs of + Nothing -> Nothing + Just i -> Just $ S.insert i s + +difference :: DocIdSet -> DocIdSet -> DocIdSet +difference (DIS s1) (DIS s2) = DIS $ S.difference s1 s2 + +union :: DocIdSet -> DocIdSet -> DocIdSet +union (DIS s1) (DIS s2) = DIS $ S.union s1 s2 + +intersection :: DocIdSet -> DocIdSet -> DocIdSet +intersection (DIS s1) (DIS s2) = DIS $ S.intersection s1 s2 + +fromList :: [DocId] -> DocIdSet +fromList = DIS . S.fromList . L.map unDocId + +toList :: DocIdSet -> [DocId] +toList = L.map DocId . S.toList . unDIS + +toIntSet :: DocIdSet -> S.IntSet +toIntSet = unDIS + +singleton :: DocId -> DocIdSet +singleton = DIS . S.singleton . unDocId + +null :: DocIdSet -> Bool +null = S.null . unDIS + +member :: DocId -> DocIdSet -> Bool +member x s = unDocId x `S.member` unDIS s + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Common/Document.hs b/src/Hunt/Common/Document.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Common/Document.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +-- ---------------------------------------------------------------------------- + +{- | + The document representation. + + This includes the + + * URI for identification, + * the description for the data itself + * the weight used in ranking and + * optionally a score +-} + +-- ---------------------------------------------------------------------------- + +module Hunt.Common.Document +where + +import Control.Applicative +import Control.DeepSeq + +import Data.Aeson +import Data.Binary (Binary (..)) +import Data.Text as T +import Data.Text.Binary () + +import Hunt.Common.ApiDocument +import Hunt.Common.BasicTypes +import qualified Hunt.Common.DocDesc as DD +import Hunt.Utility.Log + +-- ------------------------------------------------------------ + +-- | The document representation. +data Document = Document + { uri :: ! URI -- ^ Unique identifier of the document. + , desc :: ! Description -- ^ Description of the document (simple key-value store). + , wght :: ! Score -- ^ Weight used in ranking (default @1.0@). + } + deriving (Show, Eq) + +emptyDocument :: Document +emptyDocument = Document "" DD.empty defScore + +-- ------------------------------------------------------------ +-- JSON instances implemented with ApiDocument +-- ------------------------------------------------------------ + +toApiDocument :: Document -> ApiDocument +toApiDocument (Document u d w) + = ApiDocument u emptyApiDocIndexMap d (fromDefScore w) + +fromApiDocument :: ApiDocument -> Document +fromApiDocument (ApiDocument u _ix d w) + = Document u d (toDefScore w) + +instance ToJSON Document where + toJSON = toJSON . toApiDocument + +instance FromJSON Document where + parseJSON o = fromApiDocument <$> parseJSON o + +-- ------------------------------------------------------------ + +instance Binary Document where + put (Document u d w) = put u >> put d >> put w + get = Document <$> get <*> get <*> get + +instance NFData Document where + rnf (Document t d _w) = rnf t `seq` rnf d + +-- ------------------------------------------------------------ + +-- | Simple bijection between @e@ and 'Document' for compression. +class (NFData e) => DocumentWrapper e where + -- | Get the document. + unwrap :: e -> Document + -- | Create e from document. + wrap :: Document -> e + -- | Update the wrapped document. + -- @update f = wrap . f . unwrap@. + update :: (Document -> Document) -> e -> e + update f = wrap . f . unwrap + +instance DocumentWrapper Document where + unwrap = id + wrap = id + +-- ------------------------------------------------------------ + +instance LogShow Document where + logShow o = "Document {uri = \"" ++ (T.unpack . uri $ o) ++ "\", ..}" + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Common/IntermediateValue.hs b/src/Hunt/Common/IntermediateValue.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Common/IntermediateValue.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Hunt.Common.IntermediateValue where + +import Control.Arrow (second) +import Control.DeepSeq + +import Data.Aeson +import Data.Binary (Binary) +import qualified Data.List as L + +import Hunt.Common.Occurrences (Occurrences) +import qualified Hunt.Common.Occurrences as Occ +import Hunt.Common.DocIdSet (DocIdSet (..)) +import qualified Hunt.Common.DocIdSet as DS +import qualified Hunt.Common.DocIdMap as DM + +-- This type represents the interface for a value to the engine +-- To have an easy first implementaton the intermediate is +-- basically the same as Occurrences, but that can be adjusted later +newtype IntermediateValue = IntermediateValue + { unIntermediate :: Occurrences + } + deriving (Show, Eq) + +mkIntermediateValue :: Occurrences -> IntermediateValue +mkIntermediateValue o = IntermediateValue $! o + +instance NFData IntermediateValue where + rnf (IntermediateValue occ) = rnf occ + +instance ToJSON IntermediateValue where + toJSON x = toJSON (fromIntermediate x :: Occurrences) + +fromIntermediates :: IndexValue u => [(x, IntermediateValue)] -> [(x, u)] +fromIntermediates xs = L.map (second fromIntermediate) xs + +fromScoredIntermediates :: IndexValue u => [(x, (s, IntermediateValue))] -> [(x, (s,u))] +fromScoredIntermediates xs = L.map (\(x,u) -> (x, second fromIntermediate $ u)) xs + +toIntermediates :: IndexValue u => [(x,u)] -> [(x, IntermediateValue)] +toIntermediates xs = L.map (second toIntermediate) xs + +class (Binary x, NFData x) => IndexValue x where + toIntermediate :: x -> IntermediateValue + fromIntermediate :: IntermediateValue -> x + mergeValues :: x -> x -> x + diffValues :: DocIdSet -> x -> Maybe x + +instance IndexValue Occurrences where + toIntermediate x = mkIntermediateValue x + fromIntermediate x = unIntermediate $! x + mergeValues = Occ.merge + diffValues s m = let z = Occ.diffWithSet m s in + if Occ.null z then Nothing else Just z + +mapToSet :: Occurrences -> DocIdSet +mapToSet = DS.fromList . DM.keys + +instance IndexValue DocIdSet where + toIntermediate = mkIntermediateValue . Occ.fromDocIdSet + fromIntermediate = mapToSet . fromIntermediate + mergeValues = DS.union + diffValues s1 s2 = let r = DS.difference s2 s1 in + if DS.null r then Nothing else Just r diff --git a/src/Hunt/Common/Occurrences.hs b/src/Hunt/Common/Occurrences.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Common/Occurrences.hs @@ -0,0 +1,118 @@ +-- ---------------------------------------------------------------------------- + +{- | + Module : Hunt.Common.Occurrences + Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: none portable + + Occurrences of words within the index. + A word occurs in document at specific locations. +-} + +-- ---------------------------------------------------------------------------- + +module Hunt.Common.Occurrences +where + +import Prelude hiding (subtract) + +import Hunt.Common.BasicTypes +import Hunt.Common.DocId +import Hunt.Common.DocIdMap (DocIdMap) +import Hunt.Common.DocIdSet (DocIdSet) +import qualified Hunt.Common.DocIdMap as DM +import Hunt.Common.Positions (Positions) +import qualified Hunt.Common.Positions as Pos + +-- ------------------------------------------------------------ + +-- | The occurrences of words in documents. +-- A mapping from document ids to the positions in the document. +type Occurrences = DocIdMap Positions + +-- ------------------------------------------------------------ + +-- | Create an empty set of positions. +empty :: Occurrences +empty = DM.empty + +-- | Create Occurrences from a 'DocIdSet' +-- Since the 'DocIdSet' contains no position information, we +-- assume position one for each 'DocId' +fromDocIdSet :: DocIdSet -> Occurrences +fromDocIdSet s = DM.fromDocIdSet (\_ -> Pos.singleton 1) s + +-- | Create a single dcid set with a single position. +singleton :: DocId -> Position -> Occurrences +singleton d p = singleton' d [p] + +-- | Create a single dcid set with a set of. +singleton' :: DocId -> [Position] -> Occurrences +singleton' d ps = DM.insert d (Pos.fromList ps) DM.empty + +-- | Test on empty set of positions. +null :: Occurrences -> Bool +null = DM.null + +-- | Determine the number of positions in a set of occurrences. +size :: Occurrences -> Int +size = DM.foldr ((+) . Pos.size) 0 + +-- | Add a position to occurrences. +insert :: DocId -> Position -> Occurrences -> Occurrences +insert d p = DM.insertWith Pos.union d (Pos.singleton p) + +-- | Add multiple positions to occurrences +insert' :: DocId -> Positions -> Occurrences -> Occurrences +insert' d ps occs = Pos.foldr (insert d) occs ps + +-- | Remove a position from occurrences. +deleteOccurrence :: DocId -> Position -> Occurrences -> Occurrences +deleteOccurrence d p = subtract (DM.singleton d (Pos.singleton p)) + +-- | Delete a document (by 'DocId') from occurrences. +delete :: DocId -> Occurrences -> Occurrences +delete = DM.delete + +-- | Changes the DocIDs of the occurrences. +update :: (DocId -> DocId) -> Occurrences -> Occurrences +update f = DM.foldrWithKey + (\ d ps res -> DM.insertWith Pos.union (f d) ps res) empty + +-- | Merge two occurrences. +merge :: Occurrences -> Occurrences -> Occurrences +merge = DM.unionWith Pos.union + +-- | Merge occurrences +merges :: [Occurrences] -> Occurrences +merges = DM.unionsWith Pos.union + +-- | Difference of occurrences. +difference :: Occurrences -> Occurrences -> Occurrences +difference = DM.difference + +-- | Remove Set of DocIds from Occurrences +diffWithSet :: Occurrences -> DocIdSet -> Occurrences +diffWithSet = DM.diffWithSet + +-- | Subtract occurrences from some other occurrences. +subtract :: Occurrences -> Occurrences -> Occurrences +subtract = DM.differenceWith subtractPositions + where + subtractPositions p1 p2 + = if Pos.null diffPos + then Nothing + else Just diffPos + where + diffPos = Pos.difference p1 p2 + +intersectOccurrences :: (Positions -> Positions -> Positions) -> + Occurrences -> Occurrences -> Occurrences +intersectOccurrences pf os1 os2 + = DM.filter (not . Pos.null) $ DM.intersectionWith pf os1 os2 + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Common/Positions.hs b/src/Hunt/Common/Positions.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Common/Positions.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- ---------------------------------------------------------------------------- + +{- | + Positions within document. +-} + +-- ---------------------------------------------------------------------------- + +module Hunt.Common.Positions where + +import Control.Applicative ((<$>)) +import Control.DeepSeq + +import Data.Aeson +import Data.Binary as B +import qualified Data.IntSet as IS +import Data.IntSet.Cache as IS +import Data.Maybe (fromMaybe) +import Data.Monoid () +import Data.Typeable + +import Hunt.Common.BasicTypes + +-- ------------------------------------------------------------ + +-- | The positions of the word in the document. + +newtype Positions + = PS {unPS :: IS.IntSet} + deriving (Eq, Ord, Read, Show, Typeable, NFData, Monoid) + +-- ------------------------------------------------------------ + +instance B.Binary Positions where + put = B.put . toAscList + get = fromList <$> B.get + +instance ToJSON Positions where + toJSON = toJSON . unPS + +-- ------------------------------------------------------------ + +-- | Empty positions. +empty :: Positions +empty = PS IS.empty + +-- | Positions with one element. +singleton :: Position -> Positions +singleton = PS . IS.cacheAt +--singleton = PS . IS.singleton + +-- | Test whether it is the empty positions. +null :: Positions -> Bool +null = IS.null . unPS + +-- | Whether the 'Position' is part of 'Positions'. +member :: Position -> Positions -> Bool +member p = IS.member p . unPS + +-- | Converts 'Positions' to a list of 'Position's in ascending order. +toAscList :: Positions -> [Position] +toAscList = IS.toAscList . unPS + +-- | Constructs Positions from a list of 'Position's. +fromList :: [Position] -> Positions +fromList = PS . IS.unions . map IS.cacheAt +--fromList = PS . IS.fromList + +-- | Number of 'Position's. +size :: Positions -> Int +size = IS.size . unPS + +-- | The union of two 'Positions'. +union :: Positions -> Positions -> Positions +union s1 s2 = PS $ (unPS s1) `IS.union` (unPS s2) + +-- | The union of two 'Positions'. +intersection :: Positions -> Positions -> Positions +intersection s1 s2 = PS $ (unPS s1) `IS.intersection` (unPS s2) + +-- | The union of two 'Positions'. +difference :: Positions -> Positions -> Positions +difference s1 s2 = PS $ (unPS s1) `IS.difference` (unPS s2) + +-- | A fold over Positions +foldr :: (Position -> r -> r) -> r -> Positions -> r +foldr op e = IS.foldr op e . unPS + +-- | intersection with a "shifted" 2. set with elements decremented by a displacement @d@ +-- before the element test +-- +-- useful when searching for sequences of words (phrases) + +intersectionWithDispl :: Int -> Positions -> Positions -> Positions +intersectionWithDispl d (PS s1) (PS s2) + = PS $ IS.filter member' s1 + where + member' i = (i + d) `IS.member` s2 + +-- | intersction with "fuzzy" element test. All elements @e1@ for which an element @e2@ in @s2@ +-- is found with @e2 - e1 `elem` [lb..ub]@ remain in set @s1@. +-- +-- Useful for context search with sequences of words. +-- This generatizes 'intersectionWithDispl' +-- +-- Law: @intersectionWithIntervall d d == intersectionWithDispl d@ + +intersectionWithIntervall :: Int -> Int -> Positions -> Positions -> Positions +intersectionWithIntervall lb ub (PS s1) (PS s2) + = PS $ IS.filter member' s1 + where + member' i = minElem <= i + ub + where + (_ls, gt) = IS.split (i + lb - 1) s2 + minElem = fromMaybe (i + ub + 1) $ fst <$> IS.minView gt + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Common/RawResult.hs b/src/Hunt/Common/RawResult.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Common/RawResult.hs @@ -0,0 +1,52 @@ +-- ---------------------------------------------------------------------------- + +{- | + Module : Hunt.Index.Common.RawResult + Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: none portable + + The raw result of index queries. +-} + +-- ---------------------------------------------------------------------------- + +module Hunt.Common.RawResult +where + +import Data.Map (Map) +import qualified Data.Map as M + +import Hunt.Common.BasicTypes +import Hunt.Common.DocIdMap (DocIdMap) +import qualified Hunt.Common.DocIdMap as DM +import Hunt.Common.Occurrences +import Hunt.Common.Positions + +-- ------------------------------------------------------------ + +-- | The raw result returned when searching the index. +type RawResult = [(Word, Occurrences)] + +type RawScoredResult = [(Word, (Score, Occurrences))] + +-- ------------------------------------------------------------ + +-- | Transform the raw result into a tree structure ordered by word. +resultByWord :: Context -> RawResult -> Map Word (Map Context Occurrences) +resultByWord c + = M.fromList . map (\ (w, o) -> (w, M.singleton c o)) + +-- | Transform the raw result into a tree structure ordered by document. +resultByDocument :: Context -> RawResult -> DocIdMap (Map Context (Map Word Positions)) +resultByDocument c os + = DM.map transform $ + DM.unionsWith (flip $ (:) . head) (map insertWords os) + where + insertWords (w, o) = DM.map (\p -> [(w, p)]) o + transform w = M.singleton c (M.fromList w) + +-- ------------------------------------------------------------ diff --git a/src/Hunt/ContextIndex.hs b/src/Hunt/ContextIndex.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/ContextIndex.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- ---------------------------------------------------------------------------- +{- | + The context index introduces contexts and combines the index, document table and schema. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.ContextIndex + ( + -- * Construction + empty + + -- * Contexts and Schema + , insertContext + , deleteContext + , foreachContext + , contexts + , contextsM + , hasContext + , hasContextM + + -- * Queries + , lookupRangeCx + , lookupAllWithCx + , searchWithCx + , searchWithCxsNormalized + , searchWithCxSc + , lookupRangeCxSc + + -- * Insert\/Delete Documents + , insertList + -- XXX: these functions should be internal + -- we export them to be able to test them + -- is there a bedder approach to achieve this? + , createDocTableFromPartition -- only used in tests + , unionDocTables -- only used in tests + , modifyWithDescription + , delete + , deleteDocsByURI + , decodeCxIx + , member + + -- * Types + , ContextIndex (..) + , ContextMap (..) + , IndexRep + , mkContextMap + , mapToSchema + ) +where +{- +import Debug.Trace (traceShow) +-- -} +import Prelude +import qualified Prelude as P + +import Control.Applicative (Applicative, (<$>), (<*>)) +import Control.Arrow +import Control.Monad +import qualified Control.Monad.Parallel as Par + +import Data.Binary (Binary (..)) +import Data.Binary.Get +import Data.ByteString.Lazy (ByteString) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) + +import Hunt.Common +import qualified Hunt.Common.DocDesc as DocDesc +import qualified Hunt.Common.DocIdSet as DS +import qualified Hunt.Common.Document as Doc +import Hunt.Common.IntermediateValue +import qualified Hunt.Common.Occurrences as Occ + +import Hunt.DocTable (DocTable) +import qualified Hunt.DocTable as Dt +import qualified Hunt.Index as Ix +import Hunt.Index.IndexImpl (IndexImpl) +import qualified Hunt.Index.IndexImpl as Impl +import Hunt.Utility + +-- ------------------------------------------------------------ + +-- | Context index introduces contexts and combines the major components of Hunt. + +data ContextIndex dt = ContextIndex + { ciIndex :: !ContextMap -- ^ Indexes associated to contexts. + , ciDocs :: !dt -- ^ Document table. + } + +empty :: DocTable dt => ContextIndex dt +empty = ContextIndex emptyContextMap Dt.empty + +-- | Contexts with associated heterogeneous index implementations. + +type IndexRep = (ContextSchema, Impl.IndexImpl) + +newtype ContextMap + = ContextMap { cxMap :: Map Context IndexRep } + deriving (Show) + +-- | Empty context map. +emptyContextMap :: ContextMap +emptyContextMap = mkContextMap $ M.empty + + +-- | Strict smart constructor for the 'ContextMap'. + +mkContextMap :: Map Context IndexRep -> ContextMap +mkContextMap x = ContextMap $! x + +-- | Get 'Schema' from 'ContextMap' +mapToSchema :: ContextMap -> Schema +mapToSchema (ContextMap m) = M.map fst m + +-- ------------------------------------------------------------ +-- Binary / Serialization +-- ------------------------------------------------------------ + +getContextMap :: [IndexImpl] -> Get ContextMap +getContextMap ts + = do + impls <- Impl.gets' ts + s <- get + return . mkContextMap . M.fromDistinctAscList $ map (mergeGets s) impls + where + mergeGets s (c, i) = (c, (getS c s, i)) + getS c s = fromMaybe (error "deserializating failed: context schema is missing") + $ lookup c s + +instance Binary ContextMap where + put = put . cxMap + get = get >>= return . mkContextMap + + +-- | Deserialize a 'ContextIndex' with the list of available index implementations and a +-- map of available 'ContextSchema'. +-- +-- /Note/: The serialized index implementations have to be in the list of available types, +-- otherwise this will fail. The serialized schemas have to be in the list of +-- available 'ContextSchema', otherwise this will fail as well. + +decodeCxIx :: (Binary dt, DocTable dt) => [IndexImpl] -> ByteString -> ContextIndex dt +decodeCxIx ts = runGet (get' ts) + +get' :: Binary dt => [IndexImpl] -> Get (ContextIndex dt) +get' ts = ContextIndex <$> (getContextMap ts) <*> get + +instance Binary dt => Binary (ContextIndex dt) where + get = error "existential types cannot be deserialized this way. Use special get' functions" + put (ContextIndex (ContextMap a) b) + = put (M.map snd a) >> -- convert to 'IndexImpl' and serialize + put (M.map fst a) >> -- convert to 'Schema' and serialize + put b -- put 'DocTable' + +-- ------------------------------------------------------------ + +{- +-- | Insert a Document and Words. +-- +-- /Note/: For multiple inserts, use the more efficient 'insertList'. +insert :: (Par.MonadParallel m, Applicative m, DocTable dt) + => Dt.DValue dt -> Words -> ContextIndex dt -> m (ContextIndex dt) +insert doc wrds ix = insertList [(doc,wrds)] ix +-} + +-- This is more efficient than using fold and with 'insert'. +-- | Insert multiple documents and words. + +insertList :: (Par.MonadParallel m, Applicative m, DocTable dt) => + [(Dt.DValue dt, Words)] -> + ContextIndex dt -> m (ContextIndex dt) + +insertList docAndWords (ContextIndex ix docTable) + = do -- insert to doctable and generate docId + tablesAndWords <- Par.mapM createDocTableFromPartition + $ partitionListByLength 20 docAndWords + -- union doctables and docid-words pairs + (newDt, docIdsAndWords) <- unionDocTables tablesAndWords docTable + -- insert words to index + newIx <- batchAddWordsM docIdsAndWords ix + return $! ContextIndex newIx newDt + +-- takes list of documents with wordlist. creates new 'DocTable' and +-- inserts each document of the list into it. +createDocTableFromPartition :: (Par.MonadParallel m, DocTable dt) => + [(Dt.DValue dt, Words)] -> m (dt, [(DocId, Words)]) +createDocTableFromPartition ds + = foldM toDocTable (Dt.empty, []) ds + where + toDocTable (dt, resIdsAndWords) (doc, ws) + = do (dId, dt') <- Dt.insert doc dt + return (dt', (dId, ws):resIdsAndWords) + +-- takes list of doctables with lists of docid-words pairs attached +-- unions the doctables to one big doctable and concats the docid-words +-- pairs to one list +unionDocTables :: (DocTable dt, Par.MonadParallel m) => + [(dt, [(DocId, Words)])] -> dt -> m (dt, [(DocId, Words)]) +unionDocTables tablesAndWords oldDt + = do step <- Par.mapM unionDtsAndWords $ mkPairs tablesAndWords + case step of + [] -> return (Dt.empty, []) + [(d,w)] -> do n <- Dt.union oldDt d + return (n, w) + xs -> unionDocTables xs oldDt + where + unionDtsAndWords ((dt1, ws1), (dt2, ws2)) + = do dt <- Dt.union dt1 dt2 + return (dt, ws1 ++ ws2) + + mkPairs [] = [] + mkPairs (a:[]) = [(a,(Dt.empty,[]))] + mkPairs (a:b:xs) = (a,b):mkPairs xs + +{- +-- XXX: this should not work well atm +-- | Modify documents and index data. + +modify :: (Par.MonadParallel m, Applicative m, DocTable dt) + => (Dt.DValue dt -> m (Dt.DValue dt)) + -> Words -> DocId -> ContextIndex dt -> m (ContextIndex dt) +modify f wrds dId (ContextIndex ii dt s) = do + newDocTable <- Dt.adjust f dId dt + newIndex <- addWordsM wrds dId ii + return $ ContextIndex newIndex newDocTable s +-- -} + +-- | Delete a set of documents by 'URI'. +deleteDocsByURI :: (Par.MonadParallel m, Applicative m, DocTable dt) + => Set URI -> ContextIndex dt -> m (ContextIndex dt) +deleteDocsByURI us ixx@(ContextIndex _ix dt) = do + docIds <- liftM (DS.fromList . catMaybes) . mapM (flip Dt.lookupByURI dt) . S.toList $ us + delete docIds ixx + + +-- | Delete a set of documents by 'DocId'. +delete :: (Par.MonadParallel m, Applicative m, DocTable dt) + => DocIdSet -> ContextIndex dt -> m (ContextIndex dt) +delete dIds cix@(ContextIndex ix dt) + | DS.null dIds + = return cix + | otherwise + = do newIx <- delete' dIds ix + newDt <- Dt.difference dIds dt + return $ ContextIndex newIx newDt + + +-- | Is the document part of the index? +member :: (Monad m, Applicative m, DocTable dt) + => URI -> ContextIndex dt -> m Bool +member u (ContextIndex _ii dt) = do + mem <- Dt.lookupByURI u dt + return $ isJust mem + +-- ------------------------------------------------------------ + +-- | Modify the description of a document and add words +-- (occurrences for that document) to the index. + +modifyWithDescription :: (Par.MonadParallel m, Applicative m, DocTable dt) => + Score -> Description -> Words -> DocId -> ContextIndex dt -> + m (ContextIndex dt) +modifyWithDescription weight descr wrds dId (ContextIndex ii dt) + = do newDocTable <- Dt.adjust mergeDescr dId dt + newIndex <- batchAddWordsM [(dId,wrds)] ii + return $ ContextIndex newIndex newDocTable + where + -- M.union is left-biased + -- flip to use new values for existing keys + -- no flip to keep old values + -- + -- Null values in new descr will remove associated attributes + mergeDescr + = return . Doc.update (updateWeight . updateDescr) + where + updateWeight d + | weight == noScore = d + | otherwise = d {wght = weight} + + updateDescr d = -- trc "updateDescr res=" $ + d {desc = DocDesc.deleteNull $ + flip DocDesc.union d' descr' + } + where + d' = -- trc "updateDescr old=" $ + desc d + descr' = -- trc "updateDescr new=" $ + descr + +-- trc :: Show a => String -> a -> a +-- trc msg x = traceShow (msg, x) x + +-- ------------------------------------------------------------ +-- Helper +-- ------------------------------------------------------------ + +-- | Adds words associated to a document to the index. +-- + +-- | Add words for a document to the 'Index'. +-- +-- /Note/: Adds words to /existing/ 'Context's. + +batchAddWordsM :: (Functor m, Par.MonadParallel m) => + [(DocId, Words)] -> ContextMap -> m ContextMap +batchAddWordsM [] ix + = return ix + +batchAddWordsM vs (ContextMap m) + = mkContextMap <$> + mapWithKeyMP ( \cx (s, impl) -> do i <- foldinsertList cx impl + return (s, i) + ) m + where + foldinsertList :: (Functor m, Monad m) => + Context -> IndexImpl -> m IndexImpl + foldinsertList cx (Impl.IndexImpl impl) + = Impl.mkIndex <$> + Ix.insertListM (contentForCx cx vs) impl + +-- | Computes the words and occurrences out of a list for one context + +contentForCx :: Context -> [(DocId, Words)] -> [(Word, IntermediateValue)] +contentForCx cx vs + = concatMap (invert . second (getWlForCx cx)) $ vs + where + invert (did, wl) + = map (second (toIntermediate . Occ.singleton' did)) $ M.toList wl + getWlForCx cx' ws' + = fromMaybe M.empty (M.lookup cx' ws') + +---------------------------------------------------------------------------- +-- addWords/batchAddWords functions +---------------------------------------------------------------------------- + +mapWithKeyMP :: (Par.MonadParallel m, Ord k) => (k -> a -> m b) -> M.Map k a -> m (M.Map k b) +mapWithKeyMP f m = + (Par.mapM (\(k, a) -> do + b <- f k a + return (k, b) + ) $ M.toList m) >>= + return . M.fromList + +---------------------------------------------------------------------------- + +-- | Inserts a new context. +-- +insertContext :: Context -> Impl.IndexImpl -> ContextSchema + -> ContextIndex dt -> ContextIndex dt +insertContext c ix schema (ContextIndex m dt) + = ContextIndex m' dt + where + m' = insertContext' c schema ix m + +-- /Note/: Does nothing if the context already exists. +insertContext' :: Context -> ContextSchema -> Impl.IndexImpl -> ContextMap -> ContextMap +insertContext' c s ix (ContextMap m) = mkContextMap $ M.insertWith (const id) c (s, ix) m + +-- | Removes context (including the index and the schema). +deleteContext :: Context -> ContextIndex dt -> ContextIndex dt +deleteContext c (ContextIndex ix dt) = ContextIndex (deleteContext' c ix) dt + +-- | Removes context (includes the index, but not the schema). +deleteContext' :: Context -> ContextMap -> ContextMap +deleteContext' cx (ContextMap m) = mkContextMap $ M.delete cx m + +delete' :: Par.MonadParallel m => DocIdSet -> ContextMap -> m ContextMap +delete' dIds (ContextMap m) + = mapWithKeyMP (\_ impl -> adjust' impl) m >>= return . mkContextMap +-- = TV.mapM adjust' m >>= return . mkContextMap + where + adjust' (s, Impl.IndexImpl ix) = Ix.deleteDocsM dIds ix >>= \i -> return (s, Impl.mkIndex i) + +{- not yet used + +-- | Search query in all context. +search :: Monad m => TextSearchOp -> Text -> ContextMap -> m [(Context, [(Text, v)])] +search op k (ContextMap m) + = liftM M.toList $ TV.mapM search' m + where + search' (Impl.IndexImpl ix) = Ix.searchM op k ix +-- -} + +-- | Range query in a context between first and second key. +lookupRangeCx :: Monad m => Context -> Text -> Text -> ContextMap -> m [(Text, IntermediateValue)] +lookupRangeCx c k1 k2 cm + = lookupIndex c cm $ Ix.lookupRangeM k1 k2 + +-- | Dump a context +lookupAllWithCx :: Monad m => Context -> ContextMap -> m [(Text, IntermediateValue)] +lookupAllWithCx cx cm + = lookupIndex cx cm $ Ix.toListM + +-- | Search query in a context. +searchWithCx :: Monad m => TextSearchOp -> Context -> Text -> ContextMap -> m [(Text, IntermediateValue)] +searchWithCx op cx w cm + = lookupIndex cx cm $ Ix.searchM op w + + +-- | Search over a list of contexts and words +searchWithCxsNormalized :: (Functor m, Monad m) => + TextSearchOp -> [(Context, Text)] -> ContextMap -> + m [(Context, [(Text, IntermediateValue)])] +searchWithCxsNormalized op cxws cm + = P.mapM (uncurry search') cxws + where + search' cx w + = (\ x -> (cx, x)) + <$> (lookupIndex cx cm $ Ix.searchM op w) + +-- | Search query with scored results +-- XXX TODO: this function should return intermediates and query processor should work with those +searchWithCxSc :: Monad m => + TextSearchOp -> Context -> Text -> ContextMap -> m [(Text, (Score, Occurrences))] +searchWithCxSc op cx w cm + = (lookupIndex cx cm $ Ix.searchMSc op w) >>= return . fromScoredIntermediates + +-- | Range query in a context between first and second key. +-- XXX TODO: this function should return intermediates and query processor should work with those +lookupRangeCxSc :: Monad m => Context -> Text -> Text -> ContextMap -> m [(Text, (Score, Occurrences))] +lookupRangeCxSc c k1 k2 cm + = (lookupIndex c cm $ Ix.lookupRangeMSc k1 k2) >>= return . fromScoredIntermediates + +-- ------------------------------------------------------------ + +-- | lookup an index by a context and then search this index for a word +-- result is always a list of values. +-- +-- This pattern is used in all search variants + +lookupIndex :: Monad m => + Context -> ContextMap -> + (forall i . Impl.IndexImplCon i => i -> m [r]) -> + m [r] +lookupIndex cx (ContextMap m) search + = case M.lookup cx m of + Just (_, Impl.IndexImpl cm) + -> search cm + Nothing + -> return [] + +foreachContext :: (Functor m, Monad m) => + [Context] -> + (Context -> m res) -> + m [(Context, res)] +foreachContext cxs action + = P.mapM action' cxs + where + action' cx + = (\ r -> (cx, r)) <$> action cx + +-- ------------------------------------------------------------ + +-- | All contexts of the index. +contextsM :: (Monad m, DocTable dt) + => ContextIndex dt -> m [Context] +contextsM (ContextIndex ix _) = return $ contexts ix + +-- | Contexts/keys of 'ContextMap'. +contexts :: ContextMap -> [Context] +contexts (ContextMap m) = M.keys m + +-- | Check if the context exists. +hasContext :: Context -> ContextMap -> Bool +hasContext c (ContextMap m) = M.member c m + +-- | Does the context exist? +hasContextM :: (Monad m, DocTable dt) + => Context -> ContextIndex dt -> m Bool +hasContextM c (ContextIndex ix _) = return $ hasContext c ix + + diff --git a/src/Hunt/DocTable.hs b/src/Hunt/DocTable.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/DocTable.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +-- ---------------------------------------------------------------------------- +{- | + The document table interface. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.DocTable +where + +import Prelude hiding (filter, lookup, map, null) + +import Control.Applicative (Applicative, (<$>)) +import Control.Monad + +import Data.Aeson +import Data.Maybe (catMaybes, fromJust) +import Data.Set (Set) +import qualified Data.Set as S + +import Hunt.Common.BasicTypes +import Hunt.Common.DocId +import Hunt.Common.DocIdMap (DocIdMap (..)) +import qualified Hunt.Common.DocIdMap as DM +import Hunt.Common.DocIdSet (DocIdSet) +import qualified Hunt.Common.DocIdSet as DS +import Hunt.Common.Document (Document, + DocumentWrapper (wrap, unwrap)) + +-- ------------------------------------------------------------ + +-- | The document table type class which needs to be implemented to be used by the 'Interpreter'. +-- The type parameter @i@ is the implementation. +-- The implementation must have a value type parameter. + +class (DocumentWrapper (DValue i)) => DocTable i where + -- | The value type of the document table. + type DValue i :: * + + -- | Test whether the document table is empty. + null :: (Monad m) => i -> m Bool + + -- | Returns the number of unique documents in the table. + size :: (Monad m) => i -> m Int + + -- | Lookup a document by its ID. + lookup :: (Monad m) => DocId -> i -> m (Maybe (DValue i)) + + -- | Lookup the 'DocId' of a document by an 'URI'. + lookupByURI :: (Monad m) => URI -> i -> m (Maybe DocId) + + -- | Union of two disjoint document tables. It is assumed, that the + -- DocIds and the document 'URI's of both indexes are disjoint. + union :: (Monad m) => i -> i -> m i + + -- | Test whether the 'DocId's of both tables are disjoint. + disjoint :: (Monad m) => i -> i -> m Bool + + -- | Insert a document into the table. Returns a tuple of the 'DocId' for that document and the + -- new table. If a document with the same 'URI' is already present, its id will be returned + -- and the table is returned unchanged. + insert :: (Monad m) => DValue i -> i -> m (DocId, i) + + -- | Update a document with a certain 'DocId'. + update :: (Monad m) => DocId -> DValue i -> i -> m i + + -- | Update a document by 'DocId' with the result of the provided function. + adjust :: (Monad m) => (DValue i -> m (DValue i)) -> DocId -> i -> m i + adjust f did d = + maybe (return d) (upd d did <=< f) =<< lookup did d + --maybe d (update d did . f) $ lookup d did + where upd i docid v = update docid v i + + -- | Update a document by 'URI' with the result of the provided function. + adjustByURI :: (Monad m) => (DValue i -> m (DValue i)) -> URI -> i -> m i + adjustByURI f uri d + = maybe (return d) (flip (adjust f) d) =<< lookupByURI uri d + + -- | Removes the document with the specified 'DocId' from the table. + delete :: (Monad m) => DocId -> i -> m i + + -- | Removes the document with the specified 'URI' from the table. + deleteByURI :: (Monad m) => URI -> i -> m i + deleteByURI u ds + = maybe (return ds) (flip delete ds) =<< lookupByURI u ds + + -- | Deletes a set of documents by 'DocId' from the table. + difference :: (Monad m) => DocIdSet -> i -> m i + + -- | Deletes a set of documents by 'URI' from the table. + differenceByURI :: (Monad m) => Set URI -> i -> m i + differenceByURI uris d = do -- XXX: eliminate S.toList? + ids <- liftM (DS.fromList . catMaybes) . mapM (flip lookupByURI d) . S.toList $ uris + difference ids d + + -- | Map a function over all values of the document table. + map :: (Monad m) => (DValue i -> DValue i) -> i -> m i + + -- | Filters all documents that satisfy the predicate. + filter :: (Monad m) => (DValue i -> Bool) -> i -> m i + + -- | Convert document table to a 'DocIdMap'. + toMap :: (Monad m) => i -> m (DocIdMap (DValue i)) + + -- | Empty 'DocTable'. + empty :: i + + +restrict :: (Functor m, Monad m, Applicative m, DocTable i) => DocIdSet -> i -> m i +restrict is dt + = foldM ins empty $ DS.toList is + where + ins m i = do v <- fromJust <$> lookup i dt + update i v m + +-- ------------------------------------------------------------ + +-- | JSON dump of the document table. +toJSON'DocTable :: (Functor m, Monad m, Applicative m, DocTable i) => i -> m Value +toJSON'DocTable dt + = do didm <- DM.map unwrap <$> toMap dt + return $ toJSON didm + +-- | JSON import of the document table. +fromJSON'DocTable :: (Functor m, Monad m, Applicative m, DocTable i) => Value -> m i +fromJSON'DocTable v + = foldM ins empty $ dm' + where + ins res (did, doc) = update did doc res + + dm :: DocIdMap Document + dm = case fromJSON v of + Error _ -> DM.empty + Success m -> m + + dm'= DM.toList . DM.map wrap $ dm + +-- ------------------------------------------------------------ diff --git a/src/Hunt/DocTable/HashedDocTable.hs b/src/Hunt/DocTable/HashedDocTable.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/DocTable/HashedDocTable.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Hunt.Index.HashedDocTable + Copyright : Copyright (C) 2012 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : experimental + + A more space efficient substitute for Hunt.Index.Documents + and a more flexible implementation than Hunt.Index.CompactDocuments. + + DocIds are computed by a hash function, so the inverse map from 'URI's to 'DocId's + is substituted by the hash function. + + MurmurHash2 64-bit is used as the hash function. + https://sites.google.com/site/murmurhash/ + + It is a fast non-cryptographic hash function with good performance and + hash distribution properties. + http://programmers.stackexchange.com/a/145633 +-} + +-- ---------------------------------------------------------------------------- + +module Hunt.DocTable.HashedDocTable + ( + -- * Documents type + Documents (..) + , DocMap + + -- * Conversion + , fromMap + ) +where + +import Data.Binary (Binary (..)) + +import Control.DeepSeq + +import Hunt.Common.BasicTypes +import Hunt.Common.DocId (DocId, mkDocId) +import Hunt.Common.DocIdMap (DocIdMap) +import qualified Hunt.Common.DocIdMap as DM +import Hunt.Common.DocIdSet (DocIdSet) +import Hunt.Common.Document (Document (..), DocumentWrapper (..)) +import Hunt.DocTable +import Hunt.Utility + +-- ------------------------------------------------------------ + +-- | The table which is used to map a document to an artificial id and vice versa. +type DocMap e + = DocIdMap e + +-- | The 'DocTable' implementation. Maps 'DocId's to 'Document's. +newtype Documents e + = Documents { idToDoc :: DocMap e } -- ^ A mapping from a document id to + -- the document itself. + deriving (Eq, Show) + +mkDocuments :: NFData e => DocMap e -> Documents e +mkDocuments m = Documents $! m + +-- ------------------------------------------------------------ + +instance NFData e => NFData (Documents e) where + rnf (Documents e) = rnf e + +instance (DocumentWrapper e, Binary e) => Binary (Documents e) where + put = put . idToDoc + get = get >>= return . mkDocuments + +--- ------------------------------------------------------------ + +-- | An empty document table. +empty' :: (DocTable (Documents e), DocumentWrapper e) => Documents e +empty' = mkDocuments DM.empty + +-- | Build a 'DocTable' from a 'DocIdMap' (maps 'DocId's to 'Document's) +fromMap :: (DocTable (Documents e), DocumentWrapper e) => + (Document -> e) -> DocIdMap Document -> Documents e +fromMap = fromMap' + +-- ------------------------------------------------------------ + +instance (DocumentWrapper e) => + DocTable (Documents e) where + type DValue (Documents e) = e + null = return . null' + + -- Returns the number of unique documents in the table. + size = return . size' + + -- Lookup a document by its id. + lookup = return .:: lookup' + + -- Lookup the id of a document by an URI. + lookupByURI = return .:: lookupByURI' + + -- Union of two disjoint document tables. It is assumed, that the DocIds and the document uris + -- of both indexes are disjoint. If only the sets of uris are disjoint, the DocIds can be made + -- disjoint by adding maxDocId of one to the DocIds of the second, e.g. with editDocIds + union = return .:: unionDocs' + + -- Test whether the doc ids of both tables are disjoint. + disjoint = return .:: disjoint' + + -- Insert a document into the table. Returns a tuple of the id for that document and the + -- new table. If a document with the same URI is already present, its id will be returned + -- and the table is returned unchanged. + insert = return .:: insert' + + -- Update a document with a certain DocId. + update = return .::: update' + + -- Removes the document with the specified id from the table. + delete = return .:: delete' + + -- Deletes a set of Docs by Id from the table. + difference = return .:: difference' + + -- Update documents (through mapping over all documents). + map = return .:: map' + + -- Filters all documents that satisfy the predicate. + filter = return .:: filter' + + -- Convert document table to a single map. + toMap = return . toMap' + + -- | Empty 'DocTable'. + empty = empty' + +-- ------------------------------------------------------------ + +null' :: (DocumentWrapper e) => Documents e -> Bool +null' + = DM.null . idToDoc + +size' :: (DocumentWrapper e) => Documents e -> Int +size' + = DM.size . idToDoc + +lookup' :: (Monad m, DocumentWrapper e) => DocId -> Documents e -> m e +lookup' i d + = maybe (fail "") return + . DM.lookup i + . idToDoc + $ d + +lookupByURI' :: (Monad m, DocumentWrapper e) => URI -> Documents e -> m DocId +lookupByURI' u d + = maybe (fail "") (const $ return i) + . DM.lookup i + . idToDoc + $ d + where + i = mkDocId u + +disjoint' :: (DocumentWrapper e) => Documents e -> Documents e -> Bool +disjoint' dt1 dt2 + = DM.null $ DM.intersection (idToDoc dt1) (idToDoc dt2) + +unionDocs' :: (DocumentWrapper e) => Documents e -> Documents e -> Documents e +unionDocs' dt1 dt2 + | disjoint' dt1 dt2 + = unionDocs'' dt1 dt2 + | otherwise + = error + "HashedDocTable.unionDocs: doctables are not disjoint" + where + unionDocs'' :: (DocumentWrapper e) => Documents e -> Documents e -> Documents e + unionDocs'' dt1' dt2' + = mkDocuments $ idToDoc dt1' `DM.union` idToDoc dt2' + + +insert' :: (DocumentWrapper e) => e -> Documents e -> (DocId, Documents e) +insert' d ds + = maybe reallyInsert (const (newId, ds)) (lookup' newId ds) + where + newId + = mkDocId . uri . unwrap $ d + reallyInsert + = (newId, mkDocuments $ DM.insert newId d $ idToDoc ds) + +update' :: (DocumentWrapper e) => DocId -> e -> Documents e -> Documents e +update' i d ds + = mkDocuments $ DM.insert i d $ idToDoc ds + +delete' :: (DocumentWrapper e) => DocId -> Documents e -> Documents e +delete' d ds + = mkDocuments $ DM.delete d $ idToDoc ds + +difference' :: (DocumentWrapper e) => DocIdSet -> Documents e -> Documents e +difference' s ds + = mkDocuments $ idToDoc ds `DM.diffWithSet` s + +map' :: (DocumentWrapper e) => (e -> e) -> Documents e -> Documents e +map' f d + = mkDocuments $ DM.map f (idToDoc d) + +filter' :: (DocumentWrapper e) => (e -> Bool) -> Documents e -> Documents e +filter' p d + = mkDocuments $ DM.filter p (idToDoc d) + +fromMap' :: (DocumentWrapper e) => (Document -> e) -> DocIdMap Document -> Documents e +fromMap' f itd + = mkDocuments $ DM.map f itd + +toMap' :: Documents e -> DocIdMap e +toMap' + = idToDoc + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Index.hs b/src/Hunt/Index.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Index.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- ---------------------------------------------------------------------------- +{- | + The index interface. +-} +-- ---------------------------------------------------------------------------- + + +module Hunt.Index +where + +import Prelude hiding (map) + +import GHC.Exts (Constraint) + +import Control.Arrow (second) + +import qualified Data.List as L + +import Hunt.Common.BasicTypes +import Hunt.Common.DocId +import Hunt.Common.DocIdSet (DocIdSet) +import qualified Hunt.Common.DocIdSet as DS +import Hunt.Common.IntermediateValue + +-- ------------------------------------------------------------ + +-- | The index type class which needs to be implemented to be used by the 'Interpreter'. +-- The type parameter @i@ is the implementation. +-- The implementation must have a value type parameter. +class (IndexValue (IVal i)) => Index i where + -- | The key type of the index. + type IKey i :: * + type IVal i :: * + + type ICon i :: Constraint + type ICon i = () + + -- | General lookup function. + search :: ICon i => TextSearchOp -> IKey i -> i -> [(IKey i, IntermediateValue)] + + searchSc :: ICon i => TextSearchOp -> IKey i -> i -> [(IKey i, (Score, IntermediateValue))] + searchSc op k ix = addDefScore $ search op k ix + + -- | Search within a range of two keys. + lookupRange :: ICon i => IKey i -> IKey i -> i -> [(IKey i, IntermediateValue)] + + lookupRangeSc :: ICon i => IKey i -> IKey i -> i -> [(IKey i, (Score, IntermediateValue))] + lookupRangeSc k1 k2 ix + = addDefScore $ lookupRange k1 k2 ix + + -- | Insert occurrences. + -- This is more efficient than folding with 'insert'. + insertList :: ICon i => + [(IKey i, IntermediateValue)] -> i -> i + + -- | Insert occurrences. + insert :: ICon i => + IKey i -> IntermediateValue -> i -> i + insert k v = insertList [(k,v)] + + -- | Delete as batch job. + -- This is more efficient than folding with 'delete'. + deleteDocs :: ICon i => DocIdSet -> i -> i + + -- | Delete occurrences. + delete :: ICon i => DocId -> i -> i + delete = deleteDocs . DS.singleton + + -- | Empty index. + empty :: ICon i => i + + -- | Convert an index to a list. + -- Can be used for easy conversion between different index implementations. + toList :: ICon i => i -> [(IKey i, IntermediateValue)] + + -- | Convert a list of key-value pairs to an index. + fromList :: ICon i => [(IKey i, IntermediateValue)] -> i + + -- | Merge two indexes with a combining function. + unionWith :: ICon i + => (IVal i -> IVal i -> IVal i) + -> i -> i -> i + + -- Merge two indexes with combining functions. + -- The second index may have another value type than the first one. + -- Conversion and merging of the indexes is done in a single step. + -- This is much more efficient than mapping the second index and calling 'unionWith'. + -- unionWithConv :: (ICon i, ICon i2) + -- => IVal i)2 -> IVal i) -> (v -> v2 -> IVal i) + -- -> i -> i2 -> i + + -- TODO: non-rigid map + -- | Map a function over the values of the index. + map :: ICon i + => (IVal i -> IVal i) + -> i -> i + map f = mapMaybe (Just . f) + + -- | Updates a value or deletes it if the result of the function is 'Nothing'. + mapMaybe :: ICon i + => (IVal i -> Maybe (IVal i)) + -> i -> i + + -- | Keys of the index. + keys :: ICon i + => i -> [IKey i] + +-- ------------------------------------------------------------ + +-- | Monadic version of 'Index'. +-- 'Index' instances are automatically instance of this type class. +class Monad m => IndexM m i where + -- | The key type of the index. + type IKeyM i :: * + + -- | The value type of the index. + type IValM i :: * + + type IConM i :: Constraint + type IConM i = () + + -- | Monadic version of 'search'. + searchM :: IConM i => TextSearchOp -> IKeyM i -> i -> m [(IKeyM i, IntermediateValue)] + + -- | Monadic version of 'search' with (default) scoring. + searchMSc :: IConM i => TextSearchOp -> IKeyM i -> i -> m [(IKeyM i, (Score, IntermediateValue))] + searchMSc op k ix + = searchM op k ix >>= return . addDefScore + + -- | Monadic version of 'lookupRangeM'. + lookupRangeM :: IConM i => IKeyM i -> IKeyM i -> i -> m [(IKeyM i, IntermediateValue)] + + lookupRangeMSc :: IConM i => IKeyM i -> IKeyM i -> i -> m [(IKeyM i, (Score, IntermediateValue))] + lookupRangeMSc k1 k2 ix + = lookupRangeM k1 k2 ix >>= return . addDefScore + + -- | Monadic version of 'insertList'. + insertListM :: IConM i => + [(IKeyM i, IntermediateValue)] -> i -> m (i) + + -- | Monadic version of 'insert'. + insertM :: IConM i => + IKeyM i -> IntermediateValue -> i -> m (i) + insertM k v = insertListM [(k,v)] + + -- | Monadic version of 'deleteDocs'. + deleteDocsM :: IConM i => DocIdSet -> i -> m (i) + + -- | Monadic version of 'delete'. + deleteM :: IConM i => DocId -> i -> m (i) + deleteM k i = deleteDocsM (DS.singleton k) i + + -- | Monadic version of 'empty'. + emptyM :: IConM i => m (i) + + -- | Monadic version of 'toList'. + toListM :: IConM i => i -> m [(IKeyM i, IntermediateValue)] + + -- | Monadic version of 'fromList'. + fromListM :: IConM i => [(IKeyM i, IntermediateValue)] -> m (i) + + -- | Monadic version of 'unionWith'. + unionWithM :: IConM i => + (IValM i -> IValM i -> IValM i) -> + i -> i -> m (i) + + -- Monadic version of 'unionWithConv'. + -- unionWithConvM :: (IConM i, Monad m, IConM i2) + -- => IVal i)2 -> IVal i) -> (v -> v2 -> IVal i) + -- -> i -> i2 -> m (i) + + -- | Monadic version of 'map'. + mapM :: IConM i + => (IValM i -> IValM i) + -> i -> m (i) + mapM f = mapMaybeM (Just . f) + + -- | Monadic version of 'mapMaybe'. + mapMaybeM :: IConM i + => (IValM i -> Maybe (IValM i)) + -> i -> m (i) + + -- | Monadic version of 'keys'. + keysM :: IConM i + => i -> m [IKeyM i] + +-- ------------------------------------------------------------ + +instance (Index i, Monad m) => IndexM m i where + type IKeyM i = IKey i + type IValM i = IVal i + type IConM i = ICon i + + searchM op s i = return $ search op s i + searchMSc op s i = return $ searchSc op s i + lookupRangeM l u i = return $ lookupRange l u i + lookupRangeMSc l u i = return $ lookupRangeSc l u i + insertListM vs i = return $! insertList vs i + deleteDocsM ds i = return $! deleteDocs ds i + insertM k v i = return $! insert k v i + deleteM k i = return $! delete k i + emptyM = return $! empty + toListM i = return $ toList i + fromListM l = return $! fromList l + unionWithM f i1 i2 = return $! unionWith f i1 i2 +-- unionWithConvM f1 f2 i1 i2 = return $! unionWithConv f1 f2 i1 i2 + mapM f i = return $! map f i + mapMaybeM f i = return $! mapMaybe f i + keysM i = return $ keys i + +-- ------------------------------------------------------------ + +addDefScore :: [(a, b)] -> [(a, (Score, b))] +addDefScore = L.map (second (\ x -> (defScore, x))) + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Index/IndexImpl.hs b/src/Hunt/Index/IndexImpl.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Index/IndexImpl.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} + +-- ---------------------------------------------------------------------------- +{- | + Heterogeneous indexes using @ExistentialQuantification@. + + Indexes have to implement the 'Index' type class as well as obey other constraints defined in + 'IndexImplCon'. + + /Note/: Due to the nature of @ExistentialQuantification@, deserialization is tricky because the + concrete implementation is not known. + This is circumvented by storing the type representation of the index. Deserialization is possible + if there is a matching type representation in the set of available types. + This requires the use of the custom get functions. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Index.IndexImpl where + +import Control.Applicative ((<$>)) +import Control.DeepSeq +import Control.Monad + +import Data.Binary +import qualified Data.List as L +import Data.Text (Text) +import Data.Text.Binary () +import Data.Typeable +import Data.Typeable.Binary () + +import Hunt.Common.BasicTypes +import Hunt.Common.IntermediateValue +import Hunt.Index + +-- ------------------------------------------------------------ + +-- | Constraint for index implementations. +type IndexImplCon i + = ( Index i + , Show i + , ICon i + , IndexValue (IVal i) + , Binary i + , Typeable i + , IKey i ~ Text + ) + +-- ------------------------------------------------------------ + +-- | Index using @ExistentialQuantification@ to allow heterogeneous index containers. +data IndexImpl + = forall i. IndexImplCon i => IndexImpl { ixImpl :: i } + +-- ------------------------------------------------------------ + +instance Show IndexImpl where + show (IndexImpl v) = show v + +-- FIXME: not 'rnf v `seq` ()'. is it supposed to be that way? +instance NFData IndexImpl where + rnf (IndexImpl v) = v `seq` () + +-- ------------------------------------------------------------ +-- Serialization + +-- | FIXME: actually implement instance +instance Binary IndexImpl where + put (IndexImpl i) = put (typeOf i) >> put i + get = error "existential types cannot be deserialized this way. Use special get' functions" + +-- TODO: refactor + +-- | Deserialize a set of 'IndexImpl's. Requires a set of available index implementations. +-- +-- /Note/: This will fail if a used index implementation is not provided. +gets' :: [IndexImpl] -> Get [(Context, IndexImpl)] +gets' ts = do + n <- get :: Get Int + go [] n + where + go xs 0 = return $! reverse xs + go xs i = do + x <- liftM2 (,) get (get' ts) + x `seq` go (x:xs) (i-1) + +-- | Deserialize an 'IndexImpl'. Requires a set of available index implementations. +-- +-- /Note/: This will fail if a used index implementation is not provided. +get' :: [IndexImpl] -> Get (IndexImpl) +get' ts = do + t <- get :: Get TypeRep + case L.find (\(IndexImpl i) -> t == typeOf i) ts of + Just (IndexImpl x) -> IndexImpl <$> get `asTypeOf` return x + Nothing -> error $ "Unable to load index of type: " -- ++ show t + +-- ------------------------------------------------------------ + +-- | Wrap an index using @ExistentialQuantification@ to allow heterogeneous containers. +mkIndex :: IndexImplCon i => i -> IndexImpl +mkIndex i = IndexImpl $! i + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Index/InvertedIndex.hs b/src/Hunt/Index/InvertedIndex.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Index/InvertedIndex.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- ---------------------------------------------------------------------------- +{- | + Top-level index implementations with 'Text' keys for + + * text + + * integers + + * dates and + + * geographic positions. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Index.InvertedIndex +{- + ( InvertedIndex (..) + , InvertedIndexDate + , InvertedIndexInt + , InvertedIndexPosition + , InvertedIndexRTree + ) +-- -} +where + +import Prelude as P + +import Control.DeepSeq + +import Data.Bijection.Instances () +import Data.Binary (Binary (..)) +import qualified Data.List as L +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable + +import Hunt.Common.BasicTypes +import Hunt.Common.Occurrences (Occurrences) +import Hunt.Index as Ix +import Hunt.Index.PrefixTreeIndex +import qualified Hunt.Index.PrefixTreeIndex2Dim as PT2D + +import Hunt.Index.Proxy.KeyIndex + + +-- ------------------------------------------------------------ +-- Inverted index using text key +-- ------------------------------------------------------------ + +-- | Text index using a 'StringMap'-implementation. +newtype InvertedIndex + = InvIx { invIx :: KeyProxyIndex Text (DmPrefixTree Occurrences) } + deriving (Eq, Show, NFData, Typeable) + +mkInvIx :: KeyProxyIndex Text (DmPrefixTree Occurrences) + -> InvertedIndex +mkInvIx x = InvIx $! x + +-- ------------------------------------------------------------ + +instance Binary InvertedIndex where + put = put . invIx + get = get >>= return . mkInvIx + +-- ------------------------------------------------------------ + +instance Index InvertedIndex where + type IKey InvertedIndex = Word + type IVal InvertedIndex = Occurrences + + insertList wos (InvIx i) + = mkInvIx $ insertList wos i + + deleteDocs docIds (InvIx i) + = mkInvIx $ deleteDocs docIds i + + empty + = mkInvIx $ empty + + fromList l + = mkInvIx $ fromList l + + toList (InvIx i) + = toList i + + search t k (InvIx i) + = search t k i + + -- here the scoring of found word rel. to searched word is added + searchSc t k m + = L.map scoreWord $ search t k m + where + dist + = similar k + scoreWord (w, r) + = (w, (dist w, r)) + + + lookupRange k1 k2 (InvIx i) + = lookupRange k1 k2 i + + -- for lookupRangeSc the default scoring (all 1.0) is done + -- + -- no better scoring known + + unionWith op (InvIx i1) (InvIx i2) + = mkInvIx $ unionWith op i1 i2 + +{- + unionWithConv to f (InvIx i1) (InvIx i2) + = mkInvIx $ unionWithConv to f i1 i2 +-} + + map f (InvIx i) + = mkInvIx $ Ix.map f i + + mapMaybe f (InvIx i) + = mkInvIx $ Ix.mapMaybe f i + + keys (InvIx i) + = keys i + + +-- ------------------------------------------------------------ + +-- | a simple similarity heuristic for scoring words found +-- when doing a fuzzy or prefix search + +similar :: Text -> Text -> Score +similar s f + = -- traceShow ("similar"::Text, s, f, r) $ + r + where + r = similar' s f + +similar' :: Text -> Text -> Score +similar' searched found + | searched == found + = 1.0 + | ls == lf + = 0.75 + | ls < lf -- reduce score by length of found word + = 0.5 * (fromIntegral ls / fromIntegral lf) + | otherwise -- make similar total + = noScore + where + ls = T.length searched + lf = T.length found + +-- ------------------------------------------------------------ +-- Inverted index using 2-dimensional lookup +-- ------------------------------------------------------------ + +-- | Text index with 2-dimensional lookup using a 'StringMap'-implementation. +newtype InvertedIndex2Dim + = InvIx2D { invIx2D :: KeyProxyIndex Text (PT2D.DmPrefixTree Occurrences) } + deriving (Eq, Show, NFData, Typeable) + +mkInvIx2D :: KeyProxyIndex Text (PT2D.DmPrefixTree Occurrences) + -> InvertedIndex2Dim +mkInvIx2D x = InvIx2D $! x + +-- ------------------------------------------------------------ + +instance Binary InvertedIndex2Dim where + put = put . invIx2D + get = get >>= return . mkInvIx2D + +-- ------------------------------------------------------------ + +instance Index InvertedIndex2Dim where + type IKey InvertedIndex2Dim = Word + type IVal InvertedIndex2Dim = Occurrences + + insertList wos (InvIx2D i) + = mkInvIx2D $ insertList wos i + + deleteDocs docIds (InvIx2D i) + = mkInvIx2D $ deleteDocs docIds i + + empty + = mkInvIx2D $ empty + + fromList l + = mkInvIx2D $ fromList l + + toList (InvIx2D i) + = toList i + + search t k (InvIx2D i) + = search t k i + + -- TODO: searchSc and lookupRangeSc implementation similar to InvertedIndexInt and InvertedIndex + + lookupRange k1 k2 (InvIx2D i) + = lookupRange k1 k2 i + + unionWith op (InvIx2D i1) (InvIx2D i2) + = mkInvIx2D $ unionWith op i1 i2 + +{- + unionWithConv to f (InvIx2D i1) (InvIx2D i2) + = mkInvIx2D $ unionWithConv to f i1 i2 +-} + + map f (InvIx2D i) + = mkInvIx2D $ Ix.map f i + + mapMaybe f (InvIx2D i) + = mkInvIx2D $ Ix.mapMaybe f i + + keys (InvIx2D i) + = keys i + + + diff --git a/src/Hunt/Index/PrefixTreeIndex.hs b/src/Hunt/Index/PrefixTreeIndex.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Index/PrefixTreeIndex.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- ---------------------------------------------------------------------------- +{- | + Text index using the 'DocIdMap' based on the 'StringMap' implementation. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Index.PrefixTreeIndex + ( DmPrefixTree (..) + , SimplePrefixTreeIndex (..) + , PrefixTreeIndexInt (..) + , PrefixTreeIndexDate (..) + ) +where + +import Control.DeepSeq + +import Data.Binary (Binary (..)) +import qualified Data.List as L +import qualified Data.StringMap.Strict as SM +import Data.Typeable +import Data.Bijection +import Data.Bijection.Instances () + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Maybe (fromMaybe) + +import Text.Read (readMaybe) + +import Hunt.Common.BasicTypes +import Hunt.Common.DocIdSet (DocIdSet) +import Hunt.Common.IntermediateValue +import Hunt.Index +import qualified Hunt.Index as Ix +import Hunt.Index.Proxy.KeyIndex + +import Hunt.Utility + +import qualified Hunt.Index.Schema.Normalize.Date as Date +import qualified Hunt.Index.Schema.Normalize.Int as Int + + + + +-- import Debug.Trace + +-- ------------------------------------------------------------ + +-- | Text index using 'DocIdMap' based on the 'StringMap' implementation. +-- Note that the value parameter is on the type of the 'DocIdMap' value and not the 'DocIdSet' +-- itself. + +newtype DmPrefixTree v + = DmPT { dmPT :: SM.StringMap v} + deriving (Eq, Show, NFData, Typeable) + +mkDmPT :: NFData v => SM.StringMap v -> DmPrefixTree v +mkDmPT v = DmPT $! v + +-- ------------------------------------------------------------ + +instance IndexValue v => Binary (DmPrefixTree v) where + put = put . dmPT + get = get >>= return . mkDmPT + +-- ------------------------------------------------------------ + +instance (IndexValue v) => Index (DmPrefixTree v) where + type IKey (DmPrefixTree v) = SM.Key + type IVal (DmPrefixTree v) = v + + insertList kvs (DmPT pt) = + mkDmPT $ L.foldl' (\ m' (k', v') -> SM.insertWith mergeValues k' v' m') pt (fromIntermediates kvs) + + {- this is a nice try, but does not do what it should do, + at least for [("a", occ1), ("a", occ2)] + + mkDmPT $ SM.unionWith op pt (SM.fromList kvs) + -} + + deleteDocs ks (DmPT pt) + = mkDmPT $ SM.mapMaybe (diffValues ks) pt + + empty + = mkDmPT $ SM.empty + + fromList + = mkDmPT . SM.fromList . fromIntermediates + + toList (DmPT pt) + = toIntermediates $ SM.toList pt + + search t k (DmPT pt) + = toIntermediates $ case t of + Case -> case SM.lookup k pt of + Nothing -> [] + Just xs -> [(k,xs)] + NoCase -> luCase k pt + PrefixCase -> pfCase k pt + PrefixNoCase -> pfNoCase k pt + where + toL = SM.toListShortestFirst + luCase = toL .:: SM.lookupNoCase + pfCase = toL .:: SM.prefixFilter + pfNoCase = toL .:: SM.prefixFilterNoCase + + lookupRange k1 k2 (DmPT pt) + = toIntermediates . SM.toList $ SM.lookupRange k1 k2 pt + + unionWith op (DmPT pt1) (DmPT pt2) + = mkDmPT $ SM.unionWith op pt1 pt2 + +{- + unionWithConv to f (DmPT i1) (DmPT i2) + = liftM mkDmPT $ unionWithConv to f i1 i2 +-} + + map f (DmPT pt) + = mkDmPT $ SM.map f pt + + mapMaybe f (DmPT pt) + = mkDmPT $ SM.mapMaybe f pt + + keys (DmPT pt) + = SM.keys pt + +-- ------------------------------------------------------------ +-- Simple minimal PrefixTreeIndex based on the 'StringMap' +-- ------------------------------------------------------------ + +-- | Integer index using a 'StringMap'-implementation. +newtype SimplePrefixTreeIndex + = SimplePTIx { simplePTIx :: KeyProxyIndex Text (DmPrefixTree DocIdSet) } + deriving (Eq, Show, NFData, Typeable) + +mkSimplePTIx :: KeyProxyIndex Text (DmPrefixTree DocIdSet) -> SimplePrefixTreeIndex +mkSimplePTIx x = SimplePTIx $! x + +-- ------------------------------------------------------------ + +instance Binary SimplePrefixTreeIndex where + put = put . simplePTIx + get = get >>= return . mkSimplePTIx + +-- ------------------------------------------------------------ + +instance Index SimplePrefixTreeIndex where + type IKey SimplePrefixTreeIndex = Text + type IVal SimplePrefixTreeIndex = DocIdSet + + insertList wos (SimplePTIx i) + = mkSimplePTIx $ insertList wos i + + deleteDocs docIds (SimplePTIx i) + = mkSimplePTIx $ deleteDocs docIds i + + empty + = mkSimplePTIx $ empty + + fromList l + = mkSimplePTIx $ fromList l + + toList (SimplePTIx i) + = toList i + + search t k (SimplePTIx i) + = search t k i + + searchSc t k m + = L.map scoreWord $ search t k m + where + dist + = similarInt k + scoreWord (w, r) + = (w, (dist w, r)) + + lookupRange k1 k2 (SimplePTIx i) + = lookupRange k1 k2 i + + lookupRangeSc k1 k2 m + = L.map scoreWord $ lookupRange k1 k2 m + where + dist + = similarRangeInt k1 k2 + scoreWord (w, r) + = (w, (dist w, r)) + + unionWith op (SimplePTIx i1) (SimplePTIx i2) + = mkSimplePTIx $ unionWith op i1 i2 + +-- unionWithConv to' f (SimplePTIx i1) (SimplePTIx i2) +-- = mkSimplePTIx $ unionWithConv to' f i1 i2 + + map f (SimplePTIx i) + = mkSimplePTIx $ Ix.map f i + + mapMaybe f (SimplePTIx i) + = mkSimplePTIx $ Ix.mapMaybe f i + + keys (SimplePTIx i) + = keys i + + +-- ------------------------------------------------------------ +-- PrefixTree index using int proxy for numeric data +-- ------------------------------------------------------------ + +-- | Newtype to allow integer normalization 'Bijection' instance. +newtype UnInt = UnInt { unInt :: Text } + deriving (Show, Eq, NFData) + +instance Bijection UnInt Text where + to = Int.denormalizeFromText . unInt + from = UnInt . Int.normalizeToText + +instance Bijection Text UnInt where + to = UnInt + from = unInt + +-- ------------------------------------------------------------ + +-- | Integer index using a 'StringMap'-implementation. +newtype PrefixTreeIndexInt + = InvIntIx { invIntIx :: KeyProxyIndex Text (KeyProxyIndex UnInt (KeyProxyIndex Text (DmPrefixTree DocIdSet))) } + deriving (Eq, Show, NFData, Typeable) + +mkInvIntIx :: KeyProxyIndex Text (KeyProxyIndex UnInt (KeyProxyIndex Text (DmPrefixTree DocIdSet))) -> PrefixTreeIndexInt +mkInvIntIx x = InvIntIx $! x + +-- ------------------------------------------------------------ + +instance Binary PrefixTreeIndexInt where + put = put . invIntIx + get = get >>= return . InvIntIx + +-- ------------------------------------------------------------ + +instance Index PrefixTreeIndexInt where + type IKey PrefixTreeIndexInt = Text + type IVal PrefixTreeIndexInt = DocIdSet + + insertList wos (InvIntIx i) + = mkInvIntIx $ insertList wos i + + deleteDocs docIds (InvIntIx i) + = mkInvIntIx $ deleteDocs docIds i + + empty + = mkInvIntIx $ empty + + fromList l + = mkInvIntIx $ fromList l + + toList (InvIntIx i) + = toList i + + search t k (InvIntIx i) + = search t k i + + searchSc t k m + = L.map scoreWord $ search t k m + where + dist + = similarInt k + scoreWord (w, r) + = (w, (dist w, r)) + + lookupRange k1 k2 (InvIntIx i) + = lookupRange k1 k2 i + + lookupRangeSc k1 k2 m + = L.map scoreWord $ lookupRange k1 k2 m + where + dist + = similarRangeInt k1 k2 + scoreWord (w, r) + = (w, (dist w, r)) + + unionWith op (InvIntIx i1) (InvIntIx i2) + = mkInvIntIx $ unionWith op i1 i2 + +-- unionWithConv to' f (InvIntIx i1) (InvIntIx i2) +-- = mkInvIntIx $ unionWithConv to' f i1 i2 + + map f (InvIntIx i) + = mkInvIntIx $ Ix.map f i + + mapMaybe f (InvIntIx i) + = mkInvIntIx $ Ix.mapMaybe f i + + keys (InvIntIx i) + = keys i + + +similarInt :: Text -> Text -> Score +similarInt searched found + = fromMaybe noScore $ + do s <- readMaybe $ T.unpack searched + f <- readMaybe $ T.unpack found + return $ similarFloat (fromIntegral (s::Int)) (fromIntegral (f::Int)) + +similarRangeInt :: Text -> Text -> Text -> Score +similarRangeInt lbt ubt found + = fromMaybe noScore $ + do lb <- readMaybe $ T.unpack lbt + ub <- readMaybe $ T.unpack ubt + f <- readMaybe $ T.unpack found + return $ similarFloat + (fromIntegral ((lb::Int) + (ub::Int)) / 2.0) + (fromIntegral (f::Int)) + +similarFloat :: Float -> Float -> Score +similarFloat mu + = mkScore . bellCurve (sigma mu) mu + +sigma :: Float -> Float +sigma x + = abs x `max` 10.0 / 10.0 + +-- | Gaussian bell curve for scoring +bellCurve :: Float -> (Float -> Float -> Float) +bellCurve sigma' + = \ mu x -> exp (- (x - mu) ^ _2 / sigma2'2) + where + _2 :: Int + _2 = 2 + sigma2'2 = 2.0 * sigma' ^ _2 + +-- ------------------------------------------------------------ +-- inverted index using date proxy for dates +-- ------------------------------------------------------------ + +-- | Newtype to allow date normalization 'Bijection' instance. +newtype UnDate = UnDate { unDate :: Text } + deriving (Show, Eq, NFData) + +instance Bijection UnDate Text where + to = Date.denormalize . unDate + from = UnDate . Date.normalize + +instance Bijection Text UnDate where + to = UnDate + from = unDate + +-- ------------------------------------------------------------ + +-- | Date index using a 'StringMap'-implementation. +newtype PrefixTreeIndexDate + = InvDateIx { invDateIx :: KeyProxyIndex Text (KeyProxyIndex UnDate (KeyProxyIndex Text (DmPrefixTree DocIdSet))) } + deriving (Eq, Show, NFData, Typeable) + +mkInvDateIx :: KeyProxyIndex Text (KeyProxyIndex UnDate (KeyProxyIndex Text (DmPrefixTree DocIdSet))) -> PrefixTreeIndexDate +mkInvDateIx x = InvDateIx $! x + +-- ------------------------------------------------------------ + +instance Binary PrefixTreeIndexDate where + put = put . invDateIx + get = get >>= return . mkInvDateIx + +-- ------------------------------------------------------------ + +instance Index PrefixTreeIndexDate where + type IKey PrefixTreeIndexDate = Word + type IVal PrefixTreeIndexDate = DocIdSet + + insertList wos (InvDateIx i) + = mkInvDateIx $ insertList wos i + + deleteDocs docIds (InvDateIx i) + = mkInvDateIx $ deleteDocs docIds i + + empty + = mkInvDateIx $ empty + + fromList l + = mkInvDateIx $ fromList l + + toList (InvDateIx i) + = toList i + + search t k (InvDateIx i) + = search t k i + + -- TODO: searchSc and lookupRangeSc implementation similar to PrefixTreeIndexInt and InvertedIndex + + lookupRange k1 k2 (InvDateIx i) + = lookupRange k1 k2 i + + unionWith op (InvDateIx i1) (InvDateIx i2) + = mkInvDateIx $ unionWith op i1 i2 + +-- unionWithConv to' f (InvDateIx i1) (InvDateIx i2) +-- = mkInvDateIx $ unionWithConv to' f i1 i2 + + map f (InvDateIx i) + = mkInvDateIx $ Ix.map f i + + mapMaybe f (InvDateIx i) + = mkInvDateIx $ Ix.mapMaybe f i + + keys (InvDateIx i) + = Ix.keys i diff --git a/src/Hunt/Index/PrefixTreeIndex2Dim.hs b/src/Hunt/Index/PrefixTreeIndex2Dim.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Index/PrefixTreeIndex2Dim.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- ---------------------------------------------------------------------------- +{- | + Text index using the 'DocIdMap' based on the 'StringMap' implementation. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Index.PrefixTreeIndex2Dim +( DmPrefixTree(..) +, PrefixTreeIndexPosition +) +where + +import Control.DeepSeq + +import Data.Binary (Binary (..)) +import Data.Typeable + +import qualified Data.StringMap.Dim2Search as SM2 +import qualified Data.StringMap.Strict as SM +import Data.Bijection +import Data.Bijection.Instances () +import Data.Text (Text) + +import Hunt.Common.BasicTypes +import Hunt.Common.DocIdSet +import Hunt.Common.IntermediateValue +import Hunt.Index +import qualified Hunt.Index as Ix +import Hunt.Index.Proxy.KeyIndex + +import qualified Hunt.Index.Schema.Normalize.Position as Pos + +import Hunt.Utility + +-- ------------------------------------------------------------ + +-- | Text index using 'DocIdMap' based on the 'StringMap' implementation. +-- Note that the value parameter is on the type of the 'DocIdMap' value and not the 'DocIdSet' +-- itself. +newtype DmPrefixTree v + = DmPT { dmPT :: SM.StringMap v } + deriving (Eq, Show, NFData, Typeable) + +mkDmPT :: NFData v => SM.StringMap v -> DmPrefixTree v +mkDmPT v = DmPT $! v + +-- ------------------------------------------------------------ + +instance IndexValue v => Binary (DmPrefixTree v) where + put = put . dmPT + get = get >>= return . mkDmPT + +-- ------------------------------------------------------------ + +instance IndexValue v => Index (DmPrefixTree v) where + type IKey (DmPrefixTree v) = SM.Key + type IVal (DmPrefixTree v) = v + + insertList kvs (DmPT pt) = + mkDmPT $ SM.unionWith mergeValues pt (SM.fromList . fromIntermediates $ kvs) + + deleteDocs ks (DmPT pt) + = mkDmPT $ SM.mapMaybe (diffValues ks) pt + + empty + = mkDmPT $ SM.empty + + fromList + = mkDmPT . SM.fromList . fromIntermediates + + toList (DmPT pt) + = toIntermediates . SM.toList $ pt + + search t k (DmPT pt) + = toIntermediates $ case t of + Case -> case SM.lookup k pt of + Nothing -> [] + Just xs -> [(k,xs)] + NoCase -> luCase k pt + PrefixCase -> pfCase k pt + PrefixNoCase -> pfNoCase k pt + where + toL = SM.toListShortestFirst + luCase = toL .:: SM.lookupNoCase + pfCase = toL .:: SM.prefixFilter + pfNoCase = toL .:: SM.prefixFilterNoCase + + lookupRange k1 k2 (DmPT pt) + = toIntermediates . SM.toList $ SM2.lookupRange k1 k2 pt + + unionWith op (DmPT pt1) (DmPT pt2) + = mkDmPT $ SM.unionWith op pt1 pt2 + +{- + unionWithConv to f (DmPT i1) (DmPT i2) + = liftM mkDmPT $ unionWithConv to f i1 i2 +-} + + map f (DmPT pt) + = mkDmPT $ SM.map f pt + + mapMaybe f (DmPT pt) + = mkDmPT $ SM.mapMaybe f pt + + keys (DmPT pt) + = SM.keys pt + +-- ------------------------------------------------------------ +-- Inverted index using position proxy for geo coordinates +-- ------------------------------------------------------------ + +-- | Newtype to allow position normalization 'Bijection' instance. +newtype UnPos = UnPos { unPos :: Text } + deriving (Show, Eq, NFData) + +instance Bijection UnPos Text where + to = Pos.denormalize . unPos + from = UnPos . Pos.normalize + +instance Bijection Text UnPos where + to = UnPos + from = unPos + +-- ------------------------------------------------------------ + +-- ------------------------------------------------------------ + +-- | Geo-position index using a 'StringMap'-implementation. +-- +newtype PrefixTreeIndexPosition + = InvPosIx { invPosIx :: KeyProxyIndex Text (KeyProxyIndex UnPos (KeyProxyIndex Text (DmPrefixTree DocIdSet))) } + deriving (Eq, Show, NFData, Typeable) + +mkInvPosIx :: KeyProxyIndex Text (KeyProxyIndex UnPos (KeyProxyIndex Text (DmPrefixTree DocIdSet))) -> PrefixTreeIndexPosition +mkInvPosIx x = InvPosIx $! x + +-- ------------------------------------------------------------ + +instance Binary PrefixTreeIndexPosition where + put = put . invPosIx + get = get >>= return . mkInvPosIx + +-- ------------------------------------------------------------ + +instance Index PrefixTreeIndexPosition where + type IKey PrefixTreeIndexPosition = Word + type IVal PrefixTreeIndexPosition = DocIdSet + + insertList wos (InvPosIx i) + = mkInvPosIx $ insertList wos i + + deleteDocs docIds (InvPosIx i) + = mkInvPosIx $ deleteDocs docIds i + + empty + = mkInvPosIx $ Ix.empty + + fromList l + = mkInvPosIx $ Ix.fromList l + + toList (InvPosIx i) + = Ix.toList i + + search t k (InvPosIx i) + = search t k i + + lookupRange k1 k2 (InvPosIx i) + = lookupRange k1 k2 i + + unionWith op (InvPosIx i1) (InvPosIx i2) + = mkInvPosIx $ unionWith op i1 i2 + +-- unionWithConv to' f (InvPosIx i1) (InvPosIx i2) +-- = mkInvPosIx $ unionWithConv to' f i1 i2 + + map f (InvPosIx i) + = mkInvPosIx $ Ix.map f i + + mapMaybe f (InvPosIx i) + = mkInvPosIx $ Ix.mapMaybe f i + + keys (InvPosIx i) + = keys i + diff --git a/src/Hunt/Index/Proxy/KeyIndex.hs b/src/Hunt/Index/Proxy/KeyIndex.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Index/Proxy/KeyIndex.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- ---------------------------------------------------------------------------- + +{- | + Key conversion proxy. + Wraps an index to expose the desired key type. + The conversion is defined by the 'Bijection' implementation. + + This can be used for simple conversions like @Text@ to @String@ or normalization and compression. +-} + +-- ---------------------------------------------------------------------------- + +module Hunt.Index.Proxy.KeyIndex +( KeyProxyIndex (..) +) +where + +import Prelude as P + +import Control.Applicative ((<$>)) +import Control.Arrow (first) +import Control.DeepSeq + +import Data.Bijection +import Data.Binary (Binary (..)) + +import Hunt.Index +import qualified Hunt.Index as Ix +import Hunt.Common.IntermediateValue (IndexValue) +-- ------------------------------------------------------------ + +-- | Key conversion proxy. +-- @toType@ is the desired/exposed key type, followed by the wrapped index type. +-- There has to be a corresponding 'Bijection' instance: +-- +-- > instance Bijection (IKey impl v) toType where ... +newtype KeyProxyIndex toType impl + = KeyProxyIx { keyProxyIx :: impl } + deriving (Eq, Show, NFData) + +-- | Wrap an index in a key conversion proxy. +mkKeyProxyIx :: impl -> KeyProxyIndex toType impl +mkKeyProxyIx v = KeyProxyIx $! v + +-- ------------------------------------------------------------ + +instance Binary (impl) => Binary (KeyProxyIndex toType impl) where + put = put . keyProxyIx + get = get >>= return . mkKeyProxyIx + +-- ------------------------------------------------------------ + +instance (IndexValue (IVal impl)) => Index (KeyProxyIndex toType impl) where + type IKey (KeyProxyIndex toType impl) = toType + type IVal (KeyProxyIndex toType impl) = IVal impl + type ICon (KeyProxyIndex toType impl) = ( Index impl + , ICon impl + , Bijection (IKey impl) toType + ) + + insertList kvs (KeyProxyIx i) + = mkKeyProxyIx $ insertList (P.map (first from) kvs) i + + deleteDocs ks (KeyProxyIx i) + = mkKeyProxyIx $ deleteDocs ks i + + empty + = mkKeyProxyIx $ empty + + fromList l + = mkKeyProxyIx . fromList $ P.map (first from) l + + toList (KeyProxyIx i) + = first to <$> toList i + + search t k (KeyProxyIx i) + = first to <$> search t (from k) i + + lookupRange k1 k2 (KeyProxyIx i) + = first to <$> lookupRange (from k1) (from k2) i + + unionWith op (KeyProxyIx i1) (KeyProxyIx i2) + = mkKeyProxyIx $ unionWith op i1 i2 + +-- unionWithConv t f (KeyProxyIx i1) (KeyProxyIx i2) +-- = mkKeyProxyIx $ unionWithConv t f i1 i2 + + map f (KeyProxyIx i) + = mkKeyProxyIx $ Ix.map f i + + mapMaybe f (KeyProxyIx i) + = mkKeyProxyIx $ Ix.mapMaybe f i + + keys (KeyProxyIx i) + = P.map to $ keys i diff --git a/src/Hunt/Index/RTreeIndex.hs b/src/Hunt/Index/RTreeIndex.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Index/RTreeIndex.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- ---------------------------------------------------------------------------- +{- | + 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.IntermediateValue +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 mergeValues k' v' m') rt (fromIntermediates 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 . fromIntermediates + + toList (DmRT rt) + = toIntermediates . RT.toList $ rt + + -- MBBs don't have any case or prefix + 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 + + -- 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 + +-- ------------------------------------------------------------ + +-- | Date index using a 'StringMap'-implementation. +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 + + diff --git a/src/Hunt/Index/Schema.hs b/src/Hunt/Index/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Index/Schema.hs @@ -0,0 +1,326 @@ +{-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +-- ---------------------------------------------------------------------------- +{- | + Schema for the 'ContextIndex'. + + Every context has a type (e.g. text, int, date, position) and additional schema information. + This includes how keys are splitted and normalized when inserted and searched for. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Index.Schema + ( + -- * Types + Schema + , ContextSchema (..) + , ContextType (..) + , ContextTypes + , CValidator (..) + , CNormalizer (..) + , normalize' + + -- * Default Context Types + , ctText + , ctTextSimple + , ctInt + , ctDate + , ctPosition + , ctPositionRTree + + -- * Default Normalizers + , cnUpperCase + , cnLowerCase + , cnZeroFill + ) +where + +import Control.Applicative +import Control.Monad (mzero) + +import Data.Aeson +import Data.Binary hiding (Word) +import Data.Default +import qualified Data.List as L +import Data.Map hiding (null) +import Data.Maybe (isNothing) +import Data.Text hiding (null) +import qualified Data.Text as T +import Data.Text.Binary () + +import Hunt.Common.BasicTypes +import qualified Hunt.Index as Ix +import Hunt.Index.IndexImpl (IndexImpl, mkIndex) +import Hunt.Index.InvertedIndex +import Hunt.Index.PrefixTreeIndex ( PrefixTreeIndexInt + , PrefixTreeIndexDate + , SimplePrefixTreeIndex ) +import Hunt.Index.PrefixTreeIndex2Dim ( PrefixTreeIndexPosition ) + +import Hunt.Index.RTreeIndex + +import qualified Hunt.Index.Schema.Normalize.Date as Date +import qualified Hunt.Index.Schema.Normalize.Int as Int +import qualified Hunt.Index.Schema.Normalize.Position as Pos +import Hunt.Utility + +-- ------------------------------------------------------------ + +-- | The global schema assigning schema information to each context. +type Schema + = Map Context ContextSchema + +-- | The context schema information. Every context schema has a type and additional to adjust the +-- behavior. +-- +-- The regular expression splits the text into words which are then transformed by the given +-- normalizations functions (e.g. to lower case). + +data ContextSchema = ContextSchema + { + -- | Optional regex to override the default given by context type. + cxRegEx :: Maybe RegEx + -- | Normalizers to apply on keys. + , cxNormalizer :: [CNormalizer] + -- | Context weight to boost results. + , cxWeight :: Weight + -- | Whether the context is searched in queries without context-specifier. + , cxDefault :: Bool + -- | The type of the index (e.g. text, int, date, geo-position). + , cxType :: ContextType + } + deriving Show + +-- ------------------------------------------------------------ + +instance Default ContextSchema where + def = ContextSchema Nothing [] 1.0 True def + +-- ------------------------------------------------------------ + +-- | Set of context types. +type ContextTypes = [ContextType] + +-- | A general context type like text or int. +data ContextType = CType + { + -- | Name used in the (JSON) API. + ctName :: Text + -- | Default regex to split words. + , ctRegEx :: RegEx + -- | Validation function for keys. + , ctValidate :: CValidator + -- | The index implementation used for this type. + , ctIxImpl :: IndexImpl + } + deriving Show + +-- ------------------------------------------------------------ + +instance Default ContextType where + def = ctText + +-- ------------------------------------------------------------ + +-- | Text context type. +ctText :: ContextType +ctText = CType + { ctName = "text" + , ctRegEx = "\\w*" + , ctValidate = def + , ctIxImpl = def + } + +-- | Special text context type +-- smaller index but not phrase queries possible +-- (due to not storing the words positions) +ctTextSimple :: ContextType +ctTextSimple = CType + { ctName = "text-small" + , ctRegEx = "\\w*" + , ctValidate = def + , ctIxImpl = simplePT + } + +-- | Int context type. +ctInt :: ContextType +ctInt = CType + { ctName = "int" + , ctRegEx = "([-]?[0-9]*)" + , ctValidate = CValidator $ Int.isInt + , ctIxImpl = intInv + } + +-- | Date context type. +ctDate :: ContextType +ctDate = CType + { ctName = "date" + , ctRegEx = "[0-9]{4}-((0[1-9])|(1[0-2]))-((0[1-9])|([12][0-9])|(3[01]))" + , ctValidate = CValidator $ Date.isAnyDate . unpack + , ctIxImpl = dateInv + } + +-- | Geographic position context type. +ctPosition :: ContextType +ctPosition = CType + { ctName = "position" + , ctRegEx = "-?(90(\\.0*)?|[1-8]?[0-9](\\.[0-9]*)?)--?((180(\\.0*)?)|(1[0-7][0-9])|([1-9]?[0-9]))(\\.[0-9]*)?" + , ctValidate = CValidator $ Pos.isPosition + , ctIxImpl = positionInv + } + +ctPositionRTree :: ContextType +ctPositionRTree = CType + { ctName = "position-rtree" + , ctRegEx = "-?(90(\\.0*)?|[1-8]?[0-9](\\.[0-9]*)?)--?((180(\\.0*)?)|(1[0-7][0-9])|([1-9]?[0-9]))(\\.[0-9]*)?" + , ctValidate = CValidator $ Pos.isPosition + , ctIxImpl = positionRTree + } + + +-- ------------------------------------------------------------ +-- IndexImpls +-- ------------------------------------------------------------ + +instance Default IndexImpl where + def = defaultInv + +-- ------------------------------------------------------------ + +-- | Default (text) index implementation. +defaultInv :: IndexImpl +defaultInv = mkIndex (Ix.empty :: InvertedIndex) + +-- | Simpler (text) index, which still enables prefix search, +-- but not phrase search anymore. Useful for cases where +-- word positions are not relevant +simplePT :: IndexImpl +simplePT = mkIndex (Ix.empty :: SimplePrefixTreeIndex) + +-- | Int index implementation. +intInv :: IndexImpl +intInv = mkIndex (Ix.empty :: PrefixTreeIndexInt) + +-- | Date index implementation. +dateInv :: IndexImpl +dateInv = mkIndex (Ix.empty :: PrefixTreeIndexDate) + +-- | Geographic position index implementation based on 'StringMap' +positionInv :: IndexImpl +positionInv = mkIndex (Ix.empty :: PrefixTreeIndexPosition) + +-- | Geographic position index implementation based on 'RTree' +positionRTree :: IndexImpl +positionRTree = mkIndex (Ix.empty :: SimpleRTreeIndex) + + +-- ------------------------------------------------------------ +-- Validator +-- ------------------------------------------------------------ + +-- | Validation function for single words. +data CValidator = CValidator { validate :: Word -> Bool } + +-- ------------------------------------------------------------ + +instance Default CValidator where + def = CValidator $ const True + +-- XXX: maybe add name to validator type as well +instance Show CValidator where + show _ = "CValidator" + +-- ------------------------------------------------------------ +-- Normalizer +-- ------------------------------------------------------------ + +-- | Normalizer for words\/keys of an index. +data CNormalizer = CNormalizer + { cnName :: Text -- ^ Name used in (JSON) API. + , normalize :: Text -> Text -- ^ Normalization function. + } + +-- | Apply the normalizers to a word. +normalize' :: [CNormalizer] -> Word -> Word +normalize' ns = L.foldl' (\f2 (CNormalizer _ f1) -> f1 . f2) id $ ns + +-- ------------------------------------------------------------ + +instance Show CNormalizer where + show = unpack . cnName + +instance Default CNormalizer where + def = CNormalizer "" id + +-- | Uppercase normalizer \"UpperCase\". +cnUpperCase :: CNormalizer +cnUpperCase = CNormalizer "UpperCase" T.toUpper + +-- | Lowercase normalizer \"LowerCase\". +cnLowerCase :: CNormalizer +cnLowerCase = CNormalizer "LowerCase" T.toLower + +-- | Int normalizer \"ZeroFill\" to preserve int ordering on strings. +cnZeroFill :: CNormalizer +cnZeroFill = CNormalizer "ZeroFill" Int.normalizeToText + +-- ------------------------------------------------------------ +-- JSON instances +-- ------------------------------------------------------------ + +-- | /Note/: This is only partial (de-)serialization. +-- The other components are environment-dependent +-- and cannot be (de-)serialized. We serialize the name +-- and identify the other compontens of the type later. + +instance FromJSON ContextType where + parseJSON (String s) = return $ def { ctName = s } + parseJSON _ = mzero + +instance ToJSON ContextType where + toJSON (CType n _ _ _) = String n + +instance FromJSON CNormalizer where + parseJSON (String s) = return $ def { cnName = s } + parseJSON _ = mzero + +instance ToJSON CNormalizer where + toJSON (CNormalizer n _) = String n + +instance FromJSON ContextSchema where + parseJSON (Object o) = do + r <- o .:? "regexp" + n <- o .:? "normalizers" .!= [] + w <- o .:? "weight" .!= 1.0 + d <- o .:? "default" .!= True + ct <- o .: "type" + return $ ContextSchema r n w d ct + + parseJSON _ = mzero + +instance ToJSON ContextSchema where + toJSON (ContextSchema r n w d ct) = object' $ + [ "type" .== ct + , "weight" .=? w .\. (== 1.0) + , "regexp" .=? r .\. isNothing + , "normalizers" .=? n .\. null + , "default" .=? d .\. id + ] + +-- ------------------------------------------------------------ +-- Binary instances +-- ------------------------------------------------------------ + +instance Binary ContextSchema where + get = ContextSchema <$> get <*> get <*> get <*> get <*> get + put (ContextSchema a b c d e) = put a >> put b >> put c >> put d >> put e + +instance Binary ContextType where + put (CType n _ _ _) = put n + get = get >>= \n -> return $ def { ctName = n } + +instance Binary CNormalizer where + put (CNormalizer n _) = put n + get = get >>= \n -> return $ def { cnName = n } diff --git a/src/Hunt/Index/Schema/Analyze.hs b/src/Hunt/Index/Schema/Analyze.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Index/Schema/Analyze.hs @@ -0,0 +1,99 @@ +-- ---------------------------------------------------------------------------- +{- | + Analyzer for index data. + Creates raw index data by splitting and normalizing the 'ApiDocument' index data as defined in + the schema. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Index.Schema.Analyze + ( toDocAndWords + , toDocAndWords' + , normalize + , scanTextRE + ) +where + +import Data.DList (DList) +import qualified Data.DList as DL +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromJust, fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T + +import Text.Regex.XMLSchema.String + +import Hunt.Common.ApiDocument +import Hunt.Common.BasicTypes +import Hunt.Common.Document (Document (..), + DocumentWrapper (..)) +import Hunt.Index.Schema + +-- ------------------------------------------------------------ + +-- | Extracts the 'Document' ('DocumentWrapper') and raw index data from an 'ApiDocument' in +-- compliance with the schema. +-- +-- /Note/: Contexts mentioned in the 'ApiDocument' need to exist. + +toDocAndWords :: DocumentWrapper e => Schema -> ApiDocument -> (e, Score, Words) +toDocAndWords s + = ( \ (d, dw, ws) -> (wrap d, dw, ws) ) + . toDocAndWords' s + +-- | Extracts the 'Document' and raw index data from an 'ApiDocument' in compliance with the schema. +-- +-- /Note/: Contexts mentioned in the ApiDoc need to exist. + +toDocAndWords' :: Schema -> ApiDocument -> (Document, Score, Words) +toDocAndWords' schema apiDoc + = (doc, weight, ws) + where + indexMap = adIndex apiDoc + descrMap = adDescr apiDoc + weight = adWght apiDoc + doc = Document + { uri = adUri apiDoc + , desc = descrMap + , wght = toDefScore weight + } + ws = M.mapWithKey + ( \ context content -> + let (ContextSchema rex normalizers _ _ cType) + = fromJust $ M.lookup context schema + (CType _ defRex validator _) + = cType + scan + = filter (validate validator) . scanTextRE (fromMaybe defRex rex) + in + toWordList scan (normalize' normalizers) content + ) + indexMap + +-- | Construct a 'WordList' from text using the splitting and normalization function. + +toWordList :: (Text -> [Word]) -> (Word -> Word) -> Text -> WordList +toWordList scan norm + = M.map DL.toList + . foldr insert M.empty + . zip [1..] + . map norm + . scan + where + insert :: (Position, Word) -> Map Word (DList Position) -> Map Word (DList Position) + insert (p, w) + = M.alter (return . maybe (DL.singleton p) (`DL.snoc` p)) w + +-- | Tokenize a text with a regular expression for words. +-- +-- > scanTextRE "[^ \t\n\r]*" == Data.Text.words +-- +-- Grammar: +scanTextRE :: RegEx -> Text -> [Word] +scanTextRE wRex + = map T.pack + . tokenize (T.unpack wRex) + . T.unpack + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Index/Schema/Normalize/Date.hs b/src/Hunt/Index/Schema/Normalize/Date.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Index/Schema/Normalize/Date.hs @@ -0,0 +1,433 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- ---------------------------------------------------------------------------- + +{- | + Normalization and validation for date. + + Days are represented here as in ISO 8601:2000 Second Edition: + ISO (International Organization for Standardization). + Representations of dates and times, second edition, 2000-12-15. + + NOT as in + ISO 8601 + ISO (International Organization for Standardization). + Representations of dates and times, 1988-06-15. + + The main difference is dealing with year 0. + in the older ISO standard, this is excluded and + "-0001" is the representation of year 1 Before Common Era "-1 BCE". + In the latter standard "0000" represents "-1 BCE" and "-0001" represents "-2 BCE" +-} +-- source hxt-xmlschema/src/Text/XML/HXT/XMLSchema/W3CDataTypeCheck.hs + +-- ---------------------------------------------------------------------------- + +module Hunt.Index.Schema.Normalize.Date + ( normalize, denormalize + , isAnyDate + , isAnyDate' + , isTime + , nullDay + , showGYearMonth + , showGYear + , showGMonthDay + , showGMonth + , showGDay + , showTime + ) +where + +import Control.Applicative +import Control.Monad + +import Data.List +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T + +import Data.Char (isDigit) +import Data.Function (on) +import Data.Ratio ((%)) +import Data.Time (Day, DiffTime, UTCTime (..), + addUTCTime, fromGregorian) + +import Text.Regex.XMLSchema.String + +import Hunt.Utility + +-- ------------------------------------------------------------ + +-- | Normalize a date representation to store in the index or search for. +normalize :: Text -> Text +normalize t = fromMaybe t + (T.pack . normDateRep . showDateTime . toUTC <$> (readAnyDateM . T.unpack $ t)) + where + -- XXX: no proper support for dates before year 0 (1 BCE) this way + normDateRep :: String -> String + normDateRep s + = if head' s == Just '-' + then ('-':) . fil . tail $ s + else fil s + where fil = filter (not . (`elem` "-T:")) + +-- | Function takes normalized Date and transforms it back a readable form. +-- We don't transform it back to the original representation, since that +-- is never used, but to a general readable date format +denormalize :: Text -> Text +denormalize t = T.concat [y1, y2, "-", m, "-", d, " ", h, ":", i, ":", s] + where + [y1,y2,m,d,h,i,s] = T.chunksOf 2 t + +-- ------------------------------------------------------------ + +-- | Checks if the string is a date representation (syntactically). +isAnyDate :: String -> Bool +isAnyDate s = any ($ s) $ map fst safeDateReaders + +-- XXX: generally (showDate . readAnyDate) /= id +-- | Same as 'isAnyDate' but also checks if @(showDate . readAnyDate)@ produces the same result. +-- /NOTE/: excludes dates before year 0 (1 BCE). +isAnyDate' :: String -> Bool +isAnyDate' s = fromMaybe False $ do + d <- readAnyDateM s + guard $ ((==s) . showDate . readAnyDate) s + return . not . isPrefixOf "-" . showDate . toUTC $ d + +-- | Unsafe 'readAnyDateM'. +readAnyDate :: String -> Date +readAnyDate = fromJust . readAnyDateM + +-- | Try to read a date. +readAnyDateM :: String -> Maybe Date +readAnyDateM s = head' . catMaybes . map readDateM $ safeDateReaders + where + readDateM :: (String -> Bool, String -> Date) -> Maybe Date + readDateM (v, r) = guard (v s) >> return (r s) + +-- | Tuples of date validator and reader. +safeDateReaders :: [(String -> Bool, String -> Date)] +safeDateReaders = zip validators readers + where + validators :: [String -> Bool] + validators = [ isDateTime, isDate, isGYearMonth, isGYear, isGMonthDay, isGMonth, isGDay] + readers :: [String -> Date] + readers = [readDateTime, readDate, readGYearMonth, readGYear, readGMonthDay, readGMonth, readGDay] + +-- ------------------------------------------------------------ + +-- source hxt-xmlschema/src/Text/XML/HXT/XMLSchema/W3CDataTypeCheck.hs + +-- ---------------------------------------- +-- +-- Days are represented here +-- as in ISO 8601:2000 Second Edition: +-- ISO (International Organization for Standardization). +-- Representations of dates and times, second edition, 2000-12-15. +-- +-- NOT as in +-- ISO 8601 +-- ISO (International Organization for Standardization). +-- Representations of dates and times, 1988-06-15. +-- +-- The main difference is dealing with year 0. +-- in the older ISO standard, this is excluded and +-- "-0001" is the representation of year 1 Before Common Era "-1 BCE". +-- In the latter standard "0000" represents "-1 BCE" and "-0001" represents "-2 BCE" + +data Date = + Date { _dUTCTime :: UTCTime + , _dTZ :: MaybeTimeZone + } + deriving (Show) + +type MaybeTimeZone = Maybe Seconds + +type Seconds = Int + +instance Eq Date where + (==) = (==) `on` toUTCTime + +instance Ord Date where + compare = compare `on` toUTCTime + +mkDateTime :: Day -> DiffTime -> MaybeTimeZone -> Date +mkDateTime d t z + = Date (UTCTime d t) z + +toUTCTime :: Date -> UTCTime +toUTCTime (Date d Nothing) = d +toUTCTime (Date d (Just tz)) = addUTCTime (fromInteger . toInteger $ tz) d + +-- | Convert to UTC time. Eliminates the timezone offset. +toUTC :: Date -> Date +toUTC d = Date (toUTCTime d) Nothing -- to UTC + +-- ------------------------------------------------------------ + +isDateTime, isDate, isTime, isGYearMonth, isGYear, isGMonthDay, isGMonth, isGDay :: String -> Bool +[isDateTime, isDate, isTime, isGYearMonth, isGYear, isGMonthDay, isGMonth, isGDay] + = map matchRE rexDates + + +rexDates :: [Regex] +rexDates + = map rex [dateTime, date, time, gYearMonth, gYear, gMonthDay, gMonth, gDay] + where + dateTime = ymd ++ "T" ++ hms ++ tz + time = hms ++ tz + date = ymd ++ tz + gYearMonth = ym ++ tz + gYear = y ++ tz + + gMonthDay = "--" ++ m2 ++ "-" ++ t2 ++ tz + gMonth = "--" ++ m2 ++ tz + gDay = "--" ++ "-" ++ t2 ++ tz + + y = "-?" ++ y4' + ym = y ++ "-" ++ m2 + ymd = ym ++ "-" ++ t2 + + hms = alt (h2 ++ ":" ++ i2 ++ ":" ++ s2 ++ fr) + ("24:00:00" ++ opt ".0+") -- 24:00 is legal + + tz = opt (alt tz0 "Z") + tz0 = (alt "\\-" "\\+") ++ tz1 + tz1 = alt (h13 ++ ":" ++ i2) "14:00:00" + + m2 = alt "0[1-9]" "1[0-2]" -- Month + t2 = alt "0[1-9]" (alt "[12][0-9]" "3[01]") -- Tag + h2 = alt "[01][0-9]" "2[0-3]" -- Hour + i2 = "[0-5][0-9]" -- mInute + s2 = i2 -- Seconds + +{- -- this conforms to ISO 8601 from 1988 + y1 = "000[1-9]" -- "0000" isn't a year, "-0001" represents "-1 BCE" + y2 = "00[1-9][0-9]" -- leading 0-s are only allowd for year < 1000 + y3 = "0[1-9][0-9]{2}" + y4 = "[1-9][0-9]{3,}" + y4' = alt y4 $ alt y3 $ alt y2 y1 +-- -} + +-- {- -- this conforms to ISO 8601 Second Edition from 2000 + y4 = "[0-9]{4}" -- year "0000" is legal and represents "-1 BCE" + y4' = opt "[1-9][0-9]*" ++ y4 +-- -} + + fr = opt ".[0-9]+" + + h13 = alt "0[0-9]" "1[0-3]" + + opt x = "(" ++ x ++ ")?" + alt x1 x2 = "((" ++ x1 ++ ")|(" ++ x2 ++ "))" + + +-- ------------------------------------------------------------ + +readDate + , readGYearMonth + , readGYear + , readGMonthDay + , readGMonth + , readGDay :: String -> Date + +readDate = readDate' readYearMonthDayS +readGYearMonth = readDate' readYearMonthS +readGYear = readDate' readYearS +readGMonthDay = readDate' readMonthDayS +readGMonth = readDate' readMonthS +readGDay = readDate' readDayS + + +readTimeZone :: String -> MaybeTimeZone +readTimeZone "" + = Nothing +readTimeZone "Z" + = Just 0 +readTimeZone (s : xs) + = Just . + ( if s == '-' then negate else id ) . + readZone $ xs + where + readZone s' + = 60 * (60 * read hs + read ms) + where + (hs, (_ : ms)) = span (/= ':') s' + +readYearMonthDayS :: String -> (Day, String) +readYearMonthDayS s0 + = (fromGregorian (sign $ read year) (read month) (read day), rest) + where + (sign, s ) = if head s0 == '-' + then (negate, tail s0) + else (id, s0) + (year, (_ : rest1)) = span (/= '-') s + (month, (_ : rest2)) = span (/= '-') rest1 + (day, rest ) = span isDigit rest2 + +readYearMonthS :: String -> (Day, String) +readYearMonthS s0 + = (fromGregorian (sign $ read year) (read month) 1, rest) + where + (sign, s ) = if head s0 == '-' + then (negate, tail s0) + else (id, s0) + (year, (_ : rest1)) = span (/= '-') s + (month, rest ) = span isDigit rest1 + +readYearS :: String -> (Day, String) +readYearS s0 + = (fromGregorian (sign $ read year) 1 1, rest) + where + (sign, s ) = if head s0 == '-' + then (negate, tail s0) + else (id, s0) + (year, rest ) = span isDigit s + +readMonthDayS :: String -> (Day, String) +readMonthDayS s0 + = (fromGregorian 1 (read month) (read day), rest) + where + (month, (_ : rest1)) = span isDigit . drop 2 $ s0 + (day, rest ) = span isDigit rest1 + +readMonthS :: String -> (Day, String) +readMonthS s0 + = (fromGregorian 1 (read month) 1, rest) + where + (month, rest ) = span isDigit . drop 2 $ s0 + +readDayS :: String -> (Day, String) +readDayS s0 + = (fromGregorian 1 1 (read day), rest) + where + (day, rest ) = span isDigit . drop 3 $ s0 + +readHourMinSec :: String -> DiffTime +readHourMinSec s + = fromInteger (60 * (60 * read hours + read minutes)) + + + fromRational (readDecimal seconds) + where + (hours, (_ : rest)) = span (/= ':') s + (minutes, (_ : seconds)) = span (/= ':') rest + +readDateTime :: String -> Date +readDateTime s + = mkDateTime day (readHourMinSec time) (readTimeZone zone) + where + (day, (_ : rest)) = readYearMonthDayS s + (time, zone) = span (\ x -> isDigit x || x `elem` ":.") rest + + +readDate' :: (String -> (Day, String)) -> String -> Date +readDate' read' s + = mkDateTime day nullTime (readTimeZone zone) + where + (day, zone) = read' s + +nullTime :: DiffTime +nullTime = fromInteger 0 + +nullDay :: Day +nullDay = fromGregorian 1 1 1 + +-- ---------------------------------------- + +-- | Reads a decimal from a string + +readDecimal :: String -> Rational +readDecimal ('+':s) = readDecimal' s +readDecimal ('-':s) = negate $ readDecimal' s +readDecimal s = readDecimal' s + +-- | Helper function to read a decimal from a string +readDecimal' :: String -> Rational +readDecimal' s + | f == 0 = (n % 1) + | otherwise = (n % 1) + (f % (10 ^ (toInteger $ length fs))) + where + (ns, fs') = span (/= '.') s + fs = drop 1 fs' + + f :: Integer + f | null fs = 0 + | otherwise = read fs + n :: Integer + n | null ns = 0 + | otherwise = read ns + +-- -------------------- +-- the show must go on + +showDateTime :: Date -> String +showDateTime (Date d tz) + = ymd ++ "T" ++ hms ++ showTimeZone tz + where + (ymd : hms : _) = words . show $ d + +showDate' :: (String -> String) -> Date -> String +showDate' fmt (Date d tz) + = fmt ymd ++ showTimeZone tz + where + (ymd : _) = words . show $ d + +dropRev :: Int -> String -> String +dropRev i = reverse . drop i . reverse + +showDate :: Date -> String +showDate = showDate' $ id + +showGYearMonth :: Date -> String +showGYearMonth = showDate' $ dropRev 3 + +showGYear :: Date -> String +showGYear = showDate' $ dropRev 6 + +showGMonthDay :: Date -> String +showGMonthDay = showDate' $ ('-' :) . reverse . take 6 . reverse + +showGMonth :: Date -> String +showGMonth = showDate' $ ('-' :) . reverse . take 3 . drop 3 . reverse + +showGDay :: Date -> String +showGDay = showDate' $ ('-' :) . ('-' :) . reverse . take 3 . reverse + +-- it's +showTime :: Date -> String +showTime (Date d tz) + = hms ++ showTimeZone tz + where + (_ymd : hms : _) = words . show $ d + +showTimeZone :: MaybeTimeZone -> String +showTimeZone Nothing + = "" +showTimeZone (Just s) + | s == 0 = "Z" + | s > 0 = '+' : showHourMin s + | otherwise = '-' : showHourMin (negate s) + +showHourMin :: Int -> String +showHourMin s0 + = showDec 2 (s `div` 60) ++ ":" ++ showDec 2 (s `mod` 60) + where + s = s0 `div` 60 + +showDec :: Int -> Int -> String +showDec n = reverse . toStr n + where + toStr 0 _ = "" + toStr l i = show (i `mod` 10) ++ toStr (l-1) (i `div` 10) + +-- ------------------------------------------------------------ + +-- | Creates a regex from a string +rex :: String -> Regex +rex regex + | isZero ex = error $ "syntax error in regexp " ++ show regex ++ "." + | otherwise = ex + where + ex = parseRegex regex + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Index/Schema/Normalize/Int.hs b/src/Hunt/Index/Schema/Normalize/Int.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Index/Schema/Normalize/Int.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- ---------------------------------------------------------------------------- +{- | + Normalization and validation for integer. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Index.Schema.Normalize.Int + ( normalizeToText, denormalizeFromText + , normalizeToInt, denormalizeFromInt + , isInt, integer + ) +where + +import Data.Text (Text) +import qualified Data.Text as T + +import Control.Applicative hiding ((<|>)) +import Hunt.Common.BasicTypes +import Text.ParserCombinators.Parsec + +-- ------------------------------------------------------------ +-- Normalize Int to actual Int +-- ------------------------------------------------------------ + +-- | Normalize an integer to an 'Int'. +normalizeToInt :: Text -> Int +normalizeToInt = getInt + +-- | Denormalize an integer. +denormalizeFromInt :: Int -> Text +denormalizeFromInt = T.pack . show + +-- ------------------------------------------------------------ +-- Normalize Int as Text +-- ------------------------------------------------------------ + +-- | Normalize a /valid/ integer to a 'Text' representation preserving ordering. +normalizeToText' :: Word -> Word +normalizeToText' i + = T.concat [pfx, zeros, nr] + where + (pfx,nr) = if T.take 1 i == "-" + then ("0", T.drop 1 i) + else ("1", i) + elems = 20 - T.length nr + zeros = T.replicate elems "0" + +-- | Normalize an integer to a 'Text' representation preserving ordering. +normalizeToText :: Text -> Text +normalizeToText t + = if isInt t + then normalizeToText' t + else error "normalizeToText: invalid input" + +-- | Denormalize a value transformed with 'normalize'. +denormalizeFromText :: Text -> Text +denormalizeFromText i + = sign raw + where + sign = if T.take 1 i == "1" then id else ('-' `T.cons`) + raw = T.dropWhile (== '0') $ T.drop 1 i + +-- ------------------------------------------------------------ +-- Validate int +-- ------------------------------------------------------------ + +-- | Parse a /valid/ integer. +-- +-- /Note/: This will fail on invalid integers. +getInt :: Text -> Int +getInt int = case parse integer "" $ T.unpack int of + Right pint -> pint + _ -> error "getInt: invalid input" + +-- | Validate if the text represents a valid integer. +-- Needs to be within 'Int' range. +isInt :: Text -> Bool +isInt int = case parse integer "" $ T.unpack int of + Right pint -> int == (T.pack . show $ pint) + _ -> False + +-- | Parse a simple integer representation. +integer :: Parser Int +integer = rd <$> (plus <|> minus <|> number) + where + rd = read :: String -> Int + plus = char '+' *> number + minus = (:) <$> char '-' <*> number + number = many1 digit + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Index/Schema/Normalize/Position.hs b/src/Hunt/Index/Schema/Normalize/Position.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Index/Schema/Normalize/Position.hs @@ -0,0 +1,199 @@ +-- ---------------------------------------------------------------------------- +{- | + Normalization and validation for geographic positions. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Index.Schema.Normalize.Position + ( normalize, denormalize + , isPosition, position + ) +where + +import Numeric + +import Control.Applicative hiding ((<|>)) + +import Data.Text (Text) +import qualified Data.Text as T + + +import Text.Parsec +import Text.ParserCombinators.Parsec + +import Hunt.Utility + +-- ------------------------------------------------------------ +-- validator +-- ------------------------------------------------------------ + +-- | Checks if value is a valid position. +-- A valid position has a format like "double-double"/"latitude-longitude". +isPosition :: Text -> Bool +isPosition pos = isRight . parse position "" $ T.unpack pos + +-- | Parse a coordinate. +position :: Parser (Double, Double) +position = do + lat <- latitude + _ <- char '-' + long <- longitude + return (lat,long) + +-- | Parse a latitude value. +latitude :: Parser Double +latitude = do + pos <- double + if pos > -90 && pos < 90 + then return pos + else fail "latitude out of bounds" + +-- | Parse a longitude value. +longitude :: Parser Double +longitude = do + pos <- double + if pos > -180 && pos < 180 + then return pos + else fail "longitude out of bounds" + +-- ------------------------------------------------------------ +-- normalizer +-- ------------------------------------------------------------ + +-- | Normalizes valid position +-- A valid position has a format like "double-double"/"latitude-longitude". +normalize :: Text -> Text +normalize pos + = case parse position "" $ T.unpack pos of + Right (la,lo) -> T.pack $ intersectPos (format la) (format lo) + Left _ -> error "normalize positon: invalid position" + where + format :: Double -> String + format v = dec2bin $ round (v * 10000000) + + +-- | Denormalizes internal position into valid position. +-- A valid position has a format like "double-double"/"latitude-longitude". +denormalize :: Text -> Text +denormalize pos + = T.pack . show' d1 . ('-':) . show' d2 $ "" + where + (d1,d2) = ( fromIntegral i1 / 10000000 + , fromIntegral i2 / 10000000 + ) :: (Double,Double) + (i1,i2) = ( bin2dec odds + , bin2dec evens + ) + + (odds,evens) = oddsAndEvens sPos + + oddsAndEvens o = case o of + (x1:x2:xs) -> let (y1,y2) = oddsAndEvens xs in (x1:y1,x2:y2) + (x1:xs) -> let (y1,y2) = oddsAndEvens xs in (x1:y1,y2) + [] -> ([],[]) + + sPos = T.unpack pos + + show' = showFFloat (Just 7) + +-- ------------------------------------------------------------ +-- normalizer helper +-- ------------------------------------------------------------ + +-- | Decimal representation of a binary encoded string. +-- +-- /Note/: The input needs to be valid. +-- @length input >= 2 && all (`elem` "01") input@ +bin2dec :: String -> Int +bin2dec (s:i) + = sign dec + where + dec = fst . head . readInt 2 isbc c2b $ i + sign = if s == '0' then negate else id +bin2dec [] + = error "bin2dec: empty String" + +-- | Convert Integer to Binary and normalize result +-- with leading zeros to a length of 32 characters. +-- The first character is the sign: 0 -> negative. +-- +-- /Note/: The input needs to be valid. +dec2bin :: Integer -> String +dec2bin i = sign . zeros . bin $ "" + where + sign, zeros, bin :: ShowS + (sign,n) = if i < 0 then (('0':),-i) else (('1':),i) + bin = showIntAtBase 2 b2c n + zeros s = foldr (\ _ xs -> '0' : xs) s [1..elems] + where elems = 31 - length s + +-- | Merge two lists starting with an element of the first list, then one +-- of the second list and so on. +-- Works like @concat . zipWith (\a b -> a:b:[])@, but pads with zeros. +intersectPos :: String -> String -> String +intersectPos (x:xs) (y:ys) = x : y : intersectPos xs ys +intersectPos (x:xs) [] = x : '0' : intersectPos xs [] +intersectPos [] (y:ys) = '0' : y : intersectPos [] ys +intersectPos _ _ = [] + +{- +-- ShowS version with accumulator - unnecessary +intersectPos :: String -> String -> ShowS +intersectPos la lo = foldPos' la lo id + where + foldPos' (x:xs) (y:ys) a = foldPos' xs ys (\s -> a (x : y : s)) + foldPos' (x:xs) [] a = foldPos' xs "" (\s -> a (x : '0' : s)) + foldPos' [] (y:ys) a = foldPos' "" ys (\s -> a ('0' : y : s)) + foldPos' [] [] a = a +-} + +-- ------------------------------------------------------------ +-- Int to binary and vice versa +-- ------------------------------------------------------------ + +-- | Binary integer to character. +b2c :: Int -> Char +b2c i = case i of + 0 -> '0' + 1 -> '1' + _ -> error "b2c i with i `notElem` [0,1]" + +-- | Character to binary integer. +c2b :: Char -> Int +c2b o = case o of + '0' -> 0 + '1' -> 1 + _ -> error "c2b c with c `notElem` \"01\"" + +-- | Is the character a binary number. +isbc :: Char -> Bool +isbc = (`elem` "01") + +-- ------------------------------------------------------------ +-- parser helper +-- ------------------------------------------------------------ + +number :: Parser String +number = many1 digit + +plus :: Parser String +plus = char '+' *> number + +minus :: Parser String +minus = char '-' <:> number + +integer :: Parser String +integer = plus <|> minus <|> number + +double :: Parser Double +double = fmap rd $ integer <++> decimal + where rd = read :: String -> Double + decimal = option "" $ char '.' <:> number + +(<++>) :: Applicative f => f [a] -> f [a] -> f [a] +(<++>) a b = (++) <$> a <*> b + +(<:>) :: Applicative f => f a -> f [a] -> f [a] +(<:>) a b = (:) <$> a <*> b + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Interpreter.hs b/src/Hunt/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Interpreter.hs @@ -0,0 +1,820 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +-- ---------------------------------------------------------------------------- +{- | + The interpreter to evaluate 'Command's. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Interpreter + ( -- * Initialization + initHunt + -- * Running Commands + , runCmd + , execCmd + , runHunt + -- * Types + , Hunt + , HuntT (..) + , HuntEnv (..) + , DefHuntEnv + ) +where + +import Control.Applicative +import Control.Arrow (second) +import Control.Concurrent.XMVar +import Control.Monad.Error +import Control.Monad.Reader + +import Data.Aeson (ToJSON (..), object, (.=)) +import Data.Binary (Binary, encodeFile) +import qualified Data.ByteString.Lazy as BL +import Data.Default +import qualified Data.List as L +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Traversable as TV + +import Hunt.Common +import Hunt.Common.ApiDocument as ApiDoc +import qualified Hunt.Common.DocDesc as DocDesc +import qualified Hunt.Common.DocIdSet as DocIdSet +import Hunt.ContextIndex (ContextIndex (..), ContextMap) +import qualified Hunt.ContextIndex as CIx +import Hunt.DocTable (DValue, DocTable) +import qualified Hunt.DocTable as DocTable +import Hunt.DocTable.HashedDocTable +import qualified Hunt.Index as Ix +import Hunt.Index.IndexImpl (IndexImpl (..), mkIndex) +import Hunt.Index.Schema.Analyze +import Hunt.Interpreter.BasicCommand +import Hunt.Interpreter.Command (Command) +import Hunt.Interpreter.Command hiding (Command (..)) +import Hunt.Query.Intermediate (ScoredDocs, ScoredWords, + UnScoredDocs, toDocIdSet, + toDocsResult, RankedDoc(..), + toDocumentResultPage, + toWordsResult) +import Hunt.Query.Language.Grammar +import Hunt.Query.Processor (ProcessConfig (..), + initProcessor, + processQueryScoredDocs, + processQueryScoredWords, + processQueryUnScoredDocs) +import Hunt.Query.Ranking +import Hunt.Utility (showText) +import Hunt.Utility.Log + +import System.IO.Error (isAlreadyInUseError, + isDoesNotExistError, + isFullError, isPermissionError, + tryIOError) +import qualified System.Log.Logger as Log + +import GHC.Stats (getGCStats, getGCStatsEnabled) +import GHC.Stats.Json () + +{- OLD +import Data.Function (on) +import Data.List (sortBy) +import qualified Hunt.Common.DocIdMap as DocIdMap +import Hunt.Common.Document (DocumentWrapper, setScore, unwrap) +import Hunt.Utility +import Hunt.Query.Result (DocInfo (..), Result (..), WordInfo (..), + WordInfoAndHits (..)) +import Hunt.Query.Processor (processQuery, + processQueryDocIds) +-- -} +-- ------------------------------------------------------------ +-- +-- the semantic domains (datatypes for interpretation) +-- +-- HuntEnv, Index, ... + +-- ------------------------------------------------------------ +-- +-- the indexer used in the interpreter +-- this should be a generic interpreter in the end +-- but right now its okay to have the indexer +-- replaceable by a type declaration + +-- ------------------------------------------------------------ +-- Logging + +-- TODO: manage exports + +-- | Name of the module for logging purposes. +modName :: String +modName = "Hunt.Interpreter" + +-- | Log a message at 'DEBUG' priority. +debugM :: MonadIO m => String -> m () +debugM = liftIO . Log.debugM modName +{- +-- | Log a message at 'WARNING' priority. +warningM :: MonadIO m => String -> m () +warningM = liftIO . Log.warningM modName +-} +-- | Log a message at 'ERROR' priority. +errorM :: MonadIO m => String -> m () +errorM = liftIO . Log.errorM modName + +{- +-- | Log formated values that get inserted into a context +debugContext :: Context -> Words -> IO () +debugContext c ws = debugM $ concat ["insert in ", T.unpack c, show . M.toList $ fromMaybe M.empty $ M.lookup c ws] +-- -} + +-- ------------------------------------------------------------ + +-- | The Hunt state and environment. +-- Initialize with default values with 'initHunt'. +data HuntEnv dt = HuntEnv + { -- | The context index (indexes, document table and schema). + -- Stored in an 'XMVar' so that read access is always possible. + huntIndex :: DocTable dt => XMVar (ContextIndex dt) + -- | Ranking configuration. + , huntRankingCfg :: RankConfig (DValue dt) + -- | Available context types. + , huntTypes :: ContextTypes + -- | Available normalizers. + , huntNormalizers :: [CNormalizer] + -- | Query processor configuration. + , huntQueryCfg :: ProcessConfig + } + +-- | Default Hunt environment type. +type DefHuntEnv = HuntEnv (Documents Document) + +-- | Initialize the Hunt environment with default values. +initHunt :: DocTable dt => IO (HuntEnv dt) +initHunt = initHuntEnv CIx.empty defaultRankConfig contextTypes normalizers def + +-- | Default context types. +contextTypes :: ContextTypes +contextTypes = [ctText, ctInt, ctDate, ctPosition, ctTextSimple, ctPositionRTree] + +-- | Default normalizers. +normalizers :: [CNormalizer] +normalizers = [cnUpperCase, cnLowerCase, cnZeroFill] + +-- | Initialize the Hunt environment. +initHuntEnv :: DocTable dt + => ContextIndex dt + -> RankConfig (DValue dt) + -> ContextTypes + -> [CNormalizer] + -> ProcessConfig + -> IO (HuntEnv dt) +initHuntEnv ixx rnk opt ns qc = do + ixref <- newXMVar ixx + return $ HuntEnv ixref rnk opt ns qc + +-- ------------------------------------------------------------ +-- Command evaluation monad +-- ------------------------------------------------------------ + +-- | The Hunt transformer monad. Allows a custom monad to be embedded to combine with other DSLs. + +newtype HuntT dt m a + = HuntT { runHuntT :: ReaderT (HuntEnv dt) (ErrorT CmdError m) a } + deriving + (Applicative, Monad, MonadIO, Functor, MonadReader (HuntEnv dt), MonadError CmdError) + +instance MonadTrans (HuntT dt) where + lift = HuntT . lift . lift + +-- | The Hunt monad on 'IO'. +type Hunt dt = HuntT dt IO + +-- ------------------------------------------------------------ + +-- | Run the Hunt monad with the supplied environment/state. + +runHunt :: DocTable dt => HuntT dt m a -> HuntEnv dt -> m (Either CmdError a) +runHunt env = runErrorT . runReaderT (runHuntT env) + +-- | Run the command the supplied environment/state. +runCmd :: (DocTable dt, Binary dt) => HuntEnv dt -> Command -> IO (Either CmdError CmdResult) +runCmd env cmd + = runErrorT . runReaderT (runHuntT . execCmd $ cmd) $ env + +-- | Get the context index. +askIx :: DocTable dt => Hunt dt (ContextIndex dt) +askIx = do + ref <- asks huntIndex + liftIO $ readXMVar ref + +-- FIXME: io exception-safe? +-- | Modify the context index. +modIx :: DocTable dt + => (ContextIndex dt -> Hunt dt (ContextIndex dt, a)) -> Hunt dt a +modIx f = do + ref <- asks huntIndex + ix <- liftIO $ takeXMVarWrite ref + (i',a) <- f ix `catchError` putBack ref ix + liftIO $ putXMVarWrite ref i' + return a + where + putBack ref i e = do + liftIO $ putXMVarWrite ref i + throwError e + +-- | Modify the context index. +-- Locks the index for reads and writes to prevent excessive memory usage. +-- +-- /Note/: This does not fix the memory issues on load entirely because the old index might +-- still be referenced by a concurrent read operation. +modIxLocked :: DocTable dt + => (ContextIndex dt -> Hunt dt (ContextIndex dt, a)) -> Hunt dt a +modIxLocked f = do + ref <- asks huntIndex + ix <- liftIO $ takeXMVarLock ref + (i',a) <- f ix `catchError` putBack ref ix + liftIO $ putXMVarLock ref i' + return a + where + putBack ref i e = do + liftIO $ putXMVarLock ref i + throwError e + +-- | Do something with the context index. +withIx :: DocTable dt => (ContextIndex dt -> Hunt dt a) -> Hunt dt a +withIx f + = askIx >>= f + +-- | Get the type of a context. +askType :: DocTable dt => Text -> Hunt dt ContextType +askType cn = do + ts <- asks huntTypes + case L.find (\t -> cn == ctName t) ts of + Just t -> return t + _ -> throwResError 410 ("used unavailable context type: " `T.append` cn) + +-- | Get the normalizer of a context. +askNormalizer :: DocTable dt => Text -> Hunt dt CNormalizer +askNormalizer cn = do + ts <- asks huntNormalizers + case L.find (\t -> cn == cnName t) ts of + Just t -> return t + _ -> throwResError 410 ("used unavailable normalizer: " `T.append` cn) + +-- | Get the index. +askIndex :: DocTable dt => Text -> Hunt dt IndexImpl +askIndex cn = ctIxImpl <$> askType cn + +-- | Throw an error in the Hunt monad. +throwResError :: DocTable dt => Int -> Text -> Hunt dt a +throwResError n msg + = do errorM $ unwords [show n, T.unpack msg] + throwError $ ResError n msg + +-- ------------------------------------------------------------ + +-- | Execute the command in the Hunt monad. +execCmd :: (Binary dt, DocTable dt) => Command -> Hunt dt CmdResult +execCmd + = execBasicCmd . toBasicCommand + +-- XXX: kind of obsolete now +-- | Execute the \"low-level\" command in the Hunt monad. + +execBasicCmd :: (Binary dt, DocTable dt) => BasicCommand -> Hunt dt CmdResult +execBasicCmd cmd@(InsertList _) = do + debugM $ "Exec: InsertList [..]" + execCmd' cmd + +execBasicCmd cmd = do + debugM $ "Exec: " ++ logShow cmd + execCmd' cmd + + +-- | Use 'execBasicCmd'. +-- +-- Dispatches basic commands to corresponding functions. + +execCmd' :: (Binary dt, DocTable dt) => BasicCommand -> Hunt dt CmdResult +execCmd' (Search q offset mx wg fields) + = withIx $ execSearch q offset mx wg fields + +execCmd' (Completion q mx) + = withIx $ execCompletion q mx +-- = withIx $ execSearch' (wrapCompletion mx) q + +execCmd' (Select q) + = withIx $ execSelect q + +execCmd' (Sequence cs) + = execSequence cs + +execCmd' NOOP + = return ResOK -- keep alive test + +execCmd' (Status sc) + = execStatus sc + +execCmd' (InsertList docs) + = modIx $ execInsertList docs + +execCmd' (Update doc) + = modIx $ execUpdate doc + +execCmd' (DeleteDocs uris) + = modIx $ execDeleteDocs uris + +execCmd' (DeleteByQuery q) + = modIx $ execDeleteByQuery q + +execCmd' (StoreIx filename) + = withIx $ execStore filename + +execCmd' (LoadIx filename) + = execLoad filename + +execCmd' (InsertContext cx ct) + = modIx $ execInsertContext cx ct + +execCmd' (DeleteContext cx) + = modIx $ execDeleteContext cx + +-- ------------------------------------------------------------ + +-- | Execute a sequence of commands. +-- The sequence will be aborted if a command fails, but the previous commands will be permanent. + +execSequence :: (DocTable dt, Binary dt)=> [BasicCommand] -> Hunt dt CmdResult +execSequence [] = execBasicCmd NOOP +execSequence [c] = execBasicCmd c +execSequence (c : cs) = execBasicCmd c >> execSequence cs + +-- | Insert a context with associated schema. +execInsertContext :: DocTable dt + => Context + -> ContextSchema + -> ContextIndex dt + -> Hunt dt (ContextIndex dt, CmdResult) +execInsertContext cx ct ixx + = do + -- check if context already exists + contextExists <- CIx.hasContextM cx ixx + unless' (not contextExists) + 409 $ "context already exists: " `T.append` cx + + -- check if type exists in this interpreter instance + cType <- askType . ctName . cxType $ ct + impl <- askIndex . ctName . cxType $ ct + norms <- mapM (askNormalizer . cnName) $ cxNormalizer ct + + -- create new index instance and insert it with context + return $ ( CIx.insertContext cx (newIx impl) (newSchema cType norms) ixx + , ResOK + ) + where + newIx :: IndexImpl -> IndexImpl + newIx (IndexImpl i) = mkIndex $ Ix.empty `asTypeOf` i + newSchema cType norms= (ct { cxType = cType, cxNormalizer = norms }) + +-- | Deletes the context and the schema associated with it. +execDeleteContext :: DocTable dt + => Context + -> ContextIndex dt + -> Hunt dt (ContextIndex dt, CmdResult) +execDeleteContext cx ixx + = return (CIx.deleteContext cx ixx, ResOK) + +-- | Inserts an 'ApiDocument' into the index. +-- +-- /Note/: All contexts mentioned in the 'ApiDocument' need to exist. +-- Documents/URIs must not exist. + +execInsertList :: DocTable dt + => [ApiDocument] -> ContextIndex dt -> Hunt dt (ContextIndex dt, CmdResult) +execInsertList docs ixx@(ContextIndex ix _dt) + = do -- existence check for all referenced contexts in all docs + checkContextsExistence contexts ixx + + -- check no duplicates in docs + checkDuplicates duplicates + + -- apidoc should not exist + mapM_ (flip (checkApiDocExistence False) ixx) docs + + -- all checks done, do the real work + ixx' <- lift $ CIx.insertList docsAndWords ixx + return (ixx', ResOK) + where + -- compute all contexts in all docs + contexts + = M.keys + . M.unions + . L.map (M.map (const ()) . adIndex) + $ docs + + -- convert ApiDocuments to Documents, delete null values, + -- and break index data into words by applying the scanner + -- given by the schema spec for the appropriate contexts + docsAndWords + = L.map ( (\ (d, _dw, ws) -> (d, ws)) + . toDocAndWords (CIx.mapToSchema ix) + . (\ d -> d {adDescr = DocDesc.deleteNull $ adDescr d}) + ) + $ docs + + -- compute duplicate URIs by building a frequency table + -- and looking for entries with counts @> 1@ + duplicates + = M.keys + . M.filter (> 1) + . L.foldl ins M.empty + . L.map adUri + $ docs + where + ins m k = M.insertWith (+) k (1::Int) m + + -- check and throw error concerning duplicate URIs + checkDuplicates xs + = unless' (L.null xs) + 409 $ "duplicate URIs found in document list:" <> showText xs + + +-- | Updates an 'ApiDocument'. +-- +-- /Note/: All contexts mentioned in the 'ApiDocument' need to exist. +-- Documents/URIs need to exist. + +execUpdate :: DocTable dt + => ApiDocument -> ContextIndex dt -> Hunt dt (ContextIndex dt, CmdResult) + +execUpdate doc ixx@(ContextIndex ix dt) + = do checkContextsExistence contexts ixx + docIdM <- lift $ DocTable.lookupByURI (uri docs) dt + case docIdM of + Just docId + -> do ixx' <- lift + $ CIx.modifyWithDescription (adWght doc) (desc docs) ws docId ixx + return (ixx', ResOK) + Nothing + -> throwResError 409 $ "document for update not found: " `T.append` uri docs + where + contexts + = M.keys $ adIndex doc + (docs, _dw, ws) + = toDocAndWords (CIx.mapToSchema ix) doc + + +-- | Test whether the contexts are present and otherwise throw an error. + +checkContextsExistence :: DocTable dt + => [Context] -> ContextIndex dt -> Hunt dt () +checkContextsExistence cs ixx + = do ixxContexts <- S.fromList <$> CIx.contextsM ixx + let docContexts = S.fromList cs + let invalidContexts = S.difference docContexts ixxContexts + unless' (S.null invalidContexts) + 409 ( "mentioned context(s) are not present: " + <> (showText . S.toList $ invalidContexts) + ) + +-- | Test whether the document (URI) already exists +-- (or does not exist depending on the first argument). +-- +-- Throws an error if it exists and the first argument is @False@ and vice versa. + +checkApiDocExistence :: DocTable dt + => Bool -> ApiDocument -> ContextIndex dt -> Hunt dt () +checkApiDocExistence switch apidoc ixx + = do let u = adUri apidoc + mem <- CIx.member u ixx + unless' (switch == mem) + 409 ( ( if mem + then "document already exists: " + else "document does not exist: " + ) <> u + ) + +execSearch :: DocTable dt => + Query -> + Int -> Int -> + Bool -> Maybe [Text] -> + ContextIndex dt -> + Hunt dt CmdResult + +execSearch q offset mx wg fields (ContextIndex ix dt) + = do debugM ("execSearch: " ++ show q) + cfg <- asks huntQueryCfg + scDocs <- liftHunt $ + runQueryScoredDocsM ix cfg q + formatPage <$> toDocsResult dt scDocs + where + formatPage ds + = ResSearch $ + LimitedResult + { lrResult = ds' + , lrOffset = offset + , lrMax = mx + , lrCount = length ds + } + where + ds' = map (mkSelect wg fields) + . toDocumentResultPage offset mx + $ ds + +execCompletion :: DocTable dt => + Query -> + Int -> + ContextIndex dt -> Hunt dt CmdResult +execCompletion q mx (ContextIndex ix _dt) + = do debugM ("execCompletion: " ++ show q) + cfg <- asks huntQueryCfg + scWords <- liftHunt $ + runQueryScoredWordsM ix cfg q + return $ ResSuggestion $ toWordsResult mx scWords + + +execSelect :: DocTable dt => Query -> ContextIndex dt -> Hunt dt CmdResult +execSelect q (ContextIndex ix dt) + = do debugM ("execSelect: " ++ show q) + res <- liftHunt $ runQueryUnScoredDocsM ix queryConfigDocIds q + dt' <- DocTable.restrict (toDocIdSet res) dt + djs <- DocTable.toJSON'DocTable dt' + return $ ResGeneric djs + +-- | Build a selection function for choosing, +-- which parts of a document are contained in the result. +-- +-- The 1. param determines, whether the weight of the document is included in the result. +-- The 2. is the list of the description keys, if @Nothing@ is given the complete desc is included. + +mkSelect :: Bool -> Maybe [Text] -> (RankedDoc -> RankedDoc) +mkSelect withWeight fields + = mkSelW withWeight . mkSelF fields + where + mkSelW True = id + mkSelW False = RD . second (\d -> d { wght = 1.0 }) . unRD + + mkSelF Nothing = id + mkSelF (Just fs) = RD . second (\d -> d {desc = DocDesc.restrict fs (desc d)}) . unRD + + +-- | Delete a set of documents. + +execDeleteDocs :: DocTable dt => Set URI -> ContextIndex dt -> Hunt dt (ContextIndex dt, CmdResult) +execDeleteDocs d ix + = do ix' <- lift $ CIx.deleteDocsByURI d ix + return (ix', ResOK) + +-- | Delete all documents matching the query. + +execDeleteByQuery :: DocTable dt => Query -> ContextIndex dt -> Hunt dt (ContextIndex dt, CmdResult) +execDeleteByQuery q ixx@(ContextIndex ix _dt) + = do debugM ("execDeleteByQuery: " ++ show q) + ds <- toDocIdSet <$> + (liftHunt $ runQueryUnScoredDocsM ix queryConfigDocIds q) + if DocIdSet.null ds + then do debugM "DeleteByQuery: Query result set empty" + return (ixx, ResOK) + else do debugM $ "DeleteByQuery: " ++ show ds + ix' <- lift $ CIx.delete ds ixx + return (ix', ResOK) + +-- ------------------------------------------------------------ + +-- TODO: catch exceptions: +-- http://hackage.haskell.org/package/base/docs/System-IO.html#v:openFile + +-- | Serialize a value to a file. +execStore :: (Binary a, DocTable dt) => + FilePath -> a -> Hunt dt CmdResult +execStore filename x = do + res <- liftIO . tryIOError $ encodeFile filename x + case res of + Left e + | isAlreadyInUseError e -> throwResError 409 $ "Cannot store index: file is already in use" + | isPermissionError e -> throwResError 403 $ "Cannot store index: no access permission to file" + | isFullError e -> throwResError 500 $ "Cannot store index: device is full" + | otherwise -> throwResError 500 $ showText $ e + Right _ -> return ResOK + +-- TODO: XMVar functions probably not suited for this, locking for load reasonable + +-- | Load a context index. +-- The deserialization is more specific because of the existentially typed index. + +-- This operation locks the index, otherwise two potentially large indexes could be present at a +-- time. This is still possible if a read operation lasts as long as loading the index. + +execLoad :: (Binary dt, DocTable dt) => FilePath -> Hunt dt CmdResult +execLoad filename = do + ts <- asks huntTypes + let ix = map ctIxImpl ts + modIxLocked $ \_ -> do + ixh@(ContextIndex ixs _) <- decodeFile' ix filename + ls <- TV.mapM reloadSchema $ CIx.cxMap ixs + return (ixh{ ciIndex = CIx.mkContextMap ls }, ResOK) + where + decodeFile' ts f = do + res <- liftIO . tryIOError $ CIx.decodeCxIx ts <$> BL.readFile f + case res of + Left e + | isAlreadyInUseError e -> throwResError 409 $ "Cannot load index: file already in use" + | isDoesNotExistError e -> throwResError 404 $ "Cannot load index: file does not exist" + | isPermissionError e -> throwResError 403 $ "Cannot load index: no access permission to file" + | otherwise -> throwResError 500 $ showText e + Right r -> return r + + reloadSchema (s,ix) = do + cxt <- askType . ctName . cxType $ s + ns <- mapM (askNormalizer . cnName) (cxNormalizer s) + return $ ( s { cxType = cxt + , cxNormalizer = ns + } + , ix ) + +-- ------------------------------------------------------------ + +-- the query interpreters + +-- for scored docs (DocIdMap with scores) + +runQueryScoredDocsM :: ContextMap + -> ProcessConfig + -> Query + -> IO (Either CmdError ScoredDocs) +runQueryScoredDocsM ix cfg q + = processQueryScoredDocs st q + where + st = initProcessor cfg ix + + +-- for unscored docs (DocIdSet), usually called with 'queryConfigDocIds' + +runQueryUnScoredDocsM :: ContextMap + -> ProcessConfig + -> Query + -> IO (Either CmdError UnScoredDocs) +runQueryUnScoredDocsM ix cfg q + = processQueryUnScoredDocs st q + where + st = initProcessor cfg ix + + +-- for scored docs (DocIdMap with scores + +runQueryScoredWordsM :: ContextMap + -> ProcessConfig + -> Query + -> IO (Either CmdError ScoredWords) +runQueryScoredWordsM ix cfg q + = processQueryScoredWords st q + where + st = initProcessor cfg ix + + +-- | Query config for \"delete by query\". + +queryConfigDocIds :: ProcessConfig +queryConfigDocIds = ProcessConfig def True 0 0 + +liftHunt :: IO (Either CmdError r) -> Hunt dt r +liftHunt cmd + = lift cmd >>= either throwError return + +-- ------------------------------------------------------------ + +-- | Get status information about the server\/index, e.g. garbage collection statistics. +execStatus :: DocTable dt => StatusCmd -> Hunt dt CmdResult +execStatus StatusGC + = do + statsEnabled <- liftIO getGCStatsEnabled + if statsEnabled + then (ResGeneric . toJSON) <$> + liftIO getGCStats + else throwResError 501 ("GC stats not enabled. Use `+RTS -T -RTS' to enable them." :: Text) + +execStatus StatusDocTable + = withIx dumpDocTable + where + dumpDocTable (ContextIndex _ix dt) + = ResGeneric <$> + DocTable.toJSON'DocTable dt + +execStatus (StatusContext cx) + = withIx dumpContext + where + dumpContext (ContextIndex ix _dt) + = (ResGeneric . object . map (uncurry (.=))) <$> + CIx.lookupAllWithCx cx ix + +execStatus (StatusIndex {- context -}) + = withIx _dumpIndex + where + -- context = "type" + _dumpIndex (ContextIndex _ix _dt) + = throwResError 501 $ "status of Index not yet implemented" + +-- ------------------------------------------------------------ + +-- | Throw an error unless the first argument is @True@, and otherwise do nothing. +unless' :: DocTable dt + => Bool -> Int -> Text -> Hunt dt () +unless' b code text = unless b $ throwResError code text + +-- ------------------------------------------------------------ + +{- OLD +askDocTable :: DocTable dt => Hunt dt dt +askDocTable = askIx >>= return . ciDocs + +-- | Get the context weightings. +askContextsWeights :: DocTable dt => Hunt dt ContextWeights -- (M.Map Context Weight) +askContextsWeights + = withIx (\(ContextIndex _ _ schema) -> return $ M.map cxWeight schema) +-- -} + + +{- OLD +-- | Run a query. +runQueryM :: DocTable dt + => ContextMap Occurrences + -> Schema + -> ProcessConfig + -> dt + -> Query + -> IO (Either CmdError (Result (DValue dt))) +runQueryM ix s cfg dt q = processQuery st dt q + where + st = initProcessor cfg ix s + +runQueryDocIdsM :: ContextMap Occurrences + -> Schema + -> Query + -> IO (Either CmdError DocIdSet) +runQueryDocIdsM ix s q + = processQueryDocIds st q + where + st = initProcessor queryConfigDocIds ix s +-- -} +-- ------------------------------------------------------------ + +{- old stuff, but still used in completions + +-- | Search the index. +-- Requires a result transformation function, e.g. 'wrapSearch' or 'wrapCompletion'. +execSearch' :: (DocTable dt, e ~ DValue dt) + => (Result e -> CmdResult) + -> Query + -> ContextIndex dt + -> Hunt dt CmdResult +execSearch' f q (ContextIndex ix dt s) + = do + cfg <- asks huntQueryCfg + r <- lift $ runQueryM ix s cfg dt q + rc <- asks huntRankingCfg + cw <- askContextsWeights + case r of + Left err -> throwError err + Right res -> do -- debugM ("doc ranking: " ++ show (docHits res)) + -- debugM ("word ranking: " ++ show (wordHits res)) + res' <- rank rc dt cw $ res + -- debugM ("doc result : " ++ show (docHits res')) + -- debugM ("word result : " ++ show (wordHits res')) + return (f res') + +-- FIXME: signature to result +-- | Wrap the query result for search. +wrapSearch :: (DocumentWrapper e) => (Document -> Document) -> Int -> Int -> Result e -> CmdResult +wrapSearch select offset mx + = ResSearch + . mkLimitedResult offset mx +-- . map fst -- remove score from result + . map (uncurry (flip setScore)) + . map (first select) + . sortBy (descending `on` snd) -- sort by score + . map (\(_did, (di, _dch)) -> (unwrap . document $ di, docScore di)) + . DocIdMap.toList + . docHits + +-- | Wrap the query result for auto-completion. +wrapCompletion :: Int -> Result e -> CmdResult +wrapCompletion mx + = ResCompletion + . take mx + . map (\(word,_score,terms') -> (word, terms')) -- remove score from result + . sortBy (descending `on` (\(_,score',_) -> score')) -- sort by score + . map (\(c, (WIH wi _wch)) -> (c, wordScore wi, terms wi)) + . M.toList + . wordHits + +-- -} + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Interpreter/BasicCommand.hs b/src/Hunt/Interpreter/BasicCommand.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Interpreter/BasicCommand.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- ---------------------------------------------------------------------------- +{- | + Basic \"low-level\" commands that are directly interpreted. + + "Hunt.Interpreter.Command" defines the \"high-level\" commands accepted by the (JSON) API. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Interpreter.BasicCommand + ( BasicCommand (..) + , StatusCmd (..) + ) +where + +import Control.Applicative +import Control.Monad (mzero) + +import Data.Aeson +import qualified Data.Aeson as JS (Value (..)) +import Data.Set (Set) +import Data.Text (Text) + +import Hunt.Common.ApiDocument +import Hunt.Common.BasicTypes +import Hunt.Index.Schema +import Hunt.Query.Language.Grammar (Query (..)) + +import Hunt.Utility.Log + +-- ------------------------------------------------------------ + +-- | The \"low-level\" commands that are actually interpreted. +data BasicCommand + -- | Search query with pagination. + = Search { icQuery :: Query + , icOffsetSR :: Int + , icMaxSR :: Int + , icWeight :: Bool + , icFields :: Maybe [Text] + } + + -- | Auto-completion query with a limit. + | Completion { icPrefixCR :: Query + , icMaxCR :: Int + } + + -- | Raw query without any ranking, scoring and ordering + | Select { icQuery :: Query } + + -- | Insert documents. + | InsertList { icDocs :: [ApiDocument] } + + -- | Update the document description. + | Update { icDoc :: ApiDocument } + + -- | Delete documents by 'URI'. + | DeleteDocs { icUris :: Set URI } + + -- | Delete all documents of the query result. + | DeleteByQuery { icQueryD :: Query } + + -- | Insert a context and the associated schema. + | InsertContext { icICon :: Context + , icSchema :: ContextSchema + } + -- | Delete a context. + | DeleteContext { icDCon :: Context } + + -- | Deserialize the index. + | LoadIx { icPath :: FilePath } + -- | Serialize the index. + | StoreIx { icPath :: FilePath } + + -- | Query general information about the server/index. + | Status { icStatus :: StatusCmd } + + -- | Sequence commands. + | Sequence { icCmdSeq :: [BasicCommand] } + -- | No operation. Can be used in control flow and as an alive test. + | NOOP + deriving (Show) + +-- | Available status commands. +data StatusCmd + = StatusGC -- ^ Garbage collection statistics. + | StatusDocTable -- ^ Document table JSON dump. + | StatusIndex -- ^ Index JSON dump. + | StatusContext Context -- ^ Index context dump + deriving (Show) + +-- ------------------------------------------------------------ +-- XXX: maybe duplicate StatusCmd to keep this module clean + +instance ToJSON StatusCmd where + toJSON StatusGC = JS.String "gc" + toJSON StatusDocTable = JS.String "doctable" + toJSON StatusIndex = JS.String "index" + toJSON (StatusContext c) = object ["context" .= c] -- JS.String $ "context/" `T.append` c + +instance FromJSON StatusCmd where + parseJSON (Object o) = StatusContext <$> o .: "context" + parseJSON (JS.String "gc" ) = return StatusGC + parseJSON (JS.String "doctable") = return StatusDocTable + parseJSON (JS.String "index" ) = return StatusIndex + parseJSON _ = mzero + +-- ------------------------------------------------------------ + +instance LogShow BasicCommand where + logShow (InsertList docs) = "InsertList " ++ show (map adUri docs) + logShow (Update doc) = "Update {icDoc = " ++ logShow doc ++ "\", ..}" + logShow (Sequence _) = "Sequence" + logShow o = show o + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Interpreter/Command.hs b/src/Hunt/Interpreter/Command.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Interpreter/Command.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- ---------------------------------------------------------------------------- +{- | + \"High-level\" commands that are accepted by the (JSON) API. + + These commands are translated with 'toBasicCommand' to 'BasicCommand's which can be interpreted. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Interpreter.Command + ( Command (..) + , StatusCmd (..) + , CmdResult (..) + , CmdError (..) + , CmdRes (..) + , toBasicCommand + ) +where + +import Control.Applicative +import Control.Monad (mzero) +import Control.Monad.Error (Error (..)) +import Control.DeepSeq + +import Data.Aeson +import Data.List +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T + +import Hunt.Common.ApiDocument +import Hunt.Common.BasicTypes +import Hunt.Index.Schema +import Hunt.Query.Language.Grammar (Query (..)) +import Hunt.Query.Intermediate (RankedDoc) + +import Hunt.Interpreter.BasicCommand (BasicCommand, StatusCmd (..)) +import qualified Hunt.Interpreter.BasicCommand as Cmd + +import Hunt.Utility.Log + +-- ------------------------------------------------------------ + +-- | The \"high-level\" commands accepted by the 'Interpreter' \/ JSON API. +-- These are translated to 'BasicCommand's. + +data Command + -- | Search query with pagination. + = Search { icQuery :: Query + , icOffsetSR :: Int + , icMaxSR :: Int + , icWeight :: Bool + , icFields :: Maybe [Text] + } + -- | Auto-completion query with a limit. + | Completion { icPrefixCR :: Query + , icMaxCR :: Int + } + -- | Raw query without any ranking, scoring and ordering + | Select { icQuery :: Query } + + -- | Insert a document. + | Insert { icDoc :: ApiDocument } + + -- | Update a documents' description. + | Update { icDoc :: ApiDocument } + + -- | Delete a documents by 'URI'. + | Delete { icUri :: URI } + + -- | Delete all documents of the query result. + | DeleteByQuery { icQueryD :: Query } + + -- | Insert a context and the associated schema. + | InsertContext { icIContext :: Context + , icSchema :: ContextSchema + } + -- | Delete a context. + | DeleteContext { icDContext :: Context } + + -- | Deserialize the index. + | LoadIx { icPath :: FilePath } + + -- | Serialize the index. + | StoreIx { icPath :: FilePath } + + -- | Query general information about the server/index. + | Status { icStatus :: StatusCmd } + + -- | Sequence commands. + | Sequence { icCmdSeq :: [Command] } + + -- | No operation. Can be used in control flow and as an alive test. + | NOOP + deriving (Show) + +-- ------------------------------------------------------------ + +-- | The result of an interpreted command. + +data CmdResult + -- | The command was processed successfully. + = ResOK + + -- | The search results. + | ResSearch { crRes :: LimitedResult RankedDoc } + + -- | The auto-completion results. + | ResCompletion { crWords :: [(Text, [Text])] } + + -- | The simplified completion result + + | ResSuggestion { crSugg :: [(Text, Score)] } + + -- | A generic JSON result. + | ResGeneric { crGen :: Value } + deriving (Show, Eq) + +instance NFData CmdResult where + rnf (ResSearch r) = r `seq` () + rnf (ResCompletion c) = c `seq` () + rnf (ResSuggestion s) = s `seq` () + rnf _ = () + +-- | An error during processing of the command. +-- This includes a error code and a message. + +data CmdError + = ResError + { ceCode :: Int -- ^ Error code. + , ceMsg :: Text -- ^ Message describing the error. + } deriving (Show) + +instance NFData CmdError where + rnf (ResError i t) = t `seq` i `seq` () + +-- ------------------------------------------------------------ + +-- | auxiliary type for parsing JSON CmdResult's of various kinds +-- +-- usefull in hunt applications, not used within the hunt server + +newtype CmdRes a = CmdRes { unCmdRes :: a } + deriving (Show) + +instance (FromJSON a) => FromJSON (CmdRes a) where + parseJSON (Object o) = do + c <- o .: "code" + case (c :: Int) of + 0 -> CmdRes <$> o .: "msg" + _ -> mzero + parseJSON _ = mzero + +-- ------------------------------------------------------------ + +instance LogShow Command where + logShow (Insert doc) = "Insert {icDoc = " ++ logShow doc ++ "\", ..}" + logShow (Update doc) = "Update {icDoc = " ++ logShow doc ++ "\", ..}" + logShow (Sequence _) = "Sequence" + logShow o = show o + +-- ------------------------------------------------------------ +-- JSON instances +-- ------------------------------------------------------------ + +instance ToJSON Command where + toJSON o = case o of + Search q ofs mx wght sel + -> object . cmd "search" $ + [ "query" .= q + , "offset" .= ofs -- the start of the result list + , "max" .= mx -- max length of result list + ] + ++ + ( if wght -- doc weight included in result (yes/no) + then [ "weight" .= wght ] + else [] + ) + ++ -- descr fields included in result + maybe [] (\ fs -> [ "fields" .= fs ]) sel + + Completion s mx -> object . cmd "completion" $ [ "text" .= s, "max" .= mx ] + Select q -> object . cmd "select" $ [ "query" .= q ] + Insert d -> object . cmd "insert" $ [ "document" .= d ] + Update d -> object . cmd "update" $ [ "document" .= d ] + Delete u -> object . cmd "delete" $ [ "uri" .= u ] + DeleteByQuery q -> object . cmd "delete-by-query"$ [ "query" .= q ] + InsertContext c s -> object . cmd "insert-context" $ [ "context" .= c, "schema" .= s ] + DeleteContext c -> object . cmd "delete-context" $ [ "context" .= c ] + LoadIx f -> object . cmd "load" $ [ "path" .= f ] + StoreIx f -> object . cmd "store" $ [ "path" .= f ] + Status sc -> object . cmd "status" $ [ "status" .= sc ] + NOOP -> object . cmd "noop" $ [] + Sequence cs -> toJSON cs + where + cmd c = (:) ("cmd" .= (c :: Text)) + +instance FromJSON Command where + parseJSON (Object o) = do + c <- o .: "cmd" + case (c :: Text) of + "search" -> Search <$> o .: "query" + <*> o .:? "offset" .!= 0 + <*> o .:? "max" .!= (-1) + <*> o .:? "weight" .!= False + <*> o .:? "fields" + + "completion" -> Completion <$> o .: "text" + <*> o .: "max" + + "select" -> Select <$> o .: "query" + "insert" -> Insert <$> o .: "document" + "update" -> Update <$> o .: "document" + "delete" -> Delete <$> o .: "uri" + "delete-by-query"-> DeleteByQuery <$> o .: "query" + + "insert-context" -> InsertContext <$> o .: "context" + <*> o .: "schema" + + "delete-context" -> DeleteContext <$> o .: "context" + "load" -> LoadIx <$> o .: "path" + "store" -> StoreIx <$> o .: "path" + "noop" -> return NOOP + "status" -> Status <$> o .: "status" + _ -> mzero + + parseJSON v = Sequence <$> parseJSON v + +instance ToJSON CmdResult where + toJSON o = case o of + ResOK -> object . code 0 $ [] + ResSearch r -> object . code 0 $ [ "res" .= r ] + ResCompletion w -> object . code 0 $ [ "res" .= w ] + ResSuggestion r -> object . code 0 $ [ "res" .= r ] + ResGeneric v -> object . code 0 $ [ "res" .= v ] + where + code i = (:) ("code" .= (i :: Int)) + +instance Error CmdError where + strMsg s = ResError 500 . T.pack $ "internal server error: " ++ s + +instance ToJSON CmdError where + toJSON (ResError c m) = object + [ "code" .= c + , "msg" .= m + ] + +instance FromJSON CmdError where + parseJSON (Object o) = ResError <$> o .: "code" + <*> o .: "msg" + parseJSON _ = mzero + +-- ------------------------------------------------------------ + +-- TODO: - flattening of 'Sequence's? + +-- | Transform the supported input command into lower level commands which are actually interpreted. +-- +-- Transformations: +-- +-- - Multiple 'Cmd.Delete's into a single 'DeleteDocs'. +-- +-- - Multiple 'Cmd.Insert's into a single or multiple 'InsertList's. +toBasicCommand :: Command -> BasicCommand +toBasicCommand (Sequence cs) = Cmd.Sequence $ opt cs + where + opt :: [Command] -> [BasicCommand] + opt cs' = concatMap optGroup $ groupBy equalHeads cs' + -- requires the commands to be grouped by constructor + optGroup :: [Command] -> [BasicCommand] + -- groups of delete to DeleteDocs + optGroup cs'@(Delete{}:_) + = [foldl (\(Cmd.DeleteDocs us) (Delete u) + -> Cmd.DeleteDocs (S.insert u us)) (Cmd.DeleteDocs S.empty) cs'] + -- groups of Insert to InsertList + -- TODO: remove constant + optGroup cs'@(Insert{}:_) + = [splitBatch maxBound $ foldl (\(Cmd.InsertList us) (Insert u) + -> Cmd.InsertList (u:us)) (Cmd.InsertList []) cs'] + optGroup cs'@(Sequence{}:_) + = map toBasicCommand cs' + optGroup cs' + = map toBasicCommand cs' + -- group by constructor + -- NOTE: add constructors to use in optGroup + equalHeads :: Command -> Command -> Bool + equalHeads Delete{} Delete{} = True + equalHeads Insert{} Insert{} = True + equalHeads Sequence{} Sequence{} = True + equalHeads _ _ = False + +toBasicCommand (Delete u) = Cmd.DeleteDocs $ S.singleton u +toBasicCommand (DeleteByQuery q) = Cmd.DeleteByQuery q +toBasicCommand (Search a b c d e) = Cmd.Search a b c d e +toBasicCommand (Completion a b) = Cmd.Completion a b +toBasicCommand (Select a) = Cmd.Select a +toBasicCommand (Insert a) = Cmd.InsertList [a] +toBasicCommand (Update a) = Cmd.Update a +toBasicCommand (InsertContext a b) = Cmd.InsertContext a b +toBasicCommand (DeleteContext a) = Cmd.DeleteContext a +toBasicCommand (LoadIx a) = Cmd.LoadIx a +toBasicCommand (StoreIx a) = Cmd.StoreIx a +toBasicCommand (Status a) = Cmd.Status a +toBasicCommand (NOOP) = Cmd.NOOP + +-- | Splits big batch inserts to smaller ones with at most @n@ elements. +-- This can avoid running out of memory for large 'InsertList's. +splitBatch :: Int -> BasicCommand -> BasicCommand +splitBatch n (Cmd.InsertList xs) + = Cmd.Sequence $ map Cmd.InsertList $ splitEvery n xs +splitBatch _ cmd + = cmd + +splitEvery :: Int -> [a] -> [[a]] +splitEvery _ [] = [] +splitEvery n list = first : splitEvery n rest + where + (first,rest) = splitAt n list + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Query/Fuzzy.hs b/src/Hunt/Query/Fuzzy.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Query/Fuzzy.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Hunt.Query.Fuzzy + Copyright : Copyright (C) 2007, 2008 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + Version : 0.2 + + The unique Holumbus mechanism for generating fuzzy sets. +-} + +-- ---------------------------------------------------------------------------- + +module Hunt.Query.Fuzzy + ( + -- * Fuzzy types + FuzzySet + , Replacements + , Replacement + , FuzzyScore + , FuzzyConfig (..) + + -- * Predefined replacements + , englishReplacements + , germanReplacements + + -- * Generation + , fuzz + + -- * Conversion + , toList + ) +where + +import Data.Binary +import Data.Default +import Data.Function +import Data.List +import Data.Maybe (fromMaybe) + +import Control.Applicative + +import Data.Map (Map) +import qualified Data.Map as M + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Binary () + +-- ------------------------------------------------------------ + +-- | A set of string which have been "fuzzed" with an associated score. +type FuzzySet = Map Text FuzzyScore + +-- | Some replacements which can be applied to a string to generate a 'FuzzySet'. The scores of +-- the replacements will be normalized to a maximum of 1.0. +type Replacements = [Replacement] + +-- | A single replacements, where the first will be replaced by the second and vice versa in +-- the target string. The score indicates the amount of fuzzines that one single application +-- of this replacement in just one direction will cause on the target string. +type Replacement = ((Text,Text), FuzzyScore) + +-- | The score indicating an amount of fuzziness. +type FuzzyScore = Float + +-- | The configuration of a fuzzy query. +data FuzzyConfig + = FuzzyConfig + { applyReplacements :: Bool -- ^ Indicates whether the replacements should be applied. + , applySwappings :: Bool -- ^ Indicates whether the swapping of adjacent characters should be applied. + , maxFuzziness :: FuzzyScore -- ^ The maximum allowed fuzziness. + , customReplacements :: Replacements -- ^ The replacements that should be applied. + } + deriving (Show) + +-- ------------------------------------------------------------ + +instance Default FuzzyConfig where + def = FuzzyConfig True True 1.0 englishReplacements + +instance Binary FuzzyConfig where + put (FuzzyConfig r s m f) = put r >> put s >> put m >> put f + get = FuzzyConfig <$> get <*> get <*> get <*> get + +-- ------------------------------------------------------------ + +-- | Some default replacements for the english language. +englishReplacements :: Replacements +englishReplacements = + [ (("l", "ll"), 0.2) + , (("t", "tt"), 0.2) + , (("r", "rr"), 0.2) + , (("e", "ee"), 0.2) + , (("o", "oo"), 0.2) + , (("s", "ss"), 0.2) + + , (("g", "ck"), 0.4) + , (("k", "ck"), 0.4) + , (("ea", "ee"), 0.4) + , (("ou", "oo"), 0.4) + , (("ou", "au"), 0.4) + , (("ou", "ow"), 0.4) + + , (("s", "c"), 0.6) + , (("uy", "ye"), 0.6) + , (("y", "ey"), 0.6) + , (("kn", "n"), 0.6) + ] + +-- | Some default replacements for the german language. +germanReplacements :: Replacements +germanReplacements = + [ (("l", "ll"), 0.2) + , (("t", "tt"), 0.2) + , (("n", "nn"), 0.2) + , (("r", "rr"), 0.2) + , (("i", "ie"), 0.2) + , (("ei", "ie"), 0.2) + , (("k", "ck"), 0.2) + + , (("d", "t"), 0.4) + , (("b", "p"), 0.4) + , (("g", "k"), 0.4) + , (("g", "ch"), 0.4) + , (("c", "k"), 0.4) + , (("s", "z"), 0.4) + , (("u", "ou"), 0.4) + + , (("ü", "ue"), 0.1) + , (("ä", "ae"), 0.1) + , (("ö", "oe"), 0.1) + , (("ß", "ss"), 0.1) + ] + +-- | Continue fuzzing a string with the an explicitly specified list of replacements until +-- a given score threshold is reached. +fuzz :: FuzzyConfig -> Text -> FuzzySet +fuzz cfg s = M.delete s (fuzz' (fuzzLimit cfg 0.0 s)) + where + fuzz' :: FuzzySet -> FuzzySet + fuzz' fs = if M.null more then fs else M.unionWith min fs (fuzz' more) + where + -- The current score is doubled on every recursive call, because fuzziness increases exponentially. + more = M.foldrWithKey (\sm sc res -> M.unionWith min res (fuzzLimit cfg (sc + sc) sm)) M.empty fs + +-- | Fuzz a string and limit the allowed score to a given threshold. +fuzzLimit :: FuzzyConfig -> FuzzyScore -> Text -> FuzzySet +fuzzLimit cfg sc s = if sc <= th then M.filter (<= th) (fuzzInternal cfg sc s) else M.empty + where + th = maxFuzziness cfg + +-- | Fuzz a string with an list of explicitly specified replacements and combine the scores +-- with an initial score. +fuzzInternal :: FuzzyConfig -> FuzzyScore -> Text -> FuzzySet +fuzzInternal cfg sc s = M.unionWith min replaced swapped + where + replaced = let rs = customReplacements cfg in if applyReplacements cfg + then foldr (\r res -> M.unionWith min res (applyFuzz (replace rs r) sc s)) M.empty rs + else M.empty + swapped = if applySwappings cfg + then applyFuzz swap sc s + else M.empty + +-- | Applies a fuzzy function to a string. An initial score is combined with the new score +-- for the replacement. +applyFuzz :: (Text -> Text -> [(Text, FuzzyScore)]) -> FuzzyScore -> Text -> FuzzySet +applyFuzz f sc s = apply (init $ T.inits s) (init $ T.tails s) + where + apply :: [Text] -> [Text] -> FuzzySet + apply [] _ = M.empty + apply _ [] = M.empty + apply (pr:prs) (su:sus) = M.unionsWith min $ apply prs sus:map create (f pr su) + where + create (fuzzed, score) = M.singleton fuzzed (sc + score * calcWeight (T.length pr) (T.length s)) + +-- | Apply a replacement in both directions to the suffix of a string and return the complete +-- string with a score, calculated from the replacement itself and the list of replacements. +replace :: Replacements -> Replacement -> Text -> Text -> [(Text, FuzzyScore)] +replace rs ((r1, r2), s) prefix suffix = replace' r1 r2 ++ replace' r2 r1 + where + replace' tok sub = if replaced == suffix then [] else [(prefix `T.append` replaced, score)] + where + replaced = replaceFirst tok sub suffix + score = s / (snd $ maximumBy (compare `on` snd) rs) + +-- | Swap the first two characters of the suffix and return the complete string with a score or +-- Nothing if there are not enough characters to swap. +swap :: Text -> Text -> [(Text, FuzzyScore)] +swap prefix str = fromMaybe [] $ do + (s1, suffix0) <- T.uncons str + (s2, suffix) <- T.uncons suffix0 + return [(prefix `T.append` (s2 `T.cons` s1 `T.cons` suffix), 1.0)] + +-- | Calculate the weighting factor depending on the position in the string and it's total length. +calcWeight :: Int -> Int -> FuzzyScore +calcWeight pos len = (l - p) / l + where + p = fromIntegral pos + l = fromIntegral len + +-- | Searches a prefix and replaces it with a substitute in a list. +replaceFirst :: Text -> Text -> Text -> Text +replaceFirst xs' ys' zs' + = case () of + _ | T.null xs' -> ys' `T.append` zs' + | T.null zs' -> T.empty + | otherwise -> let (x, xs) = (T.head xs', T.tail xs') + (y, ys) = (T.head ys', T.tail ys') + (z, zs) = (T.head zs', T.tail zs') + in if x == z && xs' `T.isPrefixOf` zs' then + if T.null ys' then replaceFirst xs T.empty zs + else y `T.cons` replaceFirst xs ys zs + else zs' + +-- | Transform a fuzzy set into a list (ordered by score). +toList :: FuzzySet -> [ (Text, FuzzyScore) ] +toList = sortBy (compare `on` snd) . M.toList + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Query/Intermediate.hs b/src/Hunt/Query/Intermediate.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Query/Intermediate.hs @@ -0,0 +1,657 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- ---------------------------------------------------------------------------- +{- | + The intermediate query results which have to be merged for the various combinatorial operations. + + 'toResult' creates the final result which includes the document (and word) hits. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Query.Intermediate + ( ScoredResult(..) + , Aggregate(..) + + , ScoredDocs + , ScoredWords + , ScoredContexts + , ScoredOccs + , ScoredRawDocs + , ScoredCx + , UnScoredDocs + , RankedDoc (..) + + , toScoredDocs + , boostAndAggregateCx + , fromCxRawResults + , fromRawResult + , limitRawResult + , limitCxRawResults + , contextWeights + , filterByDocSet + , toDocIdSet + , toDocsResult + , toDocumentResultPage + , toWordsResult + + , evalSequence + , evalFollow + , evalNear + , evalOr + , evalAnd + , evalAndNot + , evalBoost + , evalPrim + ) +where + +import Prelude hiding (null) + +import Control.Applicative hiding (empty) +import Control.Arrow (second, (***)) + +import qualified Data.LimitedPriorityQueue as Q +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Aeson +import qualified Data.HashMap.Strict as HM +import Hunt.Query.Result hiding (null) + +import Hunt.Common +import qualified Hunt.Common.DocIdMap as DM +import qualified Hunt.Common.DocIdSet as DS +import Hunt.Common.Document (DocumentWrapper (..)) +import qualified Hunt.Common.Occurrences as Occ +import qualified Hunt.Common.Positions as Pos +import Hunt.DocTable (DocTable) +import qualified Hunt.DocTable as Dt + +-- import Debug.Trace + +-- ------------------------------------------------------------ +-- +-- The Monoid @mempty@ acts as empty result, +-- (<>) is the union of scored results + +class Monoid a => ScoredResult a where + boost :: Score -> a -> a + nullSC :: a -> Bool + differenceSC :: a -> a -> a + intersectSC :: a -> a -> a + intersectDisplSC :: Int -> a -> a -> a + intersectFuzzySC :: Int -> Int -> a -> a -> a + +-- ------------------------------------------------------------ + +-- The result type for document search, every doc is associated with a score + +newtype ScoredDocs + = SDS (DocIdMap Score) + deriving (Show) + +instance Monoid ScoredDocs where + mempty + = SDS DM.empty + mappend (SDS m1) (SDS m2) + = SDS $ DM.unionWith (<>) m1 m2 + +instance ScoredResult ScoredDocs where + boost b (SDS m1) + = SDS $ DM.map (b *) m1 + + nullSC (SDS m1) + = DM.null m1 + + differenceSC (SDS m1) (SDS m2) + = SDS $ DM.difference m1 m2 + + intersectSC (SDS m1) (SDS m2) + = SDS $ DM.intersectionWith (+) m1 m2 + + intersectDisplSC _disp + = intersectSC + + intersectFuzzySC _lb _ub + = intersectSC + +toScoredDocs :: Occurrences -> ScoredDocs +toScoredDocs os + = SDS $ DM.map toScore os + where + toScore = mkScore . fromIntegral . Pos.size + +-- ------------------------------------------------------------ + +-- | The result type for unscored search of documents +-- +-- used when all matching docs must be processed, +-- e.g. in DeleteByQuery commands + +newtype UnScoredDocs + = UDS DS.DocIdSet + deriving (Show, Monoid) + +instance ScoredResult UnScoredDocs where + boost _b uds + = uds + + nullSC (UDS s) + = DS.null s + + differenceSC (UDS s1) (UDS s2) + = UDS $ DS.difference s1 s2 + + intersectSC (UDS s1) (UDS s2) + = UDS $ DS.intersection s1 s2 + + intersectDisplSC _disp + = intersectSC + + intersectFuzzySC _lb _ub + = intersectSC + +toUnScoredDocs :: Occurrences -> UnScoredDocs +toUnScoredDocs os + = UDS . DS.fromList . DM.keys $ os + +toDocIdSet :: UnScoredDocs -> DS.DocIdSet +toDocIdSet (UDS ds) = ds + +-- ------------------------------------------------------------ + +-- The result type for word search, +-- this is the required result type for completions search + +newtype ScoredWords + = SWS (Map Word Score) + deriving (Show) + +type ScoredContexts = ScoredWords + +instance Monoid ScoredWords where + mempty + = SWS M.empty + + mappend (SWS m1) (SWS m2) + = SWS $ M.unionWith (<>) m1 m2 + +instance ScoredResult ScoredWords where + boost b (SWS m1) + = SWS $ M.map (b *) m1 + + nullSC (SWS m1) + = M.null m1 + + differenceSC (SWS m1) (SWS m2) + = SWS $ M.difference m1 m2 + + intersectSC (SWS m1) (SWS m2) + = SWS $ M.intersectionWith (+) m1 m2 + + intersectDisplSC _disp + = intersectSC + + intersectFuzzySC _lb _ub + = intersectSC + +-- ------------------------------------------------------------ + +data ScoredOccs + = SCO Score Occurrences + deriving (Show) + +instance Monoid ScoredOccs where + mempty + = SCO defScore DM.empty + mappend (SCO s1 d1) (SCO s2 d2) + = SCO ((s1 + s2) / 2.0) (DM.unionWith Pos.union d1 d2) + +instance ScoredResult ScoredOccs where + boost b (SCO s d) + = SCO (b * s) d + + nullSC (SCO _s d) + = DM.null d + + differenceSC (SCO s1 d1) (SCO _s2 d2) + = SCO s1 (DM.difference d1 d2) + + intersectSC (SCO s1 d1) (SCO s2 d2) + = SCO (s1 + s2) (Occ.intersectOccurrences Pos.union d1 d2) + + intersectDisplSC disp (SCO s1 d1) (SCO s2 d2) + = SCO (s1 + s2) (Occ.intersectOccurrences (Pos.intersectionWithDispl disp) d1 d2) + + intersectFuzzySC lb ub (SCO s1 d1) (SCO s2 d2) + = SCO (s1 + s2) (Occ.intersectOccurrences (Pos.intersectionWithIntervall lb ub) d1 d2) + +-- ------------------------------------------------------------ + +-- A result type for searching phrases and context search, +-- every word hit or word sequence hit is +-- associated with a score and a DocIdMap containing +-- the docs and position. +-- +-- The positions are neccessary in phrase and context search, +-- afterwards the positions can be accumulated into a score, +-- e.g. by counting the occurences +-- +-- A RawResult can easily be converted into this type + +newtype ScoredRawDocs + = SRD [([Word], ScoredOccs)] + deriving (Show) + +instance Monoid ScoredRawDocs where + mempty + = SRD [] + mappend (SRD xs1) (SRD xs2) + = SRD $ xs1 ++ xs2 + +instance ScoredResult ScoredRawDocs where + boost b (SRD xs) + = SRD $ L.map (second (boost b)) xs + + nullSC (SRD xs) + = L.null xs + + differenceSC (SRD xs1) (SRD xs2) + = srd $ [(ws1, SCO sc1 (diff occ1 xs2)) | (ws1, SCO sc1 occ1) <- xs1] + where + diff occ xs + = L.foldl op occ xs + where + op occ' (_ws2, SCO _sc2 occ2) + = DM.difference occ' occ2 + + intersectSC + = intersectSRD intersectSC + + intersectDisplSC d + = intersectSRD $ intersectDisplSC d + + intersectFuzzySC lb ub + = intersectSRD $ intersectFuzzySC lb ub + +-- ------------------------------------------------------------ +-- +-- auxiliary functions for ScoredRawDocs + +-- | generalized intersection operator for ScoredRawDocs + +intersectSRD :: (ScoredOccs -> ScoredOccs -> ScoredOccs) + -> ScoredRawDocs -> ScoredRawDocs -> ScoredRawDocs +intersectSRD interSRD (SRD xs1) (SRD xs2) + = srd $ [ (ws1 ++ ws2, interSRD socc1 socc2) + | (ws1, socc1) <- xs1 + , (ws2, socc2) <- xs2 + ] + +-- | smart constructor for ScoredRawDoc removing empty entries + +srd :: [([Word], ScoredOccs)] -> ScoredRawDocs +srd + = SRD . L.filter (not . nullSC . snd) + +filterByDocSet :: UnScoredDocs -> ScoredRawDocs -> ScoredRawDocs +filterByDocSet (UDS ds) (SRD xs) + = SRD $ concatMap filterDocs xs + where + filterDocs (ws, SCO sc occ) + | Occ.null occ' + = [] + | otherwise + = [(ws, SCO sc occ')] + where + occ' = DM.filterWithKey p occ + where + p k _v = k `DS.member` ds + +-- ------------------------------------------------------------ + +-- | Add the Context dimension to a scored result + +newtype ScoredCx a + = SCX (Map Context a) + deriving (Show) + +instance Functor ScoredCx where + fmap f (SCX m) = SCX $ M.map f m + +instance Monoid a => Monoid (ScoredCx a) where + mempty + = SCX M.empty + mappend (SCX m1) (SCX m2) + = SCX $ M.unionWith (<>) m1 m2 + +instance ScoredResult a => ScoredResult (ScoredCx a) where + boost b (SCX m) + = SCX $ M.map (boost b) m + + nullSC (SCX m) + = M.null m + + differenceSC + = binopSCX differenceSC + + intersectSC + = binopSCX intersectSC + + intersectDisplSC d + = binopSCX $ intersectDisplSC d + + intersectFuzzySC lb ub + = binopSCX $ intersectFuzzySC lb ub + + +-- | The final op for a search result: boost the partial results of the contexts +-- with the context weights from the schema and aggregate them +-- by throwing away the contexts + +boostAndAggregateCx :: ScoredResult a => ScoredContexts -> ScoredCx a -> a +boostAndAggregateCx (SWS sm) (SCX m) + = M.foldlWithKey op mempty m + where + op res k x + = boost b x <> res + where + b = fromMaybe defScore $ M.lookup k sm + +contextWeights :: Schema -> ScoredContexts +contextWeights s + = SWS $ M.map cxWeight s + +-- ------------------------------------------------------------ +-- +-- auxiliary functions for scored context results + +binopSCX :: ScoredResult a => (a -> a -> a) -> (ScoredCx a -> ScoredCx a -> ScoredCx a) +binopSCX op (SCX m1) (SCX m2) + = scx $ M.mapWithKey op' m1 + where + op' cx1 sr1 + = sr1 `op` sr2 + where + sr2 = fromMaybe mempty $ M.lookup cx1 m2 + + +-- | smart constructore for ScoredCx removing empty contexts + +scx :: ScoredResult a => Map Word a -> ScoredCx a +scx = SCX . M.filter (not . nullSC) + +-- ------------------------------------------------------------ +-- +-- conversions from RawResult into scored results + +type CxRawResults = [(Context, RawScoredResult)] + +fromCxRawResults :: CxRawResults -> ScoredCx ScoredRawDocs +fromCxRawResults crs + = -- traceShow ("fromCxRawResults:"::String, crs, res) $ + res + where + res = mconcat $ L.map (uncurry $ fromRawResult) crs + +fromRawResult :: Context -> RawScoredResult -> ScoredCx ScoredRawDocs +fromRawResult cx rr + = SCX $ M.singleton cx sr + where + sr = SRD $ L.map toScored rr + where + toScored (w, (sc, occ)) + = ([w], SCO sc occ) + +limitCxRawResults :: Int -> CxRawResults -> CxRawResults +limitCxRawResults mx + = L.map (second $ limitRawResult mx) + +limitRawResult :: Int -> RawScoredResult -> RawScoredResult +limitRawResult maxDocs rs + | maxDocs <= 0 = rs + | otherwise = takeDocs maxDocs rs + where + takeDocs _ xs@[] + = xs + takeDocs _ xs@[_] + = xs + takeDocs mx (r@(_w, (_sc, occ)) : xs) + = case DM.sizeWithLimit mx occ of + Nothing -> [r] + Just s -> let mx' = mx - s in + if mx' <= 0 + then [r] + else r : takeDocs mx' xs + +-- | convert a set of scored doc ids into a list of documents containing the score +-- +-- This list may be further sorted by score, partitioned into pages or ... + +toDocsResult :: (Applicative m, Monad m, DocTable dt) => + dt -> ScoredDocs -> m [RankedDoc] +toDocsResult dt (SDS m) + = mapM toDoc (DM.toList m) + where + toDoc (did, sc) + = (toD . fromJust') <$> Dt.lookup did dt + where + toD d' + = RD (wght d * sc, d) + where + d = unwrap d' + fromJust' (Just x) = x + fromJust' Nothing = error "Intermediate.toDocsResult: undefined" +-- ---------------------------------------- +-- ranking of documents + +-- define a total ordering over documents by taking score and uri into account +-- this is used for ranking (only) +-- +-- XXX TODO: maybe move to Common modules, since this type is now the regular +-- return type + +newtype RankedDoc = RD {unRD :: (Score, Document)} + deriving Show + +instance Eq RankedDoc where + (RD (sc1,d1)) == (RD (sc2,d2)) + = sc1 == sc2 + && + uri d1 == uri d2 + +instance Ord RankedDoc where + (RD (sc1,d1)) `compare` (RD (sc2,d2)) + = case sc1 `compare` sc2 of + EQ -> uri d2 `compare` uri d1 + r -> r + +instance ToJSON RankedDoc where + toJSON (RD (c,d)) + = addScore $ toJSON d + where + addScore (Object hm) + = Object $ HM.insert "score" (toJSON c) hm + addScore _ + = error "toJSON rankedDoc: propably a bug introduced with #75" + +toDocumentResultPage :: Int -> Int -> [RankedDoc] -> [RankedDoc] +toDocumentResultPage = Q.pageList + +-- ---------------------------------------- +-- ranking of completions + +data RankedWord = RW Score Word + deriving Eq + +instance Ord RankedWord where + (RW s1 w1) `compare` (RW s2 w2) + = case s1 `compare` s2 of + EQ -> w2 `compare` w1 + r -> r + +toWordsResult :: Int -> ScoredWords -> [(Word, Score)] +toWordsResult len (SWS m) + = map (\ (RW s w) -> (w, s)) + . Q.toList 0 len + . M.foldWithKey (\ w s -> Q.insert (RW s w)) (Q.mkQueue len) + $ m + +-- ------------------------------------------------------------ +-- +-- aggregating (raw) results for various types of scored results + +class Aggregate a b where + aggregate :: a -> b + +-- | allow no aggregation + +instance Aggregate a a where + aggregate = id + +-- | aggregate scored docs to a single score by summing up the scores and throw away the DocIds + +instance Aggregate ScoredDocs Score where + aggregate (SDS m) + = DM.foldr (<>) defScore m + + +-- | aggregate scored occurences by counting the positions per doc and boost the +-- result with the score. +-- +-- The positions in a doc are thrown away, so all kinds of phrase search become impossible + +instance Aggregate ScoredOccs ScoredDocs where + aggregate (SCO sc occ) + = SDS $ DM.map toScore occ + where + toScore = (sc *) . mkScore . fromIntegral . Pos.size + +-- | aggregate scored occurrences to unscored docs by throwing away the score +instance Aggregate ScoredOccs UnScoredDocs where + aggregate (SCO _sc occ) + = toUnScoredDocs occ + +-- | aggregate scored occurences to a score by aggregating first the positions and snd the doc ids +-- +-- used in computing the score of word in completion search + +instance Aggregate ScoredOccs Score where + aggregate = agg2 . agg1 + where + agg1 :: ScoredOccs -> ScoredDocs + agg1 = aggregate + agg2 :: ScoredDocs -> Score + agg2 = aggregate + +-- | aggregate scored raw results by throwing away the word hits and aggregating +-- all document hits by throwing away the positions. +-- +-- The function for computing the scores of documents in a query + +instance Aggregate ScoredRawDocs ScoredDocs where + aggregate (SRD xs) + = L.foldl (<>) mempty + $ L.map (aggregate . snd) xs + +-- | aggregate scored raw results into an unscored result by throwing away +-- the words, scores and occurrences + +instance Aggregate ScoredRawDocs UnScoredDocs where + aggregate (SRD xs) + = L.foldl (<>) mempty + $ L.map (aggregate . snd) xs + +-- | aggregate the scored raw results by computing the score of all doc per word +-- +-- Used in completion search. +-- The sequence of words (in a phrase) is cut to the last word (@L.last@). For this last one +-- the completions are computed. + +instance Aggregate ScoredRawDocs ScoredWords where + aggregate (SRD xs) + = SWS + $ L.foldl (\ res (w, sc) -> M.insertWith (+) w sc res) M.empty + $ L.map (L.last *** aggregate) xs + +-- | Lifting aggregation to scored context results + +instance Aggregate a b => Aggregate (ScoredCx a) (ScoredCx b) where + aggregate (SCX m) + = SCX $ M.map aggregate m + +-- ------------------------------------------------------------ + +-- query operator evaluation + +-- | combine a sequence of results from a phrase query into a single result +-- and aggregate this result into a simpler structure, +-- e.g. a @ScoredDocs@ or @ScoredWords@ value +-- +-- The arguments must be of this unaggregated from, still containing word +-- positions, else sequences of words are not detected + +evalSequence :: (ScoredResult r, Aggregate ScoredRawDocs r) => + (ScoredCx ScoredRawDocs -> ScoredCx r) -> + [ScoredCx ScoredRawDocs] -> ScoredCx r +evalSequence _aggr [] + = mempty +evalSequence aggr [r1] + = aggr r1 +evalSequence aggr (r1 : rs) + = aggr $ L.foldl op r1 (L.zip [(1::Int)..] rs) + where + op acc (d, r2) = intersectDisplSC d acc r2 + +evalFollow :: (ScoredResult r, Aggregate ScoredRawDocs r) => + (ScoredCx ScoredRawDocs -> ScoredCx r) -> + Int -> + [ScoredCx ScoredRawDocs] -> ScoredCx r +evalFollow _aggr _d [] + = mempty +evalFollow aggr _d [r1] + = aggr r1 +evalFollow aggr dp (r1 : rs) + = aggr $ L.foldl op r1 (L.zip [dp, (2 * dp) ..] rs) + where + op acc (d, r2) = intersectFuzzySC 1 d acc r2 + +evalNear :: (ScoredResult r, Aggregate ScoredRawDocs r) => + (ScoredCx ScoredRawDocs -> ScoredCx r) -> + Int -> + [ScoredCx ScoredRawDocs] -> ScoredCx r +evalNear _aggr _d [] + = mempty +evalNear aggr _d [r1] + = aggr r1 +evalNear aggr dp (r1 : rs) + = aggr $ L.foldl op r1 (L.zip [dp, (2 * dp) ..] rs) + where + op acc (d, r2) = intersectFuzzySC (-d) d acc r2 + +evalOr, evalAnd, evalAndNot :: ScoredResult a => [a] -> a +evalOr = evalBinary (<>) +evalAnd = evalBinary intersectSC +evalAndNot = evalBinary differenceSC + +evalBinary :: ScoredResult a => (a -> a -> a) -> [a] -> a +evalBinary _ [] + = mempty +evalBinary _ [r] + = r +evalBinary op rs + = L.foldl1 op rs + +evalBoost :: ScoredResult a => Score -> a -> a +evalBoost = boost + +evalPrim :: Aggregate (ScoredCx ScoredRawDocs) (ScoredCx r) => ScoredCx ScoredRawDocs -> ScoredCx r +evalPrim = aggregate + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Query/Language/Builder.hs b/src/Hunt/Query/Language/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Query/Language/Builder.hs @@ -0,0 +1,232 @@ + +module Hunt.Query.Language.Builder + ( qWord + , qWordNoCase + , qFullWord + , qFullWordNoCase + , qPhrase + , qPhraseNoCase + , qPrefixPhrase + , qPrefixPhraseNoCase + , qRange + , qAnd + , qAnds + , qOr + , qOrs + , qAndNot + , qAndNots + , qNext + , qNexts + , qFollow + , qFollows + , qNear + , qNears + , setNoCaseSearch + , setFuzzySearch + , setContext + , setContexts + , setBoost + , withinContexts -- deprecated + , withinContext -- deprecated + , withBoost -- deprecated + , qContext + ) +where + +import Hunt.Query.Language.Grammar +import Data.Text (Text) +import qualified Data.Text as T + +import Hunt.Common.BasicTypes (Context, Weight) + +-- query construction + +-- | case sensitive prefix search of a single word + +qWord :: Text -> Query +qWord = QWord QCase + +-- | case insensitive prefix search of a single word + +qWordNoCase :: Text -> Query +qWordNoCase = QWord QNoCase + +-- | exact case sensitive search of a single word + +qFullWord :: Text -> Query +qFullWord = QFullWord QCase + +-- | exact, but case insensitive search of a single word + +qFullWordNoCase :: Text -> Query +qFullWordNoCase = QFullWord QNoCase + +-- -------------------- +-- +-- phrase search + +qPhrase' :: (Text -> Query) -> Text -> Query +qPhrase' qf t + = case T.words t of + [w] -> qf w + ws -> qNexts $ map qf ws + +-- | exact search of a sequence of space separated words. +-- For each word in the sequence, an exact word search is performed. + +qPhrase :: Text -> Query +qPhrase = qPhrase' qFullWord + +-- | exact, but case insenitive search of a sequence of space separated words. +-- For each word in the sequence, a word search is performed. + +qPhraseNoCase :: Text -> Query +qPhraseNoCase = qPhrase' qFullWordNoCase + +-- | prefix search of a sequence of space separated words. +-- For each word in the sequence, a prefix search is performed. + +qPrefixPhrase :: Text -> Query +qPrefixPhrase = qPhrase' qWordNoCase + +-- | prefix search of a sequence of space separated words. +-- For each word in the sequence, a prefix search is performed. + +qPrefixPhraseNoCase :: Text -> Query +qPrefixPhraseNoCase = qPhrase' qWordNoCase + +-- -------------------- + +-- | search a range of words or an intervall for numeric contexts +qRange :: Text -> Text -> Query +qRange = QRange + +-- | shortcut for case sensitive context search +qContext :: Context -> Text -> Query +qContext c w = QContext [c] $ QWord QCase w + +-- | and query +qAnd :: Query -> Query -> Query +qAnd q1 q2 = qAnds [q1, q2] + +-- | multiple @and@ queries. The list must not be emtpy +qAnds :: [Query] -> Query +qAnds = mkAssocSeq And + +-- | or query +qOr :: Query -> Query -> Query +qOr q1 q2 = qOrs [q1, q2] + +-- | multiple @or@ queries. The list must not be emtpy +qOrs :: [Query] -> Query +qOrs = mkAssocSeq Or + +-- | and not query +qAndNot :: Query -> Query -> Query +qAndNot q1 q2 = qAndNots [q1, q2] + +-- | multiple @and-not@ queries. The list must not be emtpy +-- TODO handle left associativity + +qAndNots :: [Query] -> Query +qAndNots = mkLeftAssocSeq AndNot + +-- | neighborhood queries. The list must not be empty +-- +-- TODO: a better name for qNext and qNexts, qPhrase is already used + +qNext :: Query -> Query -> Query +qNext q1 q2 = qNexts [q1, q2] + +qNexts :: [Query] -> Query +qNexts = mkAssocSeq Phrase + +qFollow :: Int -> Query -> Query -> Query +qFollow d q1 q2 = qFollows d [q1, q2] + +qFollows :: Int -> [Query] -> Query +qFollows d = mkAssocSeq (Follow d) + +qNear :: Int -> Query -> Query -> Query +qNear d q1 q2 = qNears d [q1, q2] + +qNears :: Int -> [Query] -> Query +qNears d = mkAssocSeq (Near d) + +collectAssocs :: BinOp -> [Query] -> [Query] +collectAssocs op qs + = concatMap subqs qs + where + subqs (QSeq op' qs') + | op == op' + = qs' + subqs q' + = [q'] + +mkAssocSeq :: BinOp -> [Query] -> Query +mkAssocSeq op qs + = remSingle $ QSeq op (collectAssocs op qs) + +mkLeftAssocSeq :: BinOp -> [Query] -> Query +mkLeftAssocSeq op qs + = remSingle $ QSeq op qs' + where + qs' = case qs of + (QSeq op' qs1 : qs2) + | op == op' + -> qs1 ++ qs2 + _ -> qs + +remSingle :: Query -> Query +remSingle (QSeq _ [q]) + = q +remSingle q + = q + + +-- ------------------------------------------------------------ +-- configure simple search queries + +-- | case insensitve search, only sensible for word and phrase queries + +setNoCaseSearch :: Query -> Query +setNoCaseSearch (QWord _ w) = QWord QNoCase w +setNoCaseSearch (QFullWord _ w) = QFullWord QNoCase w +setNoCaseSearch (QPhrase _ w) = QPhrase QNoCase w +setNoCaseSearch q = q + +-- | fuzzy search, only sensible for word and phrase queries + +setFuzzySearch :: Query -> Query +setFuzzySearch (QWord _ w) = QWord QFuzzy w +setFuzzySearch (QFullWord _ w) = QFullWord QFuzzy w +setFuzzySearch (QPhrase _ w) = QPhrase QFuzzy w +setFuzzySearch q = q + +-- | restrict search to list of contexts + +setContexts :: [Context] -> Query -> Query +setContexts = QContext + +withinContexts :: [Context] -> Query -> Query +withinContexts = QContext +{-# DEPRECATED withinContexts "Don't use this, use setContexts" #-} + +-- | restrict search to a single context + +setContext :: Context -> Query -> Query +setContext cx = withinContexts [cx] + +withinContext :: Context -> Query -> Query +withinContext cx = setContexts [cx] +{-# DEPRECATED withinContext "Don't use this, use setContext" #-} + + +-- | boost the search results by a factor + +setBoost :: Weight -> Query -> Query +setBoost = QBoost + +withBoost :: Weight -> Query -> Query +withBoost = QBoost +{-# DEPRECATED withBoost "Don't use this, use setBoost" #-} diff --git a/src/Hunt/Query/Language/Grammar.hs b/src/Hunt/Query/Language/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Query/Language/Grammar.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- ---------------------------------------------------------------------------- +{- | + The query language. + + 'Query' specifies the complete grammar. + + "Hunt.Query.Language.Parser" provides a parser for plain text queries. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Query.Language.Grammar + ( -- * Query data types + Query (..) + , BinOp (..) + , TextSearchType (..) + , escapeChar + , notWordChar + + -- * Optimizing + , optimize + , checkWith + , extractTerms + -- * Pretty printing + , printQuery + ) +where + +import Control.Applicative +import Control.Monad + +import Data.Aeson +import Data.Binary +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Binary () + +import Hunt.Common.BasicTypes as BTy + +import Text.Read (readMaybe) + +-- ------------------------------------------------------------ + +-- TODO: the constructors QPhrase and QBinary can be removed +-- they can be represented by QFullWord and QSeq. +-- +-- Currently these operators are transformed during query evaluation +-- on the fly into QFullWord and QSeq. + +-- | The query language. +data Query + = QWord TextSearchType Text -- ^ prefix search for a word + | QFullWord TextSearchType Text -- ^ search for a complete word + | QPhrase TextSearchType Text -- ^ Phrase search. + | QContext [Context] Query -- ^ Restrict a query to a list of contexts. + | QBinary BinOp Query Query -- ^ Combine two queries with a binary operation. + | QSeq BinOp [Query] + | QBoost Weight Query -- ^ Weight for query. + | QRange Text Text -- ^ Range query. + deriving (Eq, Show) + +-- | The search opeation. +data TextSearchType + = QCase -- ^ Case-sensitive search. + | QNoCase -- ^ Case-insensitive search. + | QFuzzy -- ^ Fuzzy search. See "Hunt.Query.Fuzzy" for details. + -- The query processor allows additional configuration with + -- 'Hunt.Query.Processor.ProcessConfig'. + deriving (Eq, Show) + +-- | A binary operation. +data BinOp + = And -- ^ Intersect two queries. + | Or -- ^ Union two queries. + | AndNot -- ^ Filter a query by another. + | Phrase -- ^ Search for a sequence of words + | Follow Int -- ^ Search a word followed another word within a distance + | Near Int -- ^ search a word followed or preceded another word within a distance + deriving (Eq, Show) + +-- ------------------------------------------------------------ +-- JSON instances +-- ------------------------------------------------------------ + +instance ToJSON Query where + toJSON o = case o of + QWord op w -> object . ty "word" $ [ "op" .= op, "word" .= w ] + QFullWord op w -> object . ty "fullword" $ [ "op" .= op, "word" .= w ] + QPhrase op s -> object . ty "phrase" $ [ "op" .= op, "phrase" .= s ] + QContext c q -> object . ty "context" $ [ "contexts" .= c , "query" .= q ] + QBinary op q1 q2 -> object . ty' op $ [ "query1" .= q1, "query2" .= q2 ] + QSeq op qs -> object . ty "seq" $ [ "op" .= op, "args" .= qs ] + QBoost w q -> object . ty "boost" $ [ "weight" .= w, "query" .= q ] + QRange l u -> object . ty "range" $ [ "lower" .= l, "upper" .= u ] + where + ty' t = (:) ("type" .= t) + ty t = ty' (t :: Text) + +instance FromJSON Query where + parseJSON (Object o) = do + t <- o .: "type" + case (t :: Text) of + "word" + -> QWord <$> (o .: "op") <*> (o .: "word") + "fullword" + -> QFullWord <$> (o .: "op") <*> (o .: "word") + "phrase" + -> QPhrase <$> (o .: "op") <*> (o .: "phrase") + "context" + -> QContext <$> (o .: "contexts") <*> (o .: "query") + "boost" + -> QBoost <$> (o .: "weight") <*> (o .: "query") + "range" + -> QRange <$> (o .: "lower") <*> (o .: "upper") + "and" + -> bin And + "or" + -> bin Or + "and not" + -> bin AndNot + "seq" + -> QSeq <$> (o .: "op") <*> (o .: "args") + _ -> mzero + where + bin op + = QBinary op <$> (o .: "query1") <*> (o .: "query2") + parseJSON _ = mzero + + +instance ToJSON TextSearchType where + toJSON o = case o of + QCase -> "case" + QNoCase -> "nocase" + QFuzzy -> "fuzzy" + +instance FromJSON TextSearchType where + parseJSON (String s) + = case s of + "case" -> return QCase + "nocase" -> return QNoCase + "fuzzy" -> return QFuzzy + _ -> mzero + parseJSON _ = mzero + +instance ToJSON BinOp where + toJSON o = case o of + And -> "and" + Or -> "or" + AndNot -> "and not" + Phrase -> "phrase" + Follow d -> String $ "follow " <> T.pack (show d) + Near d -> String $ "near " <> T.pack (show d) + +instance FromJSON BinOp where + parseJSON (String s) + = case T.words s of + ["and"] -> return And + ["or"] -> return Or + ["and", "not"] -> return AndNot + ["phrase"] -> return Phrase + ["follow", d] -> maybe mzero (return . Follow) . readMaybe . T.unpack $ d + ["near", d] -> maybe mzero (return . Near ) . readMaybe . T.unpack $ d + _ -> mzero + parseJSON _ = mzero + +-- ------------------------------------------------------------ +-- Binary instances +-- ------------------------------------------------------------ + +instance Binary Query where + put (QWord op s) = put (0 :: Word8) >> put op >> put s + put (QFullWord op s) = put (7 :: Word8) >> put op >> put s + put (QPhrase op s) = put (1 :: Word8) >> put op >> put s + put (QContext c q) = put (2 :: Word8) >> put c >> put q + put (QBinary o q1 q2) = put (4 :: Word8) >> put o >> put q1 >> put q2 + put (QSeq o qs) = put (8 :: Word8) >> put o >> put qs + put (QBoost w q) = put (5 :: Word8) >> put w >> put q + put (QRange l u) = put (6 :: Word8) >> put l >> put u + + get = do + tag <- getWord8 + case tag of + 0 -> QWord <$> get <*> get + 7 -> QFullWord <$> get <*> get + 1 -> QPhrase <$> get <*> get + 2 -> QContext <$> get <*> get + 4 -> QBinary <$> get <*> get <*> get + 8 -> QSeq <$> get <*> get + 5 -> QBoost <$> get <*> get + 6 -> QRange <$> get <*> get + _ -> fail "Error while decoding Query" + + +instance Binary TextSearchType where + put QCase = put (0 :: Word8) + put QNoCase = put (1 :: Word8) + put QFuzzy = put (2 :: Word8) + + get = do + tag <- getWord8 + case tag of + 0 -> return QCase + 1 -> return QNoCase + 2 -> return QFuzzy + _ -> fail "Error while decoding BinOp" + +instance Binary BinOp where + put And = put (0 :: Word8) + put Or = put (1 :: Word8) + put AndNot = put (2 :: Word8) + put Phrase = put (3 :: Word8) + put (Follow d) = put (4 :: Word8) >> put d + put (Near d) = put (5 :: Word8) >> put d + + get = do + tag <- getWord8 + case tag of + 0 -> return And + 1 -> return Or + 2 -> return AndNot + 3 -> return Phrase + 4 -> Follow <$> get + 5 -> Near <$> get + _ -> fail "Error while decoding BinOp" + +-- ------------------------------------------------------------ + +-- | Characters that cannot occur in a word (and have to be escaped). +notWordChar :: String +notWordChar = escapeChar : "\"')([]^ \n\r\t" + +-- | The character an escape sequence starts with. +escapeChar :: Char +escapeChar = '\\' + +-- | Minor query optimizations. +-- +-- /Note/: This can affect the ranking. +optimize :: Query -> Query +-- Same prefix in AND query (case-insensitive) +optimize q@(QBinary And (QWord QNoCase q1) (QWord QNoCase q2)) + | T.toLower q1 `T.isPrefixOf` T.toLower q2 = QWord QNoCase q2 + | T.toLower q2 `T.isPrefixOf` T.toLower q1 = QWord QNoCase q1 + | otherwise = q +-- Same prefix in AND query (case-sensitive) +optimize q@(QBinary And (QWord QCase q1) (QWord QCase q2)) + | q1 `T.isPrefixOf` q2 = QWord QCase q2 + | q2 `T.isPrefixOf` q1 = QWord QCase q1 + | otherwise = q +-- Same prefix in OR query (case-insensitive) +optimize q@(QBinary Or (QWord QNoCase q1) (QWord QNoCase q2)) + | T.toLower q1 `T.isPrefixOf` T.toLower q2 = QWord QNoCase q1 + | T.toLower q2 `T.isPrefixOf` T.toLower q1 = QWord QNoCase q2 + | otherwise = q +-- Same prefix in OR query (case-sensitive) +optimize q@(QBinary Or (QWord QCase q1) (QWord QCase q2)) + | q1 `T.isPrefixOf` q2 = QWord QCase q1 + | q2 `T.isPrefixOf` q1 = QWord QCase q2 + | otherwise = q +-- recursive application +optimize (QBinary And q1 q2) = QBinary And (optimize q1) (optimize q2) +optimize (QBinary Or q1 q2) = QBinary Or (optimize q1) (optimize q2) +optimize (QBinary AndNot q1 q2) = QBinary AndNot (optimize q1) (optimize q2) +optimize (QContext cs q) = QContext cs (optimize q) +optimize (QBoost w q) = QBoost w (optimize q) + +optimize q = q + +-- | Check if the query arguments comply with some custom predicate. +checkWith :: (Text -> Bool) -> Query -> Bool +checkWith f (QWord _ s) = f s +checkWith f (QFullWord _ s) = f s +checkWith f (QPhrase _ s) = f s +checkWith f (QBinary _ q1 q2) = checkWith f q1 && checkWith f q2 +checkWith f (QSeq _ qs) = and $ map (checkWith f) qs +checkWith f (QContext _ q) = checkWith f q +checkWith f (QBoost _ q) = checkWith f q +checkWith f (QRange s1 s2) = f s1 && f s2 + +-- | Returns a list of all terms in the query. +extractTerms :: Query -> [Text] +extractTerms (QWord _ s) = [s] +extractTerms (QFullWord _ s) = [s] +extractTerms (QContext _ q) = extractTerms q +extractTerms (QBinary _ q1 q2) = extractTerms q1 ++ extractTerms q2 +extractTerms _ = [] + +-- ------------------------------------------------------------ + +-- | Renders a text representation of a Query. + +printQuery :: Query -> Text +printQuery (QWord QNoCase w) + = printWord w + +printQuery (QWord QCase w) + = "!" <> printWord w + +printQuery (QWord QFuzzy w) + = "~" <> printWord w + +printQuery (QFullWord QNoCase w) + = printPhrase w + +printQuery (QFullWord QCase w) + = "!" <> printPhrase w + +printQuery (QFullWord QFuzzy w) + = "~" <> printPhrase w + +printQuery (QPhrase _ w) + = printPhrase w + +printQuery (QContext [] w) + = printQPar w + +printQuery (QContext cs' w) + = printCs <> ":(" <> (printQPar w) <> ")" + where + printCs = foldr1 (\l r -> l <> "," <> r) cs' + +printQuery (QBinary o l r) + = (printQPar l) <> (printOp o) <> (printQPar r) + +printQuery (QSeq _ []) + = "" +printQuery (QSeq _ [q]) + = printQuery q +printQuery (QSeq o qs) + = foldr1 (\ res arg -> res <> printOp o <> arg) $ + map printQPar qs + +printQuery (QBoost w q) + = (printQPar q) <> "^" <> (T.pack $ show $ unScore $ toDefScore $ w) + +printQuery (QRange l u) + = "[" <> l <> " TO " <> u <> "]" + +printOp :: BinOp -> Text +printOp And = " " -- the token AND is not required. +printOp Or = " OR " +printOp AndNot = " AND NOT " +printOp Phrase = " ++ " +printOp (Follow d) = " FOLLOW " <> (T.pack $ show d) <> " " +printOp (Near d) = " NEAR " <> (T.pack $ show d) <> " " + +-- | Maybe render paranthesis. +printQPar :: Query -> Text +printQPar q@QWord{} = printQuery q +printQPar q@QFullWord{} = printQuery q +printQPar q@QPhrase{} = printQuery q +printQPar q@QRange{} = printQuery q +printQPar q@QContext{} = printQuery q +printQPar q = "(" <> (printQuery q) <> ")" + +printPhrase :: Text -> Text +printPhrase w + = "\"" <> escapeWord toBeQuoted w <> "\"" + where + toBeQuoted = (== '\"') + +printWord :: Text -> Text +printWord w + | T.any toBeQuoted w = "'" <> escapeWord (== '\'') w <> "'" + | otherwise = w + where + toBeQuoted c = elem c $ notWordChar + +escapeWord :: (Char -> Bool) -> Text -> Text +escapeWord p t + = T.concatMap esc t + where + esc c + | p c = T.pack ('\\' : c : []) + | otherwise = T.singleton c + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Query/Language/Parser.hs b/src/Hunt/Query/Language/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Query/Language/Parser.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +-- ---------------------------------------------------------------------------- +{- | + Module : Hunt.Query.Language.Parser + Copyright : Copyright (C) 2007, 2008 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + Version : 0.2 + + The Hunt query parser, based on the famous Parsec library. + + The parser implements a default syntax for the query grammar which exposes + all possible query types and operators to the user. + + Syntax: + + [@AND@, @OR@, @AND NOT@] = combinatory queries + + [@!w@] = case sensitive prefix query e.g.: @!car@ or @!Car@ + + [@~w@] = fuzzy word query e.g.: @~car@ or @~cra@ + + [@\"...\"@] = phrase query, performs an exact search for a single word + + [@(...)@] = brackets + + [@c:w@] = context sensitive queries e.g.: @(who:Rudi Voeller)@ + + [@c1,c2:w@] = multi context queries e.g.: @(content,who,title:Rudi Voeller)@ + + [@\[... TO ...\]@] = range queries e.g.: @[2014-02-10 TO 2012-02-16]@ + + [@w\^b@] = query boosting e.g.: @toList OR toAscList^1.5@ +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Query.Language.Parser + ( + -- * Parsing + parseQuery + ) +where + +import Control.Applicative hiding (many, (<|>)) + +import Data.Text (Text) +import qualified Data.Text as T + +import Text.Parsec +import Text.Parsec.String + +import Hunt.Query.Language.Builder +import Hunt.Common.BasicTypes (mkScore) +import Hunt.Query.Language.Grammar + +-- ------------------------------------------------------------ + +-- | Parse a query using the default syntax provided by the Hunt framework. +parseQuery :: String -> Either Text Query +parseQuery = result . parse query "" + where + result (Left err) = Left (T.pack . show $ err) + result (Right q) = Right q + +-- | A query may always be surrounded by whitespace +query :: Parser Query +query + = do spaces + res <- orQuery' + spaces >> eof + return res + +orQuery' :: Parser Query +orQuery' + = do q1 <- andQuery' + qs <- many (orOp1 >> andQuery') + return $ qOrs (q1 : qs) + where + orOp1 + = try orOp' + where + orOp' = spaces >> string "OR" >> spaces1 + +andQuery' :: Parser Query +andQuery' + = do q1 <- neighborQuery + qs <- many $ + do op <- andOp1 + q <- neighborQuery + return (op, q) + return $ foldl (\ res (op', q') -> op' res q') q1 qs + where + andOp1 + = try andNotOp' + <|> try andOp' + where + andNotOp' + = do spaces >> string "AND" >> spaces >> string "NOT" >> spaces1 + return qAndNot + andOp' = do spaces >> string "AND" >> spaces1 + return qAnd + + +neighborQuery :: Parser Query +neighborQuery + = do q1 <- contextSeqQuery + qs <- many $ + do op <- neiOp + q <- contextSeqQuery + return (op, q) + return $ foldl (\ res (op', q') -> op' res q') q1 qs + where + neiOp + = try nextOp + <|> try nearOp + <|> try followOp + where + nextOp + = do spaces >> string "++" >> spaces1 + return qNext + nearOp + = do spaces >> string "NEAR" >> spaces + d <- read <$> many1 digit + spaces1 + return $ qNear d + + followOp + = do spaces >> string "FOLLOW" >> spaces + d <- read <$> many1 digit + spaces1 + return $ qNear d + +contextSeqQuery :: Parser Query +contextSeqQuery + = do q1 <- boostQuery + qs <- many $ + try (spaces1 >> boostQuery) + return $ foldl qAnd q1 qs + +boostQuery :: Parser Query +boostQuery + = do q <- contextQuery + tryBoost q + + +-- | Parse a context query. +contextQuery :: Parser Query +contextQuery + = do cs <- try contextSpec <|> return [] + q <- primaryQuery + case cs of + [] -> return q + _ -> return (QContext cs q) + where + contextSpec + = do cs <- contexts + spaces >> char ':' >> spaces + return cs + +primaryQuery :: Parser Query +primaryQuery + = parQuery + <|> + rangeQuery + <|> + caseQuery + <|> + fuzzyQuery + <|> + noCaseQuery + +-- | Parse a query surrounded by parentheses. +parQuery :: Parser Query +parQuery + = do char '(' >> spaces + q <- orQuery' + spaces >> char ')' + return q + +-- | Parse a range query. +rangeQuery :: Parser Query +rangeQuery + = do char '[' >> spaces + l <- word + spaces1 >> string "TO" >> spaces1 + u <- word + spaces >> char ']' >> spaces + return $ QRange (T.pack l) (T.pack u) + +-- | Parse a case-sensitive query. +caseQuery :: Parser Query +caseQuery + = do char '!' >> spaces + ( phraseQuery qPhrase + <|> + wordQuery qWord + <|> + quotedWordQuery qWord ) + +-- | Parse a fuzzy query. +fuzzyQuery :: Parser Query +fuzzyQuery + =do char '~' >> spaces + ( wordQuery (setFuzzySearch . qWord) + <|> + quotedWordQuery (setFuzzySearch . qWord) ) + +noCaseQuery :: Parser Query +noCaseQuery + = phraseQuery qPhraseNoCase + <|> + quotedWordQuery qWordNoCase + <|> + wordQuery qPrefixPhraseNoCase + +-- | Parse a word query. +wordQuery :: (Text -> Query) -> Parser Query +wordQuery c = word >>= return . c . T.pack + +quotedWordQuery :: (Text -> Query) -> Parser Query +quotedWordQuery c = quotedWord >>= return . c . T.pack + +-- | Parse a phrase query. +phraseQuery :: (Text -> Query) -> Parser Query +phraseQuery c = phrase >>= return . c . T.pack + +-- | Parse a word. +word :: Parser String +word = try $ + do w <- many1 (escapedChar <|> wordChar) + if w `elem` ["OR", "AND", "++", "NEAR", "FOLLOW"] + then parserZero + else return w + where + wordChar :: Parser Char + wordChar = noneOf notWordChar + +-- | Parse an escape sequence. @\@ followed by the character, e.g. @\"@. +escapedChar :: Parser Char +escapedChar = char escapeChar *> decodeChar + +-- | Parse a single valid escape character, e.g. @"@. +decodeChar :: Parser Char +decodeChar = choice (zipWith decode notWordChar notWordChar) + where decode c r = r <$ char c + +escaped :: Char -> Parser Char +escaped c + = do char escapeChar + (char c <|> return escapeChar) + +-- | Parse a phrase. +phrase :: Parser String +phrase + = do char '"' + p <- many1 phraseChar + char '"' + return p + where + phraseChar + = escaped '\"' <|> noneOf "\"" + +quotedWord :: Parser String +quotedWord + = do char '\'' + p <- many1 quotedWordChar + char '\'' + return p + where + quotedWordChar + = escaped '\'' <|> noneOf "'" + +-- | Parse a boosted query. +tryBoost :: Query -> Parser Query +tryBoost q = try boost <|> return q + where + boost = do + char '^' + b <- simplePositiveFloat + return (QBoost (mkScore b) q) + + +-- | Parse a list of contexts. +contexts :: Parser [Text] +contexts = context `sepBy1` char ',' + +-- | Parse a context. +context :: Parser Text +context = do spaces + c <- many1 alphaNum + spaces + return (T.pack c) + +-- | Parse at least on white space character. +spaces1 :: Parser () +spaces1 = skipMany1 space + +-- | Parse a simple positive number. +simplePositiveNumber :: Parser String +simplePositiveNumber = many1 digit + +-- | Parse a simple positive float. The decimal point with following numbers is optional. +simplePositiveFloat :: Parser Float +simplePositiveFloat = fmap read $ simplePositiveNumber <++> decimal + where decimal = option "" $ char '.' <:> simplePositiveNumber + +-- ------------------------------------------------------------ + +-- |Applicative concat @(++)@. +(<++>) :: Applicative f => f [a] -> f [a] -> f [a] +(<++>) a b = (++) <$> a <*> b + +-- Applicative cons @(:)@. +(<:>) :: Applicative f => f a -> f [a] -> f [a] +(<:>) a b = (:) <$> a <*> b + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Query/Processor.hs b/src/Hunt/Query/Processor.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Query/Processor.hs @@ -0,0 +1,661 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +-- ---------------------------------------------------------------------------- +{- | + The query processor to perform 'Query's. + + 'processQuery' executes the query and generates the unranked result. + The result can be ranked with the default 'Hunt.Query.Ranking.rank' function. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Query.Processor + ( processQueryScoredDocs + , processQueryUnScoredDocs + , processQueryScoredWords + , initProcessor + + , ProcessConfig (..) + , ProcessEnv + ) + +where + +import Control.Applicative +import Control.Monad.Error +import Control.Monad.Reader + +import Data.Binary (Binary) +import qualified Data.Binary as Bin +import Data.Default +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T + +import Hunt.Common +import Hunt.ContextIndex (ContextMap) +import qualified Hunt.ContextIndex as CIx +import Hunt.Interpreter.Command (CmdError (..)) +import Hunt.Query.Fuzzy (FuzzyConfig) +import Hunt.Query.Intermediate +import Hunt.Query.Language.Grammar +import Hunt.Utility (showText) + +import qualified System.Log.Logger as Log + +-- import Debug.Trace + +-- ------------------------------------------------------------ +-- Logging +-- ------------------------------------------------------------ + +-- | Name of the module for logging purposes. +modName :: String +modName = "Hunt.Query.Processor" + +-- | Log a message at 'DEBUG' priority. +debugM :: String -> IO () +debugM = Log.debugM modName + +-- ------------------------------------------------------------ +-- Configuration and state for the query processor +-- ------------------------------------------------------------ + +-- | Query processor configuration. +data ProcessConfig + = ProcessConfig + { fuzzyConfig :: ! FuzzyConfig -- ^ The configuration for fuzzy queries. + , optimizeQuery :: ! Bool -- ^ Optimize the query before processing (default: @False@). + , wordLimit :: ! Int -- ^ The maximum number of words used from a prefix. @0@ = no limit (default: @100@). + , docLimit :: ! Int -- ^ The maximum number of documents taken into account. @0@ = no limit (default: @500@). + } + +-- ------------------------------------------------------------ + +instance Default ProcessConfig where + def = ProcessConfig def False 100 500 + +-- ------------------------------------------------------------ + +instance Binary ProcessConfig where + put (ProcessConfig fc o l d) + = Bin.put fc >> Bin.put o >> Bin.put l >> Bin.put d + get + = ProcessConfig <$> Bin.get <*> Bin.get <*> Bin.get <*> Bin.get + +-- ------------------------------------------------------------ + +-- | The internal state of the query processor. +data ProcessEnv + = ProcessEnv + { psConfig :: ! ProcessConfig -- ^ The configuration for the query processor. + , psContexts :: ! [Context] -- ^ The current list of contexts. + , psIndex :: ContextMap -- ^ The index to search. + } + +-- ------------------------------------------------------------ +-- Processor monad +-- ------------------------------------------------------------ + +type QueryIndex + = ContextMap + +-- | the processor monad +newtype ProcessorT m a + = PT { runProcessor :: ReaderT ProcessEnv (ErrorT CmdError m) a + } + deriving (Applicative, Monad, MonadIO, Functor, MonadReader ProcessEnv, MonadError CmdError) + +instance MonadTrans ProcessorT where + lift = PT . lift . lift + +type Processor + = ProcessorT IO + +-- ------------------------------------------------------------ +-- Helper +-- ------------------------------------------------------------ + +queryError :: Int -> Text -> Processor a +queryError n msg + = throwError $ ResError n msg + +getContexts :: Processor [Context] +getContexts + = asks psContexts + +getIx :: Processor QueryIndex +getIx + = asks psIndex + +getSchema :: Processor Schema +getSchema + = getIx >>= return . (M.map fst) . CIx.cxMap + +-- | Get the schema associated with that context/index. +-- +-- /Note/: This fails if the schema does not exist. + +getContextSchema :: Context -> Processor ContextSchema +getContextSchema c + = do schema <- getSchema + case M.lookup c schema of + Just cs -> return cs + _ -> queryError 420 ("Context does not exist in schema: " <> c) + + +-- | Normalizes the search value with respect to the schema context type. +-- First runs the validator that throws an error for invalid values, +-- then runs the normalizers associated with the context. + +normQueryCx :: Context -> Text -> Processor (Maybe Text) +normQueryCx c t + = do s <- getContextSchema c + -- apply context type validator + if (validate . ctValidate . cxType $ s) t + then + do liftIO . debugM . debugMsg $ s + -- apply context schema normalizer + return . Just . norm $ s + else + return Nothing + where + norm s + = normalize' (cxNormalizer s) t + + debugMsg s + = T.unpack $ T.concat [ "query normalizer: ", c, ": [", t, "=>", norm s, "]"] + +-- | Initialize the state of the processor. +initProcessor :: ProcessConfig -> QueryIndex -> ProcessEnv +initProcessor cfg ix + = ProcessEnv cfg cxs ix + where + s = CIx.mapToSchema ix + cxs = filter (\c -> fromMaybe False $ M.lookup c s >>= return . cxDefault) + $ CIx.contexts ix + +-- ------------------------------------------------------------ + +processQueryUnScoredDocs :: ProcessEnv -> Query -> IO (Either CmdError UnScoredDocs) +processQueryUnScoredDocs = processQueryScoredResult evalUnScoredDocs + +-- | evaluate a query into a UnScoredDocs result +-- +-- all info about contexts, words and positions and the score of docs +-- are removed by the aggregation. +-- +-- This evaluator is called by commands which need to compute just a set of documents, +-- e.g. DeleteByQuery. When calling evalUnScoredDocs the 'ProcessEnv' value +-- should be configured such that the limit for document to taken into account +-- is set to infinity (represented as @0@ in the config), else the result set +-- may not be complete. +-- +-- In that case it becomes easy to build a query witch acts as a denial of service +-- attack, because the intermediate results become too large to be processed. +-- So these queries must be used in applications rather carefully, e.g. a user should +-- not be able to construct these types of queries by filling in some input fields in a web interface. + +evalUnScoredDocs :: Query -> Processor UnScoredDocs +evalUnScoredDocs q + | isPrimaryQuery q + = do res <- forallCx (evalPrimary q) + aggregateToScoredResult res + +evalUnScoredDocs (QRange lb ub) + = do res <- forallCx (evalRange lb ub) + aggregateToScoredResult res + +evalUnScoredDocs (QSeq op qs) + | isLocalCxOp op + = do res <- forallCxLocal + ( evalSeq' op -- do the position aware operation + <$> mapM evalScoredRawDocs qs ) -- switch to the raw evaluator due to positions + aggregateToScoredResult res -- and aggregate res to UnScoredDocs + | otherwise + = evalSeq op -- do the result combination + <$> mapM evalUnScoredDocs qs -- for the args stay in evaluator + +evalUnScoredDocs (QContext cxs q) + = withCxs cxs $ evalUnScoredDocs q + +evalUnScoredDocs (QBoost _w q) + = evalUnScoredDocs q + +evalUnScoredDocs q@QPhrase{} -- QPhrase is transformed into QFullWord or QSeq Phrase + = normQuery q >>= evalUnScoredDocs + +evalUnScoredDocs q@QBinary{} -- QBin is transformed into QSeq + = normQuery q >>= evalUnScoredDocs + +evalUnScoredDocs q + = queryEvalError q + +-- ------------------------------------------------------------ + +processQueryScoredDocs :: ProcessEnv -> Query -> IO (Either CmdError ScoredDocs) +processQueryScoredDocs = processQueryScoredResult evalScoredDocs' + +-- | evaluate a query into a ScoredDocs result +-- +-- all info about contexts, words and positions is removed by the aggregation, +-- just a set of DocIds and associated scores is computed + +evalScoredDocs :: Query -> Processor ScoredDocs +evalScoredDocs q + | isPrimaryQuery q + = do res <- forallCx (evalPrimary q) + aggregateToScoredResult res + +evalScoredDocs (QRange lb ub) + = do res <- forallCx (evalRange lb ub) + aggregateToScoredResult res + +evalScoredDocs (QSeq op qs) + | isLocalCxOp op + = do res <- forallCxLocal + ( evalSeq' op -- do the position aware operation + <$> mapM evalScoredRawDocs' qs ) -- switch to the raw evaluator due to positions + aggregateToScoredResult res -- and aggregate res to ScoredDocs + | otherwise + = evalSeq op -- do the result combination + <$> mapM evalScoredDocs' qs -- for the args stay in evaluator + +evalScoredDocs (QContext cxs q) + = withCxs cxs $ evalScoredDocs' q + +evalScoredDocs (QBoost w q) + = boost w <$> evalScoredDocs' q + +evalScoredDocs q@QPhrase{} -- QPhrase is transformed into QFullWord or QSeq Phrase + = normQuery q >>= evalScoredDocs + +evalScoredDocs q@QBinary{} -- QBin is transformed into QSeq + = normQuery q >>= evalScoredDocs + +evalScoredDocs q + = queryEvalError q + +-- -------------------- +-- {- switch off trace + +evalScoredDocs' :: Query -> Processor ScoredDocs +evalScoredDocs' = evalScoredDocs +{-# INLINE evalScoredDocs' #-} + +-- -} +{- switch on trace the evaluation + +evalScoredDocs' :: Query -> Processor ScoredDocs +evalScoredDocs' q = trc <$> evalScoredDocs q + where + trc res = traceShow ("evalScoredDocs: "::String,q ) $ + traceShow ("evalScoredDocs: "::String,res) $ res +-- -} +-- ------------------------------------------------------------ + +processQueryScoredWords :: ProcessEnv -> Query -> IO (Either CmdError ScoredWords) +processQueryScoredWords = processQueryScoredResult evalScoredWords' + +-- | evaluate a query into a ScoredWords result +-- +-- all info about contexts, words and positions is removed by the aggregation, +-- just a set of words and associated scores is computed. +-- +-- the words found are suggestions for the last primitive prefix in the query + +evalScoredWords :: Query -> Processor ScoredWords +evalScoredWords q + | isPrimaryQuery q + = do res <- forallCx (evalPrimary q) + aggregateToScoredResult res + +evalScoredWords (QRange lb ub) + = do res <- forallCx (evalRange lb ub) + aggregateToScoredResult res + +evalScoredWords (QSeq Or qs) -- for completions just search + = evalScoredWords' (last qs) -- for rightmost subquery + +evalScoredWords (QSeq AndNot qs) -- for completions just search + = evalScoredWords' (last qs) -- for rightmost subquery + +evalScoredWords (QSeq And qs) -- for completions + = do docs <- evalUnScoredDocs (mkQ $ init qs) -- eval the set of docs for all but the last q + res <- evalScoredRawDocs ( last qs) -- eval the last q as ScoredRawDos + aggregateToScoredResult -- aggregate to ScoredWords + $ fmap (filterByDocSet docs) res -- restrict result to docs found + where + mkQ [q'] = q' + mkQ qs' = QSeq And qs' + +evalScoredWords (QSeq op qs) + | isLocalCxOp op + = do res <- forallCxLocal + ( evalSeq' op -- do the position aware operation + <$> mapM evalScoredRawDocs' qs ) -- switch to the raw evaluator due to positions + aggregateToScoredResult res -- and aggregate res to ScoredWords + +evalScoredWords (QContext cxs q) + = withCxs cxs $ evalScoredWords' q + +evalScoredWords (QBoost w q) + = boost w <$> evalScoredWords' q + +evalScoredWords q@QPhrase{} -- QPhrase is transformed into QFullWord or QSeq Phrase + = normPhraseQuery q >>= evalScoredWords + +evalScoredWords q@QBinary{} -- QBin is transformed into QSeq + = normQuery q >>= evalScoredWords + +evalScoredWords q + = queryEvalError q + +-- -------------------- +-- {- switch off trace + +evalScoredWords' :: Query -> Processor ScoredWords +evalScoredWords' = evalScoredWords +{-# INLINE evalScoredWords' #-} + +-- -} +{- switch on trace of evaluation + +evalScoredWords' :: Query -> Processor ScoredWords +evalScoredWords' q = trc <$> evalScoredWords q + where + trc res = traceShow ("evalScoredWords: "::String,q ) $ + traceShow ("evalScoredWords: "::String,res) $ res +-- -} +-- ------------------------------------------------------------ + +-- | evaluate a query into a context aware raw docs result +-- +-- This evaluator is called from 'evalScoredDocs', 'evalUnScoredDocs' and 'evalScoredWords' +-- in the case of Phrase-, Follow- and Near-queries. +-- +-- No info about contexts, words and positions is removed by the aggregation. +-- 'evalScoredRawDocs' always runs in a single context at a time, +-- because the position information does not have any meaning across contexts +-- +-- Therefore QContext subqueries become meaningless within Phrase-, Follow- and Near-queries + +evalScoredRawDocs :: Query -> Processor (ScoredCx ScoredRawDocs) +evalScoredRawDocs q + | isPrimaryQuery q + = forallCx (evalPrimary q) + +evalScoredRawDocs (QRange lb ub) + = forallCx (evalRange lb ub) + +evalScoredRawDocs (QSeq op qs) + = evalSeq' op + <$> mapM evalScoredRawDocs' qs + +evalScoredRawDocs (QContext cxs q) + = restrictCxs cxs $ evalScoredRawDocs' q + +evalScoredRawDocs (QBoost w q) + = boost w <$> evalScoredRawDocs' q + +evalScoredRawDocs q@QPhrase{} -- QPhrase is transformed into QFullWord or QSeq Phrase + = normQuery q >>= evalScoredRawDocs + +evalScoredRawDocs q@QBinary{} -- QBin is transformed into QSeq + = normQuery q >>= evalScoredRawDocs + +evalScoredRawDocs q + = queryEvalError q + +-- -------------------- +-- {- switch off trace + +evalScoredRawDocs' :: Query -> Processor (ScoredCx ScoredRawDocs) +evalScoredRawDocs' = evalScoredRawDocs +{-# INLINE evalScoredRawDocs' #-} + +-- -} +{- switch on trace of evaluation + +evalScoredRawDocs' :: Query -> Processor (ScoredCx ScoredRawDocs) +evalScoredRawDocs' q = trc <$> evalScoredRawDocs q + where + trc res = traceShow ("evalScoredRawDocs: "::String,q ) $ + traceShow ("evalScoredRawDocs: "::String,res) $ res +-- -} +-- ------------------------------------------------------------ + +-- run a query evaluation + +processQueryScoredResult :: (q -> Processor r) -> ProcessEnv -> q -> IO (Either CmdError r) +processQueryScoredResult eval st q + = runErrorT . runReaderT (runProcessor $ eval q) $ st + + +-- ------------------------------------------------------------ +-- +-- query normalization: transform "old" queries into generalized new form + +normQuery :: Query -> Processor Query +normQuery (QPhrase op w) + = return . QSeq Phrase . L.map (QFullWord op) $ T.words w + +normQuery q@(QBinary op _q1 _q2) + = return . QSeq op . collect op q $ [] + where + collect + | isAssocOp op = collectAssoc + | isLeftAssocOp op = collectLeftAssoc + | otherwise = \ _op q' -> (q':) + +normQuery q + = return q + + +normPhraseQuery :: Query -> Processor Query +normPhraseQuery (QPhrase op w) + = return . QSeq Phrase $ normPhrase (T.words w) [] + where + normPhrase (x:[]) r = r ++ [QWord op x] + normPhrase (x:xs) r = normPhrase xs $ + r ++ [QFullWord op x] + normPhrase [] r = r +normPhraseQuery q + = return q + + + +collectAssoc :: BinOp -> Query -> [Query] -> [Query] +collectAssoc op (QBinary op' q1 q2) + | op == op' + = collectAssoc op q1 . collectAssoc op q2 +collectAssoc _ q + = (q :) + +collectLeftAssoc :: BinOp -> Query -> [Query] -> [Query] +collectLeftAssoc op (QBinary op' q1 q2) + | op == op' + = collectAssoc op q1 . (q2 :) +collectLeftAssoc _ q + = (q :) + +isAssocOp :: BinOp -> Bool +isAssocOp AndNot = False +isAssocOp _ = True + +isLeftAssocOp :: BinOp -> Bool -- currently AndNot is left assoc +isLeftAssocOp = not . isAssocOp -- all others are assoc ops + +isLocalCxOp :: BinOp -> Bool +isLocalCxOp Phrase = True +isLocalCxOp Follow{} = True +isLocalCxOp Near{} = True +isLocalCxOp _ = False + +-- ------------------------------------------------------------ + +-- eval query combinators + +evalSeq :: (ScoredResult r) => BinOp -> [r] -> r +evalSeq Or = evalOr +evalSeq And = evalAnd +evalSeq AndNot = evalAndNot +evalSeq _op = const mempty + +evalSeq' :: BinOp -> [ScoredCx ScoredRawDocs] -> ScoredCx ScoredRawDocs +evalSeq' Phrase = evalSequence id +evalSeq' (Follow d) = evalFollow id d +evalSeq' (Near d) = evalNear id d +evalSeq' op = evalSeq op + +-- | restrict the current context for a query +-- +-- used in evaluating phrase-, follow- and near- queries +-- there it's meaningless to use other than the current contexts + +restrictCxs :: [Context] -> Processor r -> Processor r +restrictCxs cxs p + = do cxs0 <- getContexts + withCxs cxs $ -- check for legal contexts + local (setCx $ cxs0 `L.intersect` L.nub cxs) p -- restrict contexts to cxs + where + setCx cxs' cfg + = cfg {psContexts = cxs'} + +-- | set the context for a part of a query evaluation + +withCxs :: [Context] -> Processor r -> Processor r +withCxs cxs p + = do icxs <- invalidContexts <$> getSchema + if L.null icxs + then local setCx $ p + else queryError 404 + $ "mentioned context(s) do not exist: " + <> showText icxs + where + invalidContexts sc + = filter (\ c -> not (c `M.member` sc)) cxs + setCx cfg + = cfg {psContexts = L.nub cxs} + +-- | execute a command (query) for all contexts and give the current context +-- as extra argument + +forallCx :: (ScoredResult r) => (Context -> Processor r) -> Processor r +forallCx action + = do cxs <- getContexts + res <- mapM action cxs + return $ mconcat res + +-- | execute a command for all contexts, but restrict the set of contexts +-- to the current context before executing the command +-- +-- So the loop over all contexts (forallCx) called in the evaluation of primary +-- queries is switched off + +forallCxLocal :: (ScoredResult r) => Processor r -> Processor r +forallCxLocal action + = do cxs <- getContexts + res <- mapM f' cxs + return $ mconcat res + where + f' cx + = withCxs [cx] action + +isPrimaryQuery :: Query -> Bool +isPrimaryQuery QWord{} = True +isPrimaryQuery QFullWord{} = True +isPrimaryQuery _ = False + +queryEvalError :: Query -> Processor r +queryEvalError q + = queryError 501 $ "Hunt.Query.Processor: query can't be evaluated " <> showText q + +-- ------------------------------------------------------------ + +aggregateToScoredResult :: (Aggregate a (ScoredCx b), ScoredResult b) => + a -> ProcessorT IO b +aggregateToScoredResult res + = do cxScores <- contextWeights <$> getSchema + return $ boostAndAggregateCx cxScores (aggregate res) + + +-- eval basic queries + +evalPrimary :: Query -> Context -> Processor (ScoredCx ScoredRawDocs) +evalPrimary (QWord QCase w) cx + = searchCx PrefixCase w cx + +evalPrimary (QWord QNoCase w) cx + = searchCx PrefixNoCase w cx + +evalPrimary (QWord QFuzzy w) cx -- TODO: QFuzzy is processed like nocase search + = searchCx PrefixNoCase w cx + +evalPrimary (QFullWord QCase w) cx + = searchCx Case w cx + +evalPrimary (QFullWord QNoCase w) cx + = searchCx NoCase w cx + +evalPrimary (QFullWord QFuzzy w) cx -- TODO: QFuzzy is processed like nocase search + = searchCx NoCase w cx + +evalPrimary q _cx + = queryError 501 $ "evalPrimary: not a primary query: " <> showText q + +searchCx :: TextSearchOp -> Word -> Context -> Processor (ScoredCx ScoredRawDocs) +searchCx op w' cx + = do mw <- normQueryCx cx w' -- normalize the word with respect to context + case mw of + Nothing -> return $ fromCxRawResults [] -- if normalization not possible, return empty result + (Just w) -> searchCx' w + where + searchCx' w + = do + limit <- asks (docLimit . psConfig) -- get the max. # of docs + ix <- getIx -- get the context search index + rawr <- limitRawResult limit + <$> CIx.searchWithCxSc op cx w ix -- do the real search and limit result + return $ fromCxRawResults [(cx, rawr)] + -- convert the result to a ScoredResult + -- the score comes from a similarity test + +evalRange :: Word -> Word -> Context -> Processor (ScoredCx ScoredRawDocs) +evalRange lb0 ub0 cx + = do mlb <- normQueryCx cx lb0 -- normalize the word with respect to context + mub <- normQueryCx cx ub0 -- normalize the word with respect to context + case (mlb, mub) of + (Just lb, Just ub) -> evalRange' lb ub + _ -> return $ fromCxRawResults [] -- if one of the words fails validation, return empty result + where + evalRange' lb ub + = do + limit <- asks (docLimit . psConfig) + ix <- getIx + rawr <- limitRawResult limit + <$> CIx.lookupRangeCxSc cx lb ub ix + return $ fromCxRawResults [(cx, rawr)] + +-- ------------------------------------------------------------ + +{- +-- | Log a message at 'WARNING' priority. +warningM :: String -> IO () +warningM = Log.warningM modName + +-- | Log a message at 'ERROR' priority. +errorM :: String -> IO () +errorM = Log.errorM modName +-} + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Query/Ranking.hs b/src/Hunt/Query/Ranking.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Query/Ranking.hs @@ -0,0 +1,231 @@ +-- ---------------------------------------------------------------------------- +{- | + Module : Hunt.Query.Ranking + Copyright : Copyright (C) 2007, 2008 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + Version : 0.3 + + The ranking mechanism for Hunt. + + Customized ranking functions for both documents and suggested words can be + provided by the user. Some predefined ranking functions are avaliable, too. + +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Query.Ranking + ( + -- * Ranking types + RankConfig (..) + , DocRanking + , WordRanking + , ContextWeights + + -- * Ranking + , rank + + -- * Predefined document rankings + , docRankByCount + --, docRankWeightedByCount + + -- * Predefined word rankings + , wordRankByCount + , wordRankBySimilarity + --, wordRankWeightedByCount + + , defaultRankConfig + ) +where + +import Prelude hiding (foldr) + +import Control.Applicative + +--import Data.Foldable +--import Data.Function +import Data.Maybe + +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T + +import Hunt.Common +import qualified Hunt.Common.DocIdMap as DM +import Hunt.Common.Document (DocumentWrapper (..)) +import Hunt.Common.Positions as Pos +import Hunt.DocTable as Dt +import Hunt.Query.Result + +import Hunt.Utility + +-- import Debug.Trace + +-- ------------------------------------------------------------ + +-- | The configuration of the ranking mechanism. +data RankConfig e + = RankConfig + { docRanking :: DocRanking e -- ^ A function to determine the score of a document. + , wordRanking :: WordRanking -- ^ A function to determine the score of a word. + } + +-- | The signature of a function to determine the score of a document. +type DocRanking e = ContextWeights -> DocId -> Score -> DocInfo e -> DocContextHits -> Score + +-- TODO: add ContextWeights +-- | The signature of a function to determine the score of a word. +type WordRanking = Word -> WordInfo -> WordContextHits -> Score + +-- | Weights for the contexts (optional). +type ContextWeights = Map Context Weight + +-- ------------------------------------------------------------ + +-- | The configuration of the ranking mechanism. +defaultRankConfig :: DocumentWrapper e => RankConfig e +defaultRankConfig + = RankConfig + { docRanking = docRankByCount + , wordRanking = wordRankBySimilarity + -- , wordRanking = wordRankByCount + } + +-- ------------------------------------------------------------ + +-- | Rank the result with custom ranking functions (and the given context weights). + +rank :: (DocTable dt, Monad m, Applicative m) => + RankConfig e -> dt -> ContextWeights -> Result e -> m (Result e) + +rank (RankConfig fd fw {-ld lw-}) dt cw r + = do sdh <- scoredDocHits + return $ Result sdh scoredWordHits + where + scoredDocHits + = DM.traverseWithKey + (\k (di, dch) -> + do + kw <- maybe defScore (wght . unwrap) <$> Dt.lookup k dt + return $ ( setDocScore (fd cw k kw di dch) di + , dch + ) + ) $ docHits r + + scoredWordHits + = M.mapWithKey + ( \ k (WIH wi wch) -> WIH (setWordScore (fw k wi wch) wi) wch ) + $ wordHits r + +-- ------------------------------------------------------------ + +-- | Rank documents by count and multiply occurrences with +-- their respective context weights (default @1.0@). +-- Pass an empty map to discard context weights. +-- +-- @docRankByCount :: ContextWeights -> DocId -> Score -> DocInfo e -> DocContextHits -> Score@ + +docRankByCount :: DocRanking e +docRankByCount cw _ docWeight di h + = docBoost di * docWeight * scHits + where + scHits = M.foldrWithKey + (\cx -> (cxw cx *) + .:: + flip (M.foldr (\h2 r2 -> mkScore (fromIntegral (Pos.size h2)) + r2)) + ) noScore h + + cxw cx = fromMaybe defScore $ M.lookup cx cw + +-- | Rank words by count. +-- +-- @wordRankByCount :: Word -> WordInfo -> WordContextHits -> Score@ +wordRankByCount :: WordRanking +wordRankByCount _w _i h + = countHits h + +wordRankBySimilarity :: WordRanking +wordRankBySimilarity wordFound (WordInfo searchTerms sc) wch + = cnt * toDefScore sc * simBoost + where + cnt = countHits wch + + simBoost :: Score + simBoost + | L.null searchTerms -- make simBoost total + = noScore + | otherwise + = maximum (L.map (similar wordFound) searchTerms) + + similar :: Text -> Text -> Score + similar found searched + | searched == found + = boostExactHit + | ls == lf + = boostSameLength + | ls < lf -- reduce score by length of found word + = fromIntegral ls / fromIntegral lf + | otherwise -- make similar total + = noScore + where + boostExactHit = 10.0 + boostSameLength = 5.0 -- NoCase hits + + ls = T.length searched + lf = T.length found + +countHits :: WordContextHits -> Score +countHits wch + = M.foldr op 0.0 wch + where + op x res = DM.foldr (+) 0.0 x + res + +-- ------------------------------------------------------------ + +-- The old weighting mechanism +-- - used a list of context weights +-- - normalizes the weights to a maximum of 1.0 +-- - not sure if this is really necessary or the users responsibility +-- - the computation should be done /once/ every time the weights are set, not with every query +-- - seems overall cumbersome + +{- +-- | Rank documents by context-weighted count. The weights will be normalized to a maximum of 1.0. +-- Contexts with no weight (or a weight of zero) will be ignored. +docRankWeightedByCount :: [(Context, Score)] -> DocId -> DocInfo e -> DocContextHits -> Score +docRankWeightedByCount ws _ _ + = M.foldrWithKey (calcWeightedScore ws) 0.0 + +-- | Rank words by context-weighted count. The weights will be normalized to a maximum of 1.0. +-- Contexts with no weight (or a weight of zero) will be ignored. +wordRankWeightedByCount :: [(Context, Score)] -> Word -> WordInfo -> WordContextHits -> Score +wordRankWeightedByCount ws _ _ + = M.foldrWithKey (calcWeightedScore ws) 0.0 + +-- | Calculate the weighted score of occurrences of a word. +calcWeightedScore :: Foldable f => [(Context, Score)] -> Context -> f Positions -> Score -> Score +calcWeightedScore ws c h r + = maybe r (\w -> r + ((w / mw) * count)) $ lookupWeight c ws + where + count = fromIntegral $ foldl' (flip $ (+) . Pos.size) 0 h + mw = snd $ L.maximumBy (compare `on` snd) ws + +-- | Find the weight of a context in a list of weights. If the context was not found or it's +-- weight is equal to zero, 'Nothing' will be returned. +lookupWeight :: Context -> [(Context, Score)] -> Maybe Score +lookupWeight _ [] = Nothing +lookupWeight c (x:xs) + = if fst x == c + then + if snd x /= 0.0 + then Just (snd x) + else Nothing + else lookupWeight c xs +-} + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Query/Result.hs b/src/Hunt/Query/Result.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Query/Result.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE StandaloneDeriving #-} + +-- ---------------------------------------------------------------------------- +{- | + Module : Hunt.Query.Result + Copyright : Copyright (C) 2007 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + + The data type for results of Holumbus queries. + + The result of a query is defined in terms of two partial results, + the documents containing the search terms and the words which + are possible completions of the search terms. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Query.Result + ( + -- * Result data types + Result(..) + , DocHits + , DocContextHits + , DocWordHits + , WordHits + , WordContextHits + , WordDocHits + , DocInfo(..) + , WordInfo(..) + , WordInfoAndHits(..) + , Score + , Weight + , Boost + , DocBoosts + + -- * Construction + , emptyResult + + -- * Query + , null + , sizeDocHits + , sizeWordHits + , maxScoreDocHits + , maxScoreWordHits + , getDocuments + + -- * Transform + , setDocScore + , setWordScore + ) +where + +import Prelude hiding (null) + +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) + +import Hunt.Common +import qualified Hunt.Common.DocIdMap as DM + +-- ------------------------------------------------------------ + +-- | The combined result type for Holumbus queries. +data Result e + = Result + { docHits :: DocHits e -- ^ The documents matching the query. + , wordHits :: WordHits -- ^ The words which are completions of the query terms. + } +deriving instance Show e => Show (Result e) + + +-- | Information about an document. +data DocInfo e + = DocInfo + { document :: e -- ^ The document itself. + , docBoost :: Weight -- ^ The document weight, init with @1.0@ + , docScore :: Score -- ^ The score for the document (initial score for all documents is @0.0@). + } + +instance Show (DocInfo e) where + show (DocInfo _d b s) = "DocInfo d " ++ show b ++ " " ++ show s + +-- | Information about a word. +data WordInfo + = WordInfo + { terms :: Terms -- ^ The search terms that led to this very word. + , wordScore :: Score -- ^ The frequency of the word in the document for a context. + } + deriving (Eq, Show) + +instance Monoid WordInfo where + mempty + = WordInfo [] noScore + mappend (WordInfo t1 s1) (WordInfo t2 s2) + = WordInfo (t1 `L.union` t2) (s1 <> s2) + +data WordInfoAndHits + = WIH WordInfo WordContextHits + deriving (Eq, Show) + +instance Monoid WordInfoAndHits where + mempty + = WIH mempty M.empty + mappend (WIH wi1 wh1) (WIH wi2 wh2) + = WIH (wi1 <> wi2) (M.unionWith (DM.unionWith (+)) wh1 wh2) + +-- XXX: a list for now - maybe useful for testing +-- | Boosting of a single document. +type Boost = Score + +-- | Document boosting. +type DocBoosts = DocIdMap Score + +-- | A mapping from a document to it's score and the contexts where it was found. +type DocHits e = DocIdMap (DocInfo e, DocContextHits) + +-- | A mapping from a context to the words of the document that were found in this context. +type DocContextHits = Map Context DocWordHits + +-- | A mapping from a word of the document in a specific context to it's positions. +type DocWordHits = Map Word Positions + +-- | A mapping from a word to it's score and the contexts where it was found. +type WordHits = Map Word WordInfoAndHits + +-- | A mapping from a context to the documents that contain the word that were found in this context. +type WordContextHits = Map Context WordDocHits + +-- | A mapping from a document containing the word to the positions of the word. +type WordDocHits = DocBoosts + +-- | The original search terms entered by the user. +type Terms = [Text] + +-- ------------------------------------------------------------ + +-- | Create an empty result. +emptyResult :: Result e +emptyResult = Result DM.empty M.empty + +-- | Query the number of documents in a result. +sizeDocHits :: Result e -> Int +sizeDocHits = DM.size . docHits + +-- | Query the number of documents in a result. +sizeWordHits :: Result e -> Int +sizeWordHits = M.size . wordHits + +-- | Query the maximum score of the documents. +maxScoreDocHits :: Result e -> Score +maxScoreDocHits = DM.foldr (\(di, _) r -> max (docScore di) r) 0.0 . docHits + +-- | Query the maximum score of the words. +maxScoreWordHits :: Result e -> Score +maxScoreWordHits = M.foldr (\ (WIH wi _) r -> max (wordScore wi) r) 0.0 . wordHits + +-- | Test if the result contains anything. +null :: Result e -> Bool +null = DM.null . docHits + +-- | Set the score in a document info. +setDocScore :: Score -> DocInfo e -> DocInfo e +setDocScore s di = di { docScore = s } + +-- | Set the score in a word info. +setWordScore :: Score -> WordInfo -> WordInfo +setWordScore s wi = wi { wordScore = s } + +-- | Extract all documents from a result. +getDocuments :: Result e -> [e] +getDocuments r = map (document . fst . snd) . DM.toList $ docHits r + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Utility.hs b/src/Hunt/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Utility.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE EmptyDataDecls #-} + +-- ---------------------------------------------------------------------------- +{- | + General utitlity functions. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Utility + ( + -- * Function Composition + (.::), (.:::) + + -- * Safe / Total Functions + , head' + + -- * Strict Functions + , foldM' + + -- * Monadic Functions + , foldlWithKeyM, foldrWithKeyM + , whenM + + -- * Maybe Helper + , catMaybesSet + + -- * Either Helper + , isLeft, isRight + , fromLeft, fromRight + + -- * List Helper + , unbox, unboxM, isSingleton + , split + , partitionListByLength, partitionListByCount + , descending + + -- * String Helper + , strip, stripl, stripr, stripWith + , escape + + -- * Text Helper + , showText + + -- * Aeson Helper + , object', (.=?), (.==), (.\.) + + -- * Types + , TypeDummy + ) +where + +import Control.Monad (when) + +import Data.Aeson hiding (decode) +import Data.Aeson.Types +import Data.Char +import qualified Data.Foldable as FB +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromJust) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T + +import Numeric (showHex) + +-- ------------------------------------------------------------ + +-- | A dummy type without constructor. +data TypeDummy + +-- ------------------------------------------------------------ + +showText :: Show a => a -> Text +showText = T.pack . show + +-- | The boob operator. +(.::) :: (c -> d) -> (a -> b -> c) -> a -> b -> d +(.::) = (.).(.) + +-- | The Total Recall operator. +(.:::) :: (d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e +(.:::) = (.).(.).(.) + +-- | Safe 'head'. +head' :: [a] -> Maybe a +head' xs = if null xs then Nothing else Just $ head xs + +-- | 'Data.Maybe.catMaybes' on a 'Set' instead of a List. +catMaybesSet :: Ord a => Set (Maybe a) -> [a] +catMaybesSet = S.toList . S.map fromJust . S.delete Nothing + +-- | Test if 'Either' is a 'Left' value. +isLeft :: Either a b -> Bool +isLeft = either (const True) (const False) + +-- | Test if 'Either' is a 'Right' value. +isRight :: Either a b -> Bool +isRight = not . isLeft + +-- | Unwraps a 'Left' value - fails on 'Right'. +fromLeft :: Either a b -> a +fromLeft = either id (error "Hunt.Utility.fromLeft: Right") + +-- | Unwraps a 'Right' value - fails on 'Left'. +fromRight :: Either a b -> b +fromRight = either (error "Hunt.Utility.fromRight: Left") id + +-- | Unbox a singleton. +-- +-- /Note/: This fails if the list is not a singleton. +unbox :: [a] -> a +unbox [e] = e +unbox _ = error "unbox: []" + +-- | Unbox a singleton in a safe way with 'Maybe'. +unboxM :: [a] -> Maybe a +unboxM [e] = Just e +unboxM _ = Nothing + +-- | Test if the list contains a single element. +isSingleton :: [a] -> Bool +isSingleton [_] = True +isSingleton _ = False + +-- | Split a string into seperate strings at a specific character sequence. +split :: Eq a => [a] -> [a] -> [[a]] +split _ [] = [[]] +split at w@(x:xs) = maybe ((x:r):rs) ((:) [] . split at) (L.stripPrefix at w) + where (r:rs) = split at xs + +-- | Removes leading and trailing whitespace from a string. +strip :: String -> String +strip = stripWith isSpace + +-- | Removes leading whitespace from a string. +stripl :: String -> String +stripl = dropWhile isSpace + +-- | Removes trailing whitespace from a string. +stripr :: String -> String +stripr = reverse . dropWhile isSpace . reverse + +-- | Strip leading and trailing elements matching a predicate. +stripWith :: (a -> Bool) -> [a] -> [a] +stripWith f = reverse . dropWhile f . reverse . dropWhile f + +-- | partition the list of input data into a list of input data lists of +-- approximately the same specified length +partitionListByLength :: Int -> [a] -> [[a]] +partitionListByLength _ [] = [] +partitionListByLength count l = take count l : partitionListByLength count (drop count l) + +-- | partition the list of input data into a list of a specified number of input data lists with +-- approximately the same length +partitionListByCount :: Int -> [a] -> [[a]] +partitionListByCount = partition + where + partition 0 _ = [] + partition sublists l + = let next = (length l `div` sublists) + in if next == 0 then [l] + else take next l : partition (sublists -1) (drop next l) + +-- | To use with 'sortBy'. +descending :: Ord a => a -> a -> Ordering +descending = flip compare + +-- | Escapes non-alphanumeric or space characters in a String +escape :: String -> String +escape [] = [] +escape (c:cs) + = if isAlphaNum c || isSpace c + then c : escape cs + else '%' : showHex (fromEnum c) "" ++ escape cs + +-- | Strict version of 'foldM'. +foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a +foldM' _ acc [] = return acc +foldM' f acc (x:xs) = do + !acc' <- f acc x + foldM' f acc' xs + +-- | 'FB.foldrM' for 'Map' with key. +foldrWithKeyM :: (Monad m) => (k -> a -> b -> m b) -> b -> Map k a -> m b +foldrWithKeyM f b = FB.foldrM (uncurry f) b . M.toList + +-- | 'FB.foldlM' for 'Map' with key. +foldlWithKeyM :: (Monad m) => (b -> k -> a -> m b) -> b -> Map k a -> m b +foldlWithKeyM f b = FB.foldlM f' b . M.toList + where f' a = uncurry (f a) + +-- | Monadic 'when'. +whenM :: Monad m => m Bool -> m () -> m () +whenM bm f = bm >>= \b -> when b f + +-- ------------------------------------------------------------ +-- Aeson helper +-- ------------------------------------------------------------ + +-- | Like 'Data.Aeson.object' to use with '.=?', '.==' and '.\.'. +-- This allows omitting (default) values in 'ToJSON' instances. +-- +-- > toJSON (Example maybe list float) = object' $ +-- > [ "maybe" .=? maybe .\. isNothing +-- > , "list" .=? list .\. null +-- > , "float" .=? float .\. (== 1.0) +-- > ] +object' :: [[Pair]] -> Value +object' = object . Prelude.concat + +-- | Like '.=' but allows omitting of (default) values in 'ToJSON' instances. +-- +-- See 'object''. +(.=?) :: ToJSON a => Text -> (a, a -> Bool) -> [Pair] +name .=? (value, cond) = if cond value then [] else [ name .= value ] + +-- | '.==' for 'object''. +-- +-- See 'object''. +(.==) :: ToJSON a => Text -> a -> [Pair] +name .== value = [ name .= value ] + +-- | Use with '.=?' to specify which value to omit. +-- +-- See 'object''. +(.\.) :: ToJSON a => a -> (a -> Bool) -> (a, a -> Bool) +v .\. c = (v,c) +infixl 8 .=? + +-- ------------------------------------------------------------ diff --git a/src/Hunt/Utility/Log.hs b/src/Hunt/Utility/Log.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Utility/Log.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-} + +-- ---------------------------------------------------------------------------- +{- | + Logging auxiliary functions. + + The 'LogShow' is an alternative 'Show' instance for a custom representation in logs. + It uses the 'Show' instance by default. +-} +-- ---------------------------------------------------------------------------- + +module Hunt.Utility.Log where + +-- | Alternative 'Show' instance for a custom representation in logs. +-- It uses the 'Show' instance by default. +class LogShow e where + logShow :: e -> String + +instance Show e => LogShow e where + logShow = show diff --git a/src/Hunt/Utility/Output.hs b/src/Hunt/Utility/Output.hs new file mode 100644 --- /dev/null +++ b/src/Hunt/Utility/Output.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +-- ------------------------------------------------------------ + +module Hunt.Utility.Output +where +import Control.Monad.IO.Class + +import Data.Aeson +import Data.Aeson.Encode.Pretty +import qualified Data.ByteString.Lazy as LB +import Data.Monoid +import Data.Text () + +import System.FilePath () + +-- ------------------------------------------------------------ + +-- +outputValue :: (Functor m, MonadIO m, ToJSON c) => String -> c -> m () +outputValue fn c + = liftIO (jsonOutput True toFile c) + where + toFile bs + | fn == "" + || + fn == "-" + = LB.putStr bs + | otherwise + = LB.writeFile fn bs + +-- TODO: merge with Hunt.Server.Client.handleJsonResponse +--evalOkRes :: MonadIO m => Maybe LB.ByteString -> m () +--evalOkRes Nothing +-- = return () +--evalOkRes (Just bs) +-- | isOkMsg bs = return () +-- | otherwise = liftIO . ioError . userError $ +-- "server error: \"ok\" expected, but got " ++ show (LC.unpack bs) +-- where +-- isOkMsg s = maybe False ((== "ok") . unCmdRes) js +-- where +-- js :: Maybe (CmdRes Text) +-- js = decode s + +--evalErrRes :: MonadIO m => Int -> LB.ByteString -> m a +--evalErrRes rc bs +-- = liftIO . ioError . userError $ +-- unwords ["server error: rc=", show rc, "msg=", msg ce] +-- where +-- ce :: Maybe CmdError +-- ce = decode bs + +-- msg Nothing = "result is not a JSON error message" +-- msg (Just e) = show e + +-- ------------------------------------------------------------ + +jsonOutput :: (ToJSON c) => Bool -> (LB.ByteString -> IO a) -> c -> IO a +jsonOutput pretty io x + = io $ (if pretty then encodePretty' encConfig else encode) x + where + encConfig :: Config + encConfig + = Config { confIndent = 2 + , confCompare + = keyOrder ["description", "index", "uri"] + `mappend` + compare + } diff --git a/test/Hunt.hs b/test/Hunt.hs new file mode 100644 --- /dev/null +++ b/test/Hunt.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} + +module Main where + +import Hunt.AnalyzerTests +import Hunt.IndexTests +import Hunt.InterpreterTests +import Hunt.QueryParserTests +--import Hunt.RankingTests + +import Test.Framework + +main :: IO () +main = defaultMain + $ analyzerTests + ++ contextTypeTests + ++ interpreterTests + ++ queryParserTests +-- XXX refactor ranking tests to be conform with new ranking +-- ++ rankingTests diff --git a/test/Strictness.hs b/test/Strictness.hs new file mode 100644 --- /dev/null +++ b/test/Strictness.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} + +module Main where + +import Hunt.Strict.DocTable +import Hunt.Strict.Index +import Hunt.Strict.ContextIndex + +import Test.Framework + +main :: IO () +main = defaultMain $ docTableTests ++ indexTests ++ contextIndexTests +