diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,8 +1,13 @@ +Version 0.3 2014-01-20 +* Refactored modules +* New Tokenizer module. +* NLP package moved to separate project + + Version 0.2 2014-01-08 * Changes in Index API * Add recursive option to command line tool. * Post list contains document id instead of document name. - Version 0.1 2014-01-04 diff --git a/Condor.cabal b/Condor.cabal --- a/Condor.cabal +++ b/Condor.cabal @@ -1,27 +1,33 @@ name: Condor -version: 0.2 +version: 0.3 cabal-version: >= 1.10 build-type: Simple author: Krzysztof Langner maintainer: klangner@gmail.com synopsis: Information retrieval library -description: Library for indexing and searching text documents homepage: https://github.com/klangner/Condor Bug-reports: https://github.com/klangner/Condor/issues stability: Unstable interface, incomplete features. category: Search, Text, Library -License: MIT +License: BSD3 License-file: LICENSE Extra-Source-Files: CHANGES +description: + An Information Retrieval (IR) library which consists of the following components: + . + * Search - for indexing and searching text documents. + Check "Condor.Search.Index" for API information + . + * Readers for reading documents from disk. Check "Condor.Reader.Text" folder text reader. source-repository head type: git location: https://github.com/klangner/Condor executable condor - hs-source-dirs: src - main-is: Main.hs + hs-source-dirs: src-app, + src default-language: Haskell2010 build-depends: base >= 4 && <4.7, @@ -29,31 +35,33 @@ containers >=0.5.0 && <0.6, directory >=1.2.0 && <1.3, filepath >=1.3.0 && <1.4, - text >=1 && <1.1 + text >=1 && <1.1, + glider-nlp >= 0.1 && <1 ghc-options: -Wall other-modules: - Condor.Index, - Condor.Readers.Text, - Condor.Text, + Condor.Commons.Document, + Condor.Commons.Unsafe, + Condor.Reader.Text, + Condor.Search.Index, IO + main-is: Main.hs library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall exposed-modules: - Condor.DataTypes, - Condor.Index, - Condor.Language.English.Porter, - Condor.Language.English.StopWords, - Condor.Readers.Text, - Condor.Text + Condor.Commons.Document, + Condor.Reader.Text, + Condor.Search.Index build-depends: base >= 4 && <4.7, containers >=0.5.0 && <0.6, binary >=0.5.1 && <0.6, - text >=1 && <1.1 + text >=1 && <1.1, + glider-nlp >= 0.1 && <1 + other-modules: Condor.Commons.Unsafe test-suite unit-tests type: detailed-0.9 @@ -66,19 +74,15 @@ Cabal >=1.16.0 && <1.17, containers >=0.5.0 && <0.6, binary >=0.5.1 && <0.6, - text >=1 && <1.1 + text >=1 && <1.1, + glider-nlp >= 0.1 && <1 other-modules: - Condor.Index, - Condor.IndexTest, - Condor.Language.English.Porter, - Condor.Language.English.PorterTest, - Condor.Language.English.StopWords, - Condor.Text, - Condor.TextTest, - Distribution.TestSuite.HUnit, - Condor.DataTypes + Condor.Commons.Document, + Condor.Commons.Unsafe, + Condor.Search.Index, + Condor.Search.IndexTest, + Distribution.TestSuite.HUnit hs-source-dirs: src, test-src - diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,20 +1,26 @@ -The MIT License (MIT) - Copyright (c) 2014 Krzysztof Langner +All rights reserved. -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: +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. -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. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src-app/IO.hs b/src-app/IO.hs new file mode 100644 --- /dev/null +++ b/src-app/IO.hs @@ -0,0 +1,39 @@ +{- | +Module : IO +Copyright : Copyright (C) 2013-2014 Krzysztof Langner +License : BSD3 + +Helper module with functions operating on IO +-} +module IO + ( listFiles + , listDirs + )where + +import System.Directory (canonicalizePath, getDirectoryContents, doesDirectoryExist) +import Data.List +import Control.Monad + + +-- | list files +listFiles :: FilePath -> IO [FilePath] +listFiles p = do + contents <- list p + filterM (fmap not . doesDirectoryExist) contents + + +-- | list subdirectories +listDirs :: FilePath -> IO [FilePath] +listDirs p = do + contents <- list p + filterM doesDirectoryExist contents + +-- | list directory content +list :: FilePath -> IO [FilePath] +list p = do + ds <- getDirectoryContents p + let filtered = filter f ds + path <- canonicalizePath $ p + return $ map ((path++"/")++) filtered + where f x = and [x /= ".", x /= "..", (not . isPrefixOf ".") x] + diff --git a/src-app/Main.hs b/src-app/Main.hs new file mode 100644 --- /dev/null +++ b/src-app/Main.hs @@ -0,0 +1,92 @@ +module Main where + +import System.Environment +import System.Directory (removeFile, renameFile) +import Control.Exception +import Control.Monad +import Data.Binary +import qualified Data.Text as T +import Condor.Search.Index +import qualified Condor.Reader.Text as TextReader +import IO + + +-- | Commands dispatcher +dispatch :: [(String, [String] -> Index -> IO ())] +dispatch = [ ("index", indexCmd) + , ("search", searchCmd) + ] +indexFile :: FilePath +indexFile = "index.db" + +-- This is dummy main function (not working yet) +main :: IO () +main = do + idx <- (readIndex indexFile) `catch` readIndexError + (command:args) <- getArgs + let (Just action) = lookup command dispatch + action args idx + + +-- | Read Index data from file +readIndex :: FilePath -> IO Index +readIndex p = {-# SCC "read" #-} decodeFile p + +-- | Create empty index if can't read from file +readIndexError :: IOError -> IO Index +readIndexError _ = return emptyIndex + +-- | Silent IO error +nullError :: IOError -> IO () +nullError _ = return () + +-- | Write index data to the file +writeIndex :: FilePath -> Index -> IO () +writeIndex p idx = do + putStrLn $ "Entries count: " ++ show (termCount idx) + let temp = p ++ ".temp" + encodeFile temp idx + removeFile p `catch` nullError + renameFile temp p + +-- | Command to index all files from given folder +indexCmd :: [String] -> Index -> IO () +indexCmd [p] idx = do + idx2 <- indexFolder False idx p + writeIndex indexFile idx2 +indexCmd [p, "-r"] idx = do + idx2 <- indexFolder True idx p + writeIndex indexFile idx2 +indexCmd _ _ = error "add command requires path to the documents" + +-- | Index given folder +indexFolder :: Bool -> Index -> FilePath -> IO Index +indexFolder False idx p = do + putStrLn $ "Added folder: " ++ p + fs <- listFiles p + idx2 <- foldM addFile idx fs + return idx2 +indexFolder True idx p = do + idx2 <- indexFolder False idx p + ds <- listDirs p + idx3 <- foldM (indexFolder True) idx2 ds + return idx3 + +-- | Add file to the index +addFile :: Index -> FilePath -> IO Index +addFile idx p = do + doc <- TextReader.readDocument p + let idx2 = addDocument doc idx + return idx2 + + +-- | Command tosearch index +searchCmd :: [String] -> Index -> IO () +searchCmd (t:_) idx = do + let result = {-# SCC "search" #-} search idx (T.pack t) + putStrLn $ "Search term: " ++ show t ++ " found in documents: " + _ <- mapM (putStrLn . show) result + return () +searchCmd _ _ = error "search command requires search terms" + + diff --git a/src/Condor/Commons/Document.hs b/src/Condor/Commons/Document.hs new file mode 100644 --- /dev/null +++ b/src/Condor/Commons/Document.hs @@ -0,0 +1,48 @@ +{- | +Module : Condor.Commons.Document +Copyright : Copyright (C) 2014 Krzysztof Langner +License : BSD3 + +Maintainer : Krzysztof Langner +Stability : alpha +Portability : portable + +Contains basic data structures uses by other modules. +-} +module Condor.Commons.Document + ( DocName + , Document(..) + , docFromStrings + , docName + , docText + ) where + +import Prelude hiding (concat, map) +import qualified Data.List as List +import Data.Text + +-- | Document name +type DocName = Text + +-- | Field consists of title and content +data Field = Field Text Text + +-- | Document with name and contents +data Document = Document DocName [Field] + + +-- | Create simple field from strings +fieldFromStrings :: String -> String -> Field +fieldFromStrings k v = Field (pack k) (pack v) + +-- | Create simple document with name and single field content. +docFromStrings :: String -> String -> Document +docFromStrings t c = Document (pack t) [fieldFromStrings "content" c] + +-- | Get document name +docName :: Document -> Text +docName (Document a _) = a + +-- | Get text from all fields +docText :: Document -> Text +docText (Document _ fs) = concat $ List.map (\(Field _ y) -> y) fs diff --git a/src/Condor/Commons/Unsafe.hs b/src/Condor/Commons/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Condor/Commons/Unsafe.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- | +Module : Condor.Commons.Unsafe +Copyright : Copyright (C) 2013-2014 Krzysztof Langner +License : BSD3 + +Maintainer : Krzysztof Langner +Stability : alpha +Portability : portable + +This module contains code which is necessary but should be removed if possible. +The warning here are turn off. +-} +module Condor.Commons.Unsafe + ( + ) where + +import Data.Text +import Data.Binary +import Data.Text.Encoding (encodeUtf8, decodeUtf8) + + +-- | This instance is necessary so Index can be serialized to and from disk using binary format +instance Binary Text where + put i = do put (encodeUtf8 i) + get = do i <- get + return $ decodeUtf8 i + diff --git a/src/Condor/DataTypes.hs b/src/Condor/DataTypes.hs deleted file mode 100644 --- a/src/Condor/DataTypes.hs +++ /dev/null @@ -1,46 +0,0 @@ -{- | -Module : Condor.DataTypes -Copyright : Copyright (C) 2014 Krzysztof Langner -License : The MIT License (MIT) - -Maintainer : Krzysztof Langner -Stability : alpha -Portability : portable - -Common to all modules data types definitions. --} -module Condor.DataTypes - ( DocName - , Document(..) - , docFromStrings - , docName - , docText - ) where - -import qualified Data.Text as T - - -type DocName = T.Text - --- | Field consists of title and content -data Field = Field T.Text T.Text - --- | Document with name and contents -data Document = Document DocName [Field] - - --- | Create simple field from strings -fieldFromStrings :: String -> String -> Field -fieldFromStrings k v = Field (T.pack k) (T.pack v) - --- | Create simple document with name and single field content. -docFromStrings :: String -> String -> Document -docFromStrings t c = Document (T.pack t) [fieldFromStrings "content" c] - --- | Get document name -docName :: Document -> T.Text -docName (Document a _) = a - --- | Get text from all fields -docText :: Document -> T.Text -docText (Document _ fs) = T.concat $ map (\(Field _ y) -> y) fs diff --git a/src/Condor/Index.hs b/src/Condor/Index.hs deleted file mode 100644 --- a/src/Condor/Index.hs +++ /dev/null @@ -1,118 +0,0 @@ -{- | -Module : Condor.Index -Copyright : Copyright (C) 2013-2014 Krzysztof Langner -License : The MIT License (MIT) - -Maintainer : Krzysztof Langner -Stability : alpha -Portability : portable - -This module contains functions which create, update and search index. -Default implementation uses algorithms for english language (stemming, stop words etc.) - -Functions in this module (for performance reasons) are based on unicode strings Data.Text. - --} -module Condor.Index - ( DocName - , Index - , addDocument - , addDocTerms - , emptyIndex - , search - , searchTerms - , termCount - ) where - -import qualified Data.Map as Map -import qualified Data.List as List -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Data.Binary -import Condor.Text -import Condor.DataTypes (DocName, Document(..), docName, docText) -import Condor.Language.English.StopWords (isStopWord) -import Condor.Language.English.Porter (stem) - - -type Term = T.Text - --- | Inverted index -data Index = Index { terms :: Map.Map Term [Int] - , docs :: [DocName] - } - --- An instance of Binary to encode and decode an IndexParams in binary -instance Binary Index where - put i = do - put (terms i) - put (docs i) - get = do i <- get - d <- get - return $ Index i d - --- An instance of Binary to encode and decode T.Text -instance Binary T.Text where - put i = do put (E.encodeUtf8 i) - get = do i <- get - return $ E.decodeUtf8 i - - --- | Create empty index. --- This index will be configured for english language. -emptyIndex :: Index -emptyIndex = Index Map.empty [] - - --- | Add document to the index. --- This function uses algorithms for english language to split document content --- into index terms. -addDocument :: Document -> Index -> Index -addDocument d idx = addDocTerms (docName d) (splitTerms content) idx - where content = docText d - - --- | Add document to the index. --- This function should be used if document content should be splitted into terms --- with custom algorithms. -addDocTerms :: DocName -> [Term] -> Index -> Index -addDocTerms d c ix = Index (foldl f (terms ix) c) (d:docs ix) - where f ix' t = case Map.lookup t ix' of - Just a -> Map.insert t (index:a) ix' - Nothing -> Map.insert t [index] ix' - index = length (docs ix) - - --- | Search terms given as single string in the index --- This function uses algorithms for english language to split query into tokens. -search :: Index -> String -> [DocName] -search ix s = searchTerms ix (splitTerms (T.pack s)) - - --- | Search terms given as array in the index. --- This function should be used if query should be splitted into terms --- with custom algorithms -searchTerms :: Index -> [Term] -> [DocName] -searchTerms ix s = List.nub $ foldl (++) [] ys - where ys = map (findDocs ix) s - - --- | Search single term in the index -findDocs :: Index -> Term -> [DocName] -findDocs ix s = case Map.lookup s (terms ix) of - Just a -> map ((reverse (docs ix))!!) a - Nothing -> [] - - --- | Get the number of terms in indexs -termCount :: Index -> Int -termCount ix = Map.size (terms ix) - - --- | Split text into terms. --- This function removes stop words and stems words -splitTerms :: T.Text -> [Term] -splitTerms s = map stem (filter (not . isStopWord) t) - where t = tokenize s - - diff --git a/src/Condor/Language/English/Porter.hs b/src/Condor/Language/English/Porter.hs deleted file mode 100644 --- a/src/Condor/Language/English/Porter.hs +++ /dev/null @@ -1,168 +0,0 @@ -{- | This code was taken from: http://tartarus.org/~martin/PorterStemmer/haskell.txt --} -module Condor.Language.English.Porter (stem) where - -import Control.Monad -import Data.Maybe -import Data.List -import qualified Data.Text as T - - --- | API stemming function -stem :: T.Text -> T.Text -stem s | T.length s < 3 = s - | otherwise = T.pack $ allSteps (T.unpack s) - - -isConsonant :: [Char] -> Int -> Bool -isConsonant str i - | c `elem` "aeiou" = False - | c == 'y' = i == 0 || isVowel str (i - 1) - | otherwise = True - where - c = str !! i - -isVowel :: [Char] -> Int -> Bool -isVowel = (not .) . isConsonant - -byIndex :: ([a] -> [Int] -> t) -> [a] -> t -byIndex fun str = fun str [0..length str - 1] - -measure :: [Char] -> Int -measure = length . filter not . init . (True:) . map head . group . byIndex (map . isConsonant) - -containsVowel :: [Char] -> Bool -containsVowel = byIndex (any . isVowel) - -endsWithDouble :: [Char] -> Bool -endsWithDouble = startsWithDouble . reverse - where - startsWithDouble l | length l < 2 = False - | otherwise = let (x:y:_) = l in x == y && x `notElem` "aeiou" - -cvc :: [Char] -> Bool -cvc word | length word < 3 = False - | otherwise = isConsonant word lastIndex && - isVowel word (lastIndex - 1) && - isConsonant word (lastIndex - 2) && - last word `notElem` "wxy" - where lastIndex = length word - 1 - -statefulReplace :: Eq a => ([a] -> Bool) -> [a] -> [a] -> [a] -> Maybe (Either [a] [a]) -statefulReplace predicate str end replacement - | end `isSuffixOf` str = Just replaced - | otherwise = Nothing - where - part = take (length str - length end) str - replaced | predicate part = Right (part ++ replacement) - | otherwise = Left str - -replaceEnd :: Eq a => ([a] -> Bool) -> [a] -> [a] -> [a] -> Maybe [a] -replaceEnd predicate str end replacement = do - result <- statefulReplace predicate str end replacement - return (either id id result) - -findStem :: Eq a => ([a] -> Bool) -> [a] -> [([a], [a])] -> Maybe [a] -findStem f word pairs = msum $ map (uncurry (replaceEnd f word)) pairs - -measureGT :: Int -> [Char] -> Bool -measureGT = flip ((>) . measure) - -step1a :: [Char] -> [Char] -step1a word = fromMaybe word result - where result = findStem (const True) word [("sses", "ss"), ("ies", "i"), ("ss", "ss"), ("s", "")] - -beforeStep1b :: [Char] -> Either [Char] [Char] -beforeStep1b word = fromMaybe (Left word) result - where - cond23 x = do { v <- x; either (const Nothing) (return . Right) v } - cond1 x = do { v <- x; return (Left v) } - result = - cond1 (replaceEnd (measureGT 0) word "eed" "ee") `mplus` - cond23 (statefulReplace containsVowel word "ed" "" ) `mplus` - cond23 (statefulReplace containsVowel word "ing" "" ) - -afterStep1b :: [Char] -> [Char] -afterStep1b word = fromMaybe word result - where - double = endsWithDouble word && not (any ((`isSuffixOf` word) . return) "lsz") - mEq1AndCvc = measure word == 1 && cvc word - iif cond val = if cond then Just val else Nothing - result = findStem (const True) word [("at", "ate"), ("bl", "ble"), ("iz", "ize")] - `mplus` iif double (init word) - `mplus` iif mEq1AndCvc (word ++ "e") - -step1b :: [Char] -> [Char] -step1b = either id afterStep1b . beforeStep1b - -step1c :: [Char] -> [Char] -step1c word = fromMaybe word result - where result = replaceEnd containsVowel word "y" "i" - -step1 :: [Char] -> [Char] -step1 = step1c . step1b . step1a - -step2 :: [Char] -> [Char] -step2 word = fromMaybe word result - where - result = findStem (measureGT 0) word - [ ("ational", "ate" ) - , ("tional", "tion") - , ("enci", "ence") - , ("anci", "ance") - , ("izer", "ize" ) - , ("bli", "ble" ) - , ("alli", "al" ) - , ("entli", "ent" ) - , ("eli", "e" ) - , ("ousli", "ous" ) - , ("ization", "ize" ) - , ("ation", "ate" ) - , ("ator", "ate" ) - , ("alism", "al" ) - , ("iveness", "ive" ) - , ("fulness", "ful" ) - , ("ousness", "ous" ) - , ("aliti", "al" ) - , ("iviti", "ive" ) - , ("biliti", "ble" ) - , ("logi", "log" ) ] - -step3 :: [Char] -> [Char] -step3 word = fromMaybe word result - where - result = findStem (measureGT 0) word - [ ("icate", "ic") - , ("ative", "" ) - , ("alize", "al") - , ("iciti", "ic") - , ("ical" , "ic") - , ("ful" , "" ) - , ("ness" , "" ) ] - -step4 :: [Char] -> [Char] -step4 word = fromMaybe word result - where - gt1andST str = (measureGT 1) str && any ((`isSuffixOf` str) . return) "st" - findGT1 = findStem (measureGT 1) word . map (flip (,) "") - result = (findGT1 ["al", "ance", "ence", "er", "ic", "able", "ible", "ant", "ement", "ment", "ent"]) `mplus` - (findStem gt1andST word [("ion","")]) `mplus` - (findGT1 ["ou", "ism", "ate", "iti", "ous", "ive", "ize"]) - -step5a :: [Char] -> [Char] -step5a word = fromMaybe word result - where - test str = (measureGT 1 str) || ((measure str == 1) && (not $ cvc str)) - result = replaceEnd test word "e" "" - -step5b :: [Char] -> [Char] -step5b word = fromMaybe word result - where - cond s = last s == 'l' && measureGT 1 s - result = replaceEnd cond word "l" "" - -step5 :: [Char] -> [Char] -step5 = step5b . step5a - -allSteps :: [Char] -> [Char] -allSteps = step5 . step4 . step3 . step2 . step1 diff --git a/src/Condor/Language/English/StopWords.hs b/src/Condor/Language/English/StopWords.hs deleted file mode 100644 --- a/src/Condor/Language/English/StopWords.hs +++ /dev/null @@ -1,152 +0,0 @@ -{- | -Module : Condor.Language.English.StopWords -Copyright : Copyright (C) 2013-2014 Krzysztof Langner -License : The MIT License (MIT) - -Maintainer : Krzysztof Langner -Stability : alpha -Portability : portable - -Module contains functions specific to the english language - --} -module Condor.Language.English.StopWords (isStopWord) where - -import qualified Data.Set as S -import qualified Data.Text as T - - --- | Predicate to check if given words is a stop word -isStopWord :: T.Text -> Bool -isStopWord w = S.member w stopWords - -stopWords :: S.Set T.Text -stopWords = S.fromList $ map T.pack - [ "i" - , "me" - , "my" - , "myself" - , "we" - , "our" - , "ours" - , "ourselves" - , "you" - , "your" - , "yours" - , "yourself" - , "yourselves" - , "he" - , "him" - , "his" - , "himself" - , "she" - , "her" - , "hers" - , "herself" - , "it" - , "its" - , "itself" - , "they" - , "them" - , "their" - , "theirs" - , "themselves" - , "what" - , "which" - , "who" - , "whom" - , "this" - , "that" - , "these" - , "those" - , "am" - , "is" - , "are" - , "was" - , "were" - , "be" - , "been" - , "being" - , "have" - , "has" - , "had" - , "having" - , "do" - , "does" - , "did" - , "doing" - , "a" - , "an" - , "the" - , "and" - , "but" - , "if" - , "or" - , "because" - , "as" - , "until" - , "while" - , "of" - , "at" - , "by" - , "for" - , "with" - , "about" - , "against" - , "between" - , "into" - , "through" - , "during" - , "before" - , "after" - , "above" - , "below" - , "to" - , "from" - , "up" - , "down" - , "in" - , "out" - , "on" - , "off" - , "over" - , "under" - , "again" - , "further" - , "then" - , "once" - , "here" - , "there" - , "when" - , "where" - , "why" - , "how" - , "all" - , "any" - , "both" - , "each" - , "few" - , "more" - , "most" - , "other" - , "some" - , "such" - , "no" - , "nor" - , "not" - , "only" - , "own" - , "same" - , "so" - , "than" - , "too" - , "very" - , "s" - , "t" - , "can" - , "will" - , "just" - , "don" - , "should" - , "now" - ] diff --git a/src/Condor/Reader/Text.hs b/src/Condor/Reader/Text.hs new file mode 100644 --- /dev/null +++ b/src/Condor/Reader/Text.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE BangPatterns #-} +{- | +Module : Condor.Reader.Text +Copyright : Copyright (C) 2014 Krzysztof Langner +License : BSD3 + +Maintainer : Krzysztof Langner +Stability : alpha +Portability : portable + +Reader for text files. Strict version. +Uses bang patters to force hGetContents to read the whole file. +-} +module Condor.Reader.Text(readDocument) where + +import System.IO +import Condor.Commons.Document (Document, docFromStrings) + + +-- | read text as UTF8 and return as document +readDocument :: FilePath -> IO Document +readDocument path = do + withFile path ReadMode (\h -> do + hSetEncoding h utf8 + !contents <- hGetContents h + hClose h + return $ docFromStrings path contents + ) + diff --git a/src/Condor/Readers/Text.hs b/src/Condor/Readers/Text.hs deleted file mode 100644 --- a/src/Condor/Readers/Text.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{- | -Module : Condor.Readers.Text -Copyright : Copyright (C) 2014 Krzysztof Langner -License : The MIT License (MIT) - -Maintainer : Krzysztof Langner -Stability : alpha -Portability : portable - -Reader for text files. Strict version. -Uses bang patters to force hGetContents to read file --} -module Condor.Readers.Text(readDocument) where - -import System.IO -import Condor.DataTypes (Document, docFromStrings) - - --- | read text as UTF8 and return as document -readDocument :: FilePath -> IO Document -readDocument path = do - withFile path ReadMode (\h -> do - hSetEncoding h utf8 - !contents <- hGetContents h - hClose h - return $ docFromStrings path contents - ) - diff --git a/src/Condor/Search/Index.hs b/src/Condor/Search/Index.hs new file mode 100644 --- /dev/null +++ b/src/Condor/Search/Index.hs @@ -0,0 +1,130 @@ +{- | +Module : Condor.Search.Index +Copyright : Copyright (C) 2013-2014 Krzysztof Langner +License : BSD3 + +Maintainer : Krzysztof Langner +Stability : alpha +Portability : portable + +Memory based index. +This module contains functions which create, update and search index. +Default implementation uses algorithms for english language (stemming, stop words etc.) + +Functions in this module (for performance reasons) are based on unicode strings from module Data.Text. + +Basic usage: + +> import Condor.Search.Index (addDocument, search) +> import Condor.Commons.Document (docFromStrings) +> +> let idx = addDocument emptyIndex $ docFromStrings "My document 1" "This is a document content." +> search idx "content" +> ["My document 1"] + +-} +module Condor.Search.Index + ( Index + , Term + , addDocument + , addDocTerms + , emptyIndex + , docCount + , search + , searchTerms + , termCount + ) where + +import Data.Text (Text) +import qualified Data.Map as Map +import qualified Data.List as List +import Data.Binary + +import Condor.Commons.Unsafe() +import Condor.Commons.Document (DocName, Document(..), docName, docText) +import Glider.NLP.Language.English.StopWords (isStopWord) +import Glider.NLP.Language.English.Porter (stem) +import Glider.NLP.Tokenizer + + +-- | Single term. Could be normalized word +type Term = Text + +-- | Inverted index +data Index = Index { terms :: Map.Map Term [Int] + , docs :: [DocName] + } + +-- | An instance of Binary to encode and decode an IndexParams in binary +instance Binary Index where + put i = do + put (terms i) + put (docs i) + get = do i <- get + d <- get + return $ Index i d + + +-- | Create empty index. +-- This index will be configured for english language. +emptyIndex :: Index +emptyIndex = Index Map.empty [] + + +-- | Add document to the index. +-- This function uses algorithms for english language to split document content +-- into index terms. +addDocument :: Document -> Index -> Index +addDocument d = addDocTerms (docName d) (splitTerms content) + where content = docText d + + +-- | Add document to the index. +-- This function should be used if document content should be splitted into terms +-- with custom algorithms. +addDocTerms :: DocName -> [Term] -> Index -> Index +addDocTerms d c ix = Index (foldl f (terms ix) c) (d:docs ix) + where f ix' t = case Map.lookup t ix' of + Just a -> Map.insert t (index:a) ix' + Nothing -> Map.insert t [index] ix' + index = length (docs ix) + + +-- | Search terms given as single string in the index +-- This function uses algorithms for english language to split query into tokens. +search :: Index -> Text -> [DocName] +search ix s = searchTerms ix (splitTerms s) + + +-- | Search terms given as array in the index. +-- This function should be used if query should be splitted into terms +-- with custom algorithms +searchTerms :: Index -> [Term] -> [DocName] +searchTerms ix s = List.nub $ foldl (++) [] ys + where ys = map (findDocs ix) s + + +-- | Search single term in the index +findDocs :: Index -> Term -> [DocName] +findDocs ix s = case Map.lookup s (terms ix) of + Just a -> map ((reverse (docs ix))!!) a + Nothing -> [] + + +-- | Get the number of terms in the index +termCount :: Index -> Int +termCount ix = Map.size (terms ix) + + +-- | Get the number of documents in the index +docCount :: Index -> Int +docCount ix = length (docs ix) + + +-- | Split text into terms. +-- This function removes stop words and stems words +splitTerms :: Text -> [Term] +splitTerms s = map stem (filter (not . isStopWord) t) + where t = (foldCase . getWords . tokenize) s + + diff --git a/src/Condor/Text.hs b/src/Condor/Text.hs deleted file mode 100644 --- a/src/Condor/Text.hs +++ /dev/null @@ -1,37 +0,0 @@ -{- | -Module : Condor.Text -Copyright : Copyright (C) 2013-2014 Krzysztof Langner -License : The MIT License (MIT) - -Maintainer : Krzysztof Langner -Stability : alpha -Portability : portable - -Helper module with functions operating on Text. -Functions in this module are language neutral. -Functions which are specific to the given language can be found in -Condor.Language. modules. - --} -module Condor.Text - ( tokenize - ) where - -import qualified Data.Text as T - - --- | List of separators -isSeparator :: Char -> Bool -isSeparator s = elem s " .,!?" - --- | Remove suffix separator -removeSeparators:: T.Text -> T.Text -removeSeparators = T.dropWhile isSeparator - - --- | Split string into tokens -tokenize :: T.Text -> [T.Text] -tokenize xs = if T.length s == 0 then [] - else (T.toCaseFold t : tokenize r) - where s = removeSeparators xs - (t, r) = T.break isSeparator (removeSeparators xs) diff --git a/src/IO.hs b/src/IO.hs deleted file mode 100644 --- a/src/IO.hs +++ /dev/null @@ -1,39 +0,0 @@ -{- | -Module : IO -Copyright : Copyright (C) 2013-2014 Krzysztof Langner -License : The MIT License (MIT) - -Helper module with functions operating on IO --} -module IO - ( listFiles - , listDirs - )where - -import System.Directory (canonicalizePath, getDirectoryContents, doesDirectoryExist) -import Data.List -import Control.Monad - - --- | list files -listFiles :: FilePath -> IO [FilePath] -listFiles p = do - contents <- list p - filterM (fmap not . doesDirectoryExist) contents - - --- | list subdirectories -listDirs :: FilePath -> IO [FilePath] -listDirs p = do - contents <- list p - filterM doesDirectoryExist contents - --- | list directory content -list :: FilePath -> IO [FilePath] -list p = do - ds <- getDirectoryContents p - let filtered = filter f ds - path <- canonicalizePath $ p - return $ map ((path++"/")++) filtered - where f x = and [x /= ".", x /= "..", (not . isPrefixOf ".") x] - diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,91 +0,0 @@ -module Main where - -import System.Environment -import System.Directory (removeFile, renameFile) -import Control.Exception -import Control.Monad -import Data.Binary -import Condor.Index -import qualified Condor.Readers.Text as TextReader -import IO - - --- | Commands dispatcher -dispatch :: [(String, [String] -> Index -> IO ())] -dispatch = [ ("index", indexCmd) - , ("search", searchCmd) - ] -indexFile :: FilePath -indexFile = "index.db" - --- This is dummy main function (not working yet) -main :: IO () -main = do - idx <- (readIndex indexFile) `catch` readIndexError - (command:args) <- getArgs - let (Just action) = lookup command dispatch - action args idx - - --- | Read Index data from file -readIndex :: FilePath -> IO Index -readIndex p = {-# SCC "read" #-} decodeFile p - --- | Create empty index if can't read from file -readIndexError :: IOError -> IO Index -readIndexError _ = return emptyIndex - --- | Silent IO error -nullError :: IOError -> IO () -nullError _ = return () - --- | Write index data to the file -writeIndex :: FilePath -> Index -> IO () -writeIndex p idx = do - putStrLn $ "Entries count: " ++ show (termCount idx) - let temp = p ++ ".temp" - encodeFile temp idx - removeFile p `catch` nullError - renameFile temp p - --- | Command to index all files from given folder -indexCmd :: [String] -> Index -> IO () -indexCmd [p] idx = do - idx2 <- indexFolder False idx p - writeIndex indexFile idx2 -indexCmd [p, "-r"] idx = do - idx2 <- indexFolder True idx p - writeIndex indexFile idx2 -indexCmd _ _ = error "add command requires path to the documents" - --- | Index given folder -indexFolder :: Bool -> Index -> FilePath -> IO Index -indexFolder False idx p = do - putStrLn $ "Added folder: " ++ p - fs <- listFiles p - idx2 <- foldM addFile idx fs - return idx2 -indexFolder True idx p = do - idx2 <- indexFolder False idx p - ds <- listDirs p - idx3 <- foldM (indexFolder True) idx2 ds - return idx3 - --- | Add file to the index -addFile :: Index -> FilePath -> IO Index -addFile idx p = do - doc <- TextReader.readDocument p - let idx2 = addDocument doc idx - return idx2 - - --- | Command tosearch index -searchCmd :: [String] -> Index -> IO () -searchCmd (t:_) idx = do - let result = {-# SCC "search" #-} search idx t - putStrLn $ "Search term: " ++ show t ++ " found in documents: " - _ <- mapM (putStrLn . show) result - return () -searchCmd _ _ = error "search command requires search terms" - - diff --git a/test-src/AllTests.hs b/test-src/AllTests.hs --- a/test-src/AllTests.hs +++ b/test-src/AllTests.hs @@ -2,12 +2,9 @@ import qualified Distribution.TestSuite as C import qualified Distribution.TestSuite.HUnit as H -import Condor.TextTest (testCases) -import Condor.IndexTest (testCases) -import Condor.Language.English.PorterTest (testCases) +import Condor.Search.IndexTest (testCases) tests :: IO [C.Test] -tests = return $ map (uncurry H.test) $ Condor.TextTest.testCases - ++ Condor.IndexTest.testCases - ++ Condor.Language.English.PorterTest.testCases +tests = return $ map (uncurry H.test) $ Condor.Search.IndexTest.testCases + diff --git a/test-src/Condor/IndexTest.hs b/test-src/Condor/IndexTest.hs deleted file mode 100644 --- a/test-src/Condor/IndexTest.hs +++ /dev/null @@ -1,100 +0,0 @@ -{- | -Module : Condor.IndexTest -Copyright : Copyright (C) 2013-2014 Krzysztof Langner -License : The MIT License (MIT) - -Maintainer : Krzysztof Langner -Stability : alpha -Portability : portable - -Unit tests for Condor.Index module --} - -module Condor.IndexTest (testCases) where - -import Data.Binary -import qualified Data.Text as T -import Condor.DataTypes (DocName, Document(..), docFromStrings) -import Condor.Index -import Test.HUnit - - -testCases :: [(String, Test)] -testCases = [ ( "Empty index has length 0" - , TestCase $ prop_empty) - - , ( "Space separates terms" - , TestCase $ prop_termCount (docFromStrings "doc1" "one two three") 3) - - , ( "Check stop words" - , TestCase $ prop_termCount (docFromStrings "doc1" "one and two or three") 3) - - , ( "Search for term with the same case" - , TestCase $ prop_search "two" (T.pack "doc1") [docFromStrings "doc1" "one two three"]) - - , ( "Search for first term" - , TestCase $ prop_search "one" (T.pack "doc1") [ docFromStrings "doc1" "one two three" - , docFromStrings "doc2" "forty two" - ]) - - , ( "Search for term in second document" - , TestCase $ prop_search "two" (T.pack "doc2") [ docFromStrings "doc1" "one two three" - , docFromStrings "doc2" "forty two" - ]) - - , ( "Search for lower case term. Document has upper case" - , TestCase $ prop_search "two" (T.pack "doc1") [docFromStrings "doc1" "One Two Three"]) - - , ( "Search for upperr case term. Document has lower case" - , TestCase $ prop_search "Three" (T.pack "doc1") [docFromStrings "doc1" "one two three"]) - - , ( "Search for 2 terms" - , TestCase $ prop_search "one Three" (T.pack "doc1") [docFromStrings "doc1" "one two three"]) - - , ( "Single doc" - , TestCase $ prop_search_count "one" 1 [ docFromStrings "doc1" "one two three" - , docFromStrings "doc2" "forty two" - ]) - - , ( "Document should be returned only once" - , TestCase $ prop_search_count "two one" 2 [ docFromStrings "doc1" "one two three" - , docFromStrings "doc2" "forty two" - ]) - - , ( "encode . decode == id" - , TestCase $ prop_serialize [ docFromStrings "doc1" "one two three" - , docFromStrings "doc2" "forty two" - ]) - ] - --- | Helper function to populate index -indexFromDocs :: [Document] -> Index -indexFromDocs ds = foldl f emptyIndex ds - where f i d = addDocument d i - - --- | Check empty index -prop_empty :: Assertion -prop_empty = assertEqual "Empty index has 0 size" 0 (termCount emptyIndex) - --- | Check if document is found -prop_search :: String -> DocName -> [Document] -> Assertion -prop_search s e ds = assertEqual s True $ elem e (search idx s) - where idx = indexFromDocs ds - --- | Count number of returned documents -prop_search_count :: String -> Int -> [Document] -> Assertion -prop_search_count s n ds = assertEqual s n $ length (search idx s) - where idx = indexFromDocs ds - --- | Check number of terms -prop_termCount :: Document -> Int -> Assertion -prop_termCount d n = assertEqual "Count terms" n (termCount $ addDocument d emptyIndex) - --- | Check empty index -prop_serialize :: [Document] -> Assertion -prop_serialize ds = assertEqual "Serialize" (termCount idx) (termCount idx') - where idx = indexFromDocs ds - idx' = decode (encode idx) - - diff --git a/test-src/Condor/Language/English/PorterTest.hs b/test-src/Condor/Language/English/PorterTest.hs deleted file mode 100644 --- a/test-src/Condor/Language/English/PorterTest.hs +++ /dev/null @@ -1,36 +0,0 @@ -{- | -Module : Condor.Language.English.Porter2Test -Copyright : Copyright (C) 2013-2014 Krzysztof Langner -License : The MIT License (MIT) - -Maintainer : Krzysztof Langner -Stability : alpha -Portability : portable - -Unit tests for Condor.Language.English.Porter2 module --} - -module Condor.Language.English.PorterTest (testCases) where - -import qualified Data.Text as T -import Condor.Language.English.Porter -import Test.HUnit - - -testCases :: [(String, Test)] -testCases = [("Porter", t) | t <- tests] - -tests :: [Test] -tests = [ TestCase $ prop_stem "consign" "consign" - , TestCase $ prop_stem "class's" "class'" - , TestCase $ prop_stem "classes" "class" - , TestCase $ prop_stem "cried" "cri" - , TestCase $ prop_stem "ties" "ti" - , TestCase $ prop_stem "gas" "ga" - , TestCase $ prop_stem "gaps" "gap" - , TestCase $ prop_stem "bleed" "bleed" - , TestCase $ prop_stem "guaranteed" "guarante" - ] - -prop_stem :: String -> String -> Assertion -prop_stem a b = assertEqual a (T.pack b) (stem (T.pack a)) diff --git a/test-src/Condor/Search/IndexTest.hs b/test-src/Condor/Search/IndexTest.hs new file mode 100644 --- /dev/null +++ b/test-src/Condor/Search/IndexTest.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | +Module : Condor.Search.IndexTest +Copyright : Copyright (C) 2013-2014 Krzysztof Langner +License : BSD3 + +Maintainer : Krzysztof Langner +Stability : alpha +Portability : portable +-} + +module Condor.Search.IndexTest (testCases) where + +import Data.Binary +import qualified Data.Text as T +import Condor.Commons.Document (DocName, Document, docFromStrings) +import Condor.Search.Index +import Test.HUnit + + +testCases :: [(String, Test)] +testCases = [ ( "Empty index has length 0" + , TestCase prop_empty) + + , ( "Space separates terms" + , TestCase $ prop_termCount (docFromStrings "doc1" "one two three") 3) + + , ( "Check stop words" + , TestCase $ prop_termCount (docFromStrings "doc1" "one and two or three") 3) + + , ( "There are 2 documents" + , TestCase $ prop_docCount [ docFromStrings "doc1" "one two three" + , docFromStrings "doc2" "forty two" + ] + 2) + + , ( "Search for term with the same case" + , TestCase $ prop_search "two" "doc1" [docFromStrings "doc1" "one two three"]) + + , ( "Search for first term" + , TestCase $ prop_search "one" "doc1" [ docFromStrings "doc1" "one two three" + , docFromStrings "doc2" "forty two" + ]) + + , ( "Search for term in second document" + , TestCase $ prop_search "two" "doc2" [ docFromStrings "doc1" "one two three" + , docFromStrings "doc2" "forty two" + ]) + + , ( "Search for lower case term. Document has upper case" + , TestCase $ prop_search "two" "doc1" [docFromStrings "doc1" "One Two Three"]) + + , ( "Search for upperr case term. Document has lower case" + , TestCase $ prop_search "Three" "doc1" [docFromStrings "doc1" "one two three"]) + + , ( "Search for 2 terms" + , TestCase $ prop_search "one Three" "doc1" [docFromStrings "doc1" "one two three"]) + + , ( "Single doc" + , TestCase $ prop_search_count "one" 1 [ docFromStrings "doc1" "one two three" + , docFromStrings "doc2" "forty two" + ]) + + , ( "Document should be returned only once" + , TestCase $ prop_search_count "two one" 2 [ docFromStrings "doc1" "one two three" + , docFromStrings "doc2" "forty two" + ]) + + , ( "encode . decode == id" + , TestCase $ prop_serialize [ docFromStrings "doc1" "one two three" + , docFromStrings "doc2" "forty two" + ]) + ] + +-- | Helper function to populate index +indexFromDocs :: [Document] -> Index +indexFromDocs = foldl f emptyIndex + where f i d = addDocument d i + + +-- | Check empty index +prop_empty :: Assertion +prop_empty = assertEqual "Empty index has 0 size" 0 (termCount emptyIndex) + +-- | Check if document is found +prop_search :: T.Text -> DocName -> [Document] -> Assertion +prop_search s e ds = assertEqual (show s) True $ elem e (search idx s) + where idx = indexFromDocs ds + +-- | Count number of returned documents +prop_search_count :: T.Text -> Int -> [Document] -> Assertion +prop_search_count s n ds = assertEqual (show s) n $ length (search idx s) + where idx = indexFromDocs ds + +-- | Check number of terms +prop_termCount :: Document -> Int -> Assertion +prop_termCount d n = assertEqual "Count terms" n (termCount $ addDocument d emptyIndex) + +-- | Check number of document +prop_docCount :: [Document] -> Int -> Assertion +prop_docCount ds n = assertEqual "Count docs" n (docCount $ indexFromDocs ds) + +-- | Check empty index +prop_serialize :: [Document] -> Assertion +prop_serialize ds = assertEqual "Serialize" (termCount idx) (termCount idx') + where idx = indexFromDocs ds + idx' = decode (encode idx) + + diff --git a/test-src/Condor/TextTest.hs b/test-src/Condor/TextTest.hs deleted file mode 100644 --- a/test-src/Condor/TextTest.hs +++ /dev/null @@ -1,33 +0,0 @@ -{- | -Module : Condor.TextTest -Copyright : Copyright (C) 2013-2014 Krzysztof Langner -License : The MIT License (MIT) - -Maintainer : Krzysztof Langner -Stability : alpha -Portability : portable - -Unit tests for Condor.Text module --} - -module Condor.TextTest (testCases) where - -import qualified Data.Text as T -import Condor.Text -import Test.HUnit - - -testCases :: [(String, Test)] -testCases = [("Text", t) | t <- tests] - -tests :: [Test] -tests = [ TestCase $ prop_tokenize_count (T.pack "one two three") 3 - , TestCase $ prop_tokenize_count (T.pack "one,two ") 2 - , TestCase $ prop_tokenize_token (T.pack " one?two! ") 1 (T.pack "two") - ] - -prop_tokenize_count :: T.Text -> Int -> Assertion -prop_tokenize_count xs n = assertEqual (show xs) n (length (tokenize xs)) - -prop_tokenize_token :: T.Text -> Int -> T.Text -> Assertion -prop_tokenize_token xs i t = assertEqual (show xs) t ((tokenize xs)!!i)