diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,1 @@ +0.1 Initial version diff --git a/Condor.cabal b/Condor.cabal new file mode 100644 --- /dev/null +++ b/Condor.cabal @@ -0,0 +1,74 @@ +name: Condor +version: 0.1 +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-file: LICENSE +Extra-Source-Files: + CHANGES + +source-repository head + type: git + location: https://github.com/klangner/Condor + +executable condor + hs-source-dirs: src + main-is: Main.hs + default-language: Haskell2010 + build-depends: + base >= 4 && <4.7, + binary >=0.5.1 && <0.6, + containers >=0.5.0 && <0.6, + directory >=1.2.0 && <1.3, + filepath >=1.3.0 && <1.4 + ghc-options: -Wall + other-modules: + Condor.Text, + Condor.Index + +library + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + exposed-modules: Condor.Index + other-modules: + Condor.Language.English.Porter, + Condor.Language.English.StopWords, + Condor.Text + build-depends: + base >= 4 && <4.7, + containers >=0.5.0 && <0.6, + binary >=0.5.1 && <0.6 + +test-suite unit-tests + type: detailed-0.9 + test-module: AllTests + default-language: Haskell2010 + ghc-options: -Wall -rtsopts + build-depends: + base >= 4 && <4.7, + HUnit >=1.2.5 && <1.3, + Cabal >=1.16.0 && <1.17, + containers >=0.5.0 && <0.6, + binary >=0.5.1 && <0.6 + 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 + hs-source-dirs: + src, + test-src + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +The MIT License (MIT) + +Copyright (c) 2014 Krzysztof Langner + +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.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dist/build/unit-testsStub/unit-testsStub-tmp/unit-testsStub.hs b/dist/build/unit-testsStub/unit-testsStub-tmp/unit-testsStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/unit-testsStub/unit-testsStub-tmp/unit-testsStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test ( stubMain ) +import AllTests ( tests ) +main :: IO () +main = stubMain tests diff --git a/src/Condor/Index.hs b/src/Condor/Index.hs new file mode 100644 --- /dev/null +++ b/src/Condor/Index.hs @@ -0,0 +1,104 @@ +{- | +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.) +But it should be possible to customize it for any language by modifying Index data type. + +-} +module Condor.Index + ( DocName + , Index + , DocContent + , addDocument + , emptyIndex + , search + , termCount + ) where + +import qualified Data.Map as Map +import qualified Data.List as List +import Data.Binary +import Condor.Text +import Condor.Language.English.StopWords (isStopWord) +import Condor.Language.English.Porter (stem) + + +type DocName = String +type DocContent = String + +-- | Index parameters. Those parameters can be used to change how +-- the text is processed before adding to the index +data IndexParams = IndexParams { ignore :: String -> Bool + , stemmer :: String -> String + } + +-- An instance of Binary to encode and decode an IndexParams in binary +instance Binary IndexParams where + put _ = put (0 :: Word8) + get = do tag <- getWord8 + case tag of + _ -> return $ IndexParams isStopWord stem + +-- | Inverted index +data Index = Index { terms :: Map.Map String [String] + , params :: IndexParams + } + +-- An instance of Binary to encode and decode an IndexParams in binary +instance Binary Index where + put i = do put (terms i) + put (params i) + get = do i <- get + p <- get + return $ Index i p + + +-- | Create empty index. +-- This index will be configured for english language. +emptyIndex :: Index +emptyIndex = Index Map.empty (IndexParams isStopWord stem) + + +-- | Add document to the index +addDocument :: DocName -> DocContent -> Index -> Index +addDocument d c ix = Index (foldl f (terms ix) ws) (params ix) + where ws = splitWords (params ix) c + f i t = case Map.lookup t i of + Just a -> Map.insert t (d:a) i + Nothing -> Map.insert t [d] i + + +-- | Search term in the index +search :: Index -> DocContent -> [DocName] +search ix s = List.nub $ foldl (++) [] ys + where ys = map (searchTerm ix) ws + ws = splitWords (params ix) s + + +-- | Search single term in the index +searchTerm :: Index -> String -> [DocName] +searchTerm ix s = case Map.lookup s (terms ix) of + Just a -> a + Nothing -> [] + + +-- | Get the number of terms in indexs +termCount :: Index -> Int +termCount ix = Map.size (terms ix) + + +-- | Split text into tokens. +-- This function removes stop words and stems words +splitWords :: IndexParams -> String -> [String] +splitWords p s = map (stemmer p) (filter f t) + where t = tokenize s + f = \x -> not ((ignore p) x) + + diff --git a/src/Condor/Language/English/Porter.hs b/src/Condor/Language/English/Porter.hs new file mode 100644 --- /dev/null +++ b/src/Condor/Language/English/Porter.hs @@ -0,0 +1,165 @@ +{- | 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 + +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 + +stem :: [Char] -> [Char] +stem s | length s < 3 = s + | otherwise = allSteps s + diff --git a/src/Condor/Language/English/StopWords.hs b/src/Condor/Language/English/StopWords.hs new file mode 100644 --- /dev/null +++ b/src/Condor/Language/English/StopWords.hs @@ -0,0 +1,150 @@ +{- | +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 Data.Set + + +-- | Predicate to check if given words is a stop word +isStopWord :: String -> Bool +isStopWord w = member w stopWords + +stopWords :: Set String +stopWords = fromList [ "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/Text.hs b/src/Condor/Text.hs new file mode 100644 --- /dev/null +++ b/src/Condor/Text.hs @@ -0,0 +1,36 @@ +{- | +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 Data.Char (toLower) + + +isSeparator :: Char -> Bool +isSeparator s = elem s " .,!?" + +-- | Split string into tokens +tokenize :: String -> [String] +tokenize xs = case dropWhile isSeparator xs of + "" -> [] + s' -> foldCase w : tokenize s'' + where (w, s'') = break isSeparator s' + +-- | Convert string to lower case +foldCase :: String -> String +foldCase xs = map toLower xs + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,79 @@ +module Main where + +import System.Environment +import System.IO +import System.Directory (getDirectoryContents, doesDirectoryExist) +import Control.Exception +import Control.Monad +import Data.Binary +import Condor.Index + + +-- | Commands dispatcher +dispatch :: [(String, [String] -> Index -> IO Index)] +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 + idx2 <- action args idx + -- This line is neccessary since otherwise there is problem with locked file + -- Lazy evaluation first opens file for saving index + putStrLn $ "Entries count: " ++ show (termCount idx2) + writeIndex indexFile idx2 + + +-- | Read Index data from file +readIndex :: FilePath -> IO Index +readIndex p = decodeFile p + +-- | Create empty index if can't read from file +readIndexError :: IOError -> IO Index +readIndexError _ = return emptyIndex + +-- | Write index data to the file +writeIndex :: FilePath -> Index -> IO () +writeIndex p i = do encodeFile p i + +-- | Command to index all files from given folder +indexCmd :: [String] -> Index -> IO Index +indexCmd (p:_) idx = do + putStrLn $ "Added folder: " ++ p + ds <- getDirectoryContents p + let ps = map ((p++"/")++) ds + fs <- filterM (fmap not . doesDirectoryExist) ps + idx2 <- foldM addFile idx fs + return idx2 +indexCmd _ _ = error "add command requires path to the documents" + +-- | Add file to the index +addFile :: Index -> FilePath -> IO Index +addFile idx p = do + putStrLn $ "Load content from: " ++ p + withFile p ReadMode (\h -> do + hSetEncoding h utf8 + contents <- hGetContents h + putStrLn $ "Content length: " ++ show (length contents) + let idx2 = addDocument p contents idx + putStrLn $ "Index entries: " ++ show (termCount idx2) + return idx2 + ) + + +-- | Command tosearch index +searchCmd :: [String] -> Index -> IO Index +searchCmd (t:_) idx = do + let result = search idx t + putStrLn $ "Search term: " ++ show t ++ " found in documents: " + _ <- mapM putStrLn result + return idx +searchCmd _ _ = error "search command requires search terms" + + diff --git a/test-src/AllTests.hs b/test-src/AllTests.hs new file mode 100644 --- /dev/null +++ b/test-src/AllTests.hs @@ -0,0 +1,13 @@ +module AllTests (tests) where + +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) + + +tests :: IO [C.Test] +tests = return $ map (uncurry H.test) $ Condor.TextTest.testCases + ++ Condor.IndexTest.testCases + ++ Condor.Language.English.PorterTest.testCases diff --git a/test-src/Condor/IndexTest.hs b/test-src/Condor/IndexTest.hs new file mode 100644 --- /dev/null +++ b/test-src/Condor/IndexTest.hs @@ -0,0 +1,75 @@ +{- | +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 Condor.Index +import Test.HUnit + + +testCases :: [(String, Test)] +testCases = [("Index", t) | t <- tests] + +tests :: [Test] +tests = [ TestCase $ prop_empty + , TestCase $ prop_termCount ("doc1", "one two three") 3 + , TestCase $ prop_termCount ("doc1", "one and two or three") 3 + , TestCase $ prop_search "two" "doc1" [("doc1", "one two three")] + , TestCase $ prop_search "one" "doc1" [ ("doc1", "one two three") + , ("doc2", "forty two") + ] + , TestCase $ prop_search "two" "doc2" [ ("doc1", "one two three") + , ("doc2", "forty two") + ] + , TestCase $ prop_search "two" "doc1" [("doc1", "One Two Three")] + , TestCase $ prop_search "Three" "doc1" [("doc1", "one two three")] + , TestCase $ prop_search "one Three" "doc1" [("doc1", "one two three")] + , TestCase $ prop_search_count "two one" 2 [ ("doc1", "one two three") + , ("doc2", "forty two") + ] + , TestCase $ prop_serialize [ ("doc1", "one two three") + , ("doc2", "forty two") + ] + ] + +-- | Helper function to populate index +indexFromDocs :: [(DocName, DocContent)] -> Index +indexFromDocs ds = foldl f emptyIndex ds + where f i (d, c) = addDocument d c 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 -> [(DocName, DocContent)] -> 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 -> [(DocName, DocContent)] -> Assertion +prop_search_count s n ds = assertEqual s n $ length (search idx s) + where idx = indexFromDocs ds + +-- | Check number of terms +prop_termCount :: (DocName, DocContent) -> Int -> Assertion +prop_termCount (d, c) n = assertEqual ("Index size: " ++ c) n (termCount $ addDocument d c emptyIndex) + +-- | Check empty index +prop_serialize :: [(DocName, DocContent)] -> 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 new file mode 100644 --- /dev/null +++ b/test-src/Condor/Language/English/PorterTest.hs @@ -0,0 +1,35 @@ +{- | +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 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 b (stem a) diff --git a/test-src/Condor/TextTest.hs b/test-src/Condor/TextTest.hs new file mode 100644 --- /dev/null +++ b/test-src/Condor/TextTest.hs @@ -0,0 +1,31 @@ +{- | +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 Condor.Text +import Test.HUnit + +testCases :: [(String, Test)] +testCases = [("Text", t) | t <- tests] + +tests :: [Test] +tests = [ TestCase $ prop_tokenize_count "one two three" 3 + , TestCase $ prop_tokenize_count "one,two " 2 + , TestCase $ prop_tokenize_token " one?two! " 1 "two" + ] + +prop_tokenize_count :: String -> Int -> Assertion +prop_tokenize_count xs n = assertEqual xs n (length (tokenize xs)) + +prop_tokenize_token :: String -> Int -> String -> Assertion +prop_tokenize_token xs i t = assertEqual xs t ((tokenize xs)!!i) diff --git a/test-src/Distribution/TestSuite/HUnit.hs b/test-src/Distribution/TestSuite/HUnit.hs new file mode 100644 --- /dev/null +++ b/test-src/Distribution/TestSuite/HUnit.hs @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------- +-- | +-- Module : Distribution.TestSuite.HUnit +-- Copyright : Patrick Brisbin 2013 +-- +-- Maintainer : pbrisbin@gmail.com +-- Portability : portable +-- +-- Test interface for running HUnit tests via cabal. +-- +-- Usage: +-- +-- > import Test.HUnit +-- > +-- > import qualified Distribution.TestSuite as C +-- > import qualified Distribution.TestSuite.HUnit as H +-- > +-- > tests :: IO [C.Test] +-- > tests = return $ map (uncurry H.test) testCases +-- > +-- > testCases :: [(String, Test)] +-- > testCases = [("Truth test", truthTest)] +-- > +-- > truthTest :: Test +-- > truthTest = assertEqual True True +-- +-- An early version of this module, written by Thomas Tuegel +-- , can be found at: +-- +-- +-- +-- This file shares no code with that one, as the changes in Cabal 1.16 +-- required it be entirely rewritten. I've retained Thomas' LICENSE but +-- removed his copyright; I hope that's appropriate. +-- +------------------------------------------------------------------------------- +module Distribution.TestSuite.HUnit (test) where + +import Distribution.TestSuite +import qualified Test.HUnit as H + +test :: String -> H.Test -> Test +test n = Test . testInstance n + +testInstance :: String -> H.Test -> TestInstance +testInstance n t = TestInstance + { run = runTest t + , name = n + , tags = [] + , options = [] + , setOption = \_ _ -> Right $ testInstance n t + } + +runTest :: H.Test -> IO Progress +runTest = fmap snd . H.performTest onStart onError onFailure (Finished Pass) + + where + + onStart :: H.State -> Progress -> IO Progress + onStart _ = return + + onError :: String -> H.State -> Progress -> IO Progress + onError msg _ _ = return $ Finished (Error msg) + + onFailure :: String -> H.State -> Progress -> IO Progress + onFailure msg _ _ = return $ Finished (Fail msg)