diff --git a/chatter.cabal b/chatter.cabal --- a/chatter.cabal +++ b/chatter.cabal @@ -1,5 +1,5 @@ name: chatter -version: 0.1.0.5 +version: 0.2.0.0 synopsis: A library of simple NLP algorithms. description: chatter is a collection of simple Natural Language Processing algorithms. @@ -13,6 +13,8 @@ . * Document similarity; A cosine-based similarity measure, and TF-IDF calculations, are available in the 'NLP.Similarity.VectorSim' module. + . + * Information Extraction patterns via () Parsec homepage: http://github.com/creswick/chatter Bug-Reports: http://github.com/creswick/chatter/issues category: Natural language processing @@ -45,6 +47,7 @@ NLP.Corpora.Parsing NLP.Corpora.Email NLP.Similarity.VectorSim + NLP.Extraction.Parsec Data.DefaultMap Build-depends: base >= 4 && <= 6, @@ -63,8 +66,15 @@ filepath >= 1.3.0.1, ghc-prim, deepseq, - tokenize >= 0.2.0 + tokenize >= 0.2.0, + parsec >= 3.1.5, + transformers, + regex-base, + regex-tdfa >= 1.2.0, + regex-tdfa-text, + array + ghc-options: -Wall @@ -145,6 +155,7 @@ NLP.Similarity.VectorSimTests NLP.POSTests NLP.POS.UnambiguousTaggerTests + NLP.Extraction.ParsecTests NLP.TypesTests Data.DefaultMapTests Corpora @@ -154,10 +165,12 @@ base >= 4 && <= 6, text, HUnit, + parsec >= 3.1.5, test-framework, test-framework-skip, test-framework-quickcheck2, test-framework-hunit, + tokenize, QuickCheck < 2.6, filepath, cereal, diff --git a/src/NLP/Corpora/Email.hs b/src/NLP/Corpora/Email.hs --- a/src/NLP/Corpora/Email.hs +++ b/src/NLP/Corpora/Email.hs @@ -4,10 +4,7 @@ import qualified Data.ByteString as BS import Data.List (isSuffixOf) -import Data.List.Split (splitWhen) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T import qualified Data.Text.Encoding as TE import Data.MBox diff --git a/src/NLP/Extraction/Parsec.hs b/src/NLP/Extraction/Parsec.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Extraction/Parsec.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts #-} + +-- | This is a very simple wrapper around Parsec for writing +-- Information Extraction patterns. +-- +-- Because the particular tags/tokens to parse depends on the training +-- corpus (for POS tagging) and the domain, this module only provides +-- basic extractors. You can, for example, create an extractor to +-- find noun phrases by combining the components provided here: +-- +-- @ +-- nounPhrase :: Extractor (Text, Tag) +-- nounPhrase = do +-- nlist <- many1 (try (posTok $ Tag "NN") +-- <|> try (posTok $ Tag "DT") +-- <|> (posTok $ Tag "JJ")) +-- let term = T.intercalate " " (map fst nlist) +-- return (term, Tag "n-phr") +-- @ +module NLP.Extraction.Parsec + +where + +-- See this SO q/a for some possibly useful combinators: +-- http://stackoverflow.com/questions/2473615/parsec-3-1-0-with-custom-token-datatype + +import Data.Text (Text) +import qualified Data.Text as T +import Text.Parsec.String () -- required for the `Stream [t] Identity t` instance. +import Text.Parsec.Prim (lookAhead, token, Parsec, try) +import qualified Text.Parsec.Combinator as PC +import Text.Parsec.Pos (newPos) + +import NLP.Types (TaggedSentence, Tag(..), CaseSensitive(..)) + +-- | A Parsec parser. +-- +-- Example usage: +-- > set -XOverloadedStrings +-- > import Text.Parsec.Prim +-- > parse myExtractor "interactive repl" someTaggedSentence +-- +type Extractor = Parsec TaggedSentence () + +-- | Consume a token with the given POS Tag +posTok :: Tag -> Extractor (Text, Tag) +posTok tag = token showTok posFromTok testTok + where + showTok (_,t) = show t + posFromTok (_,_) = newPos "unknown" 0 0 + testTok tok@(_,t) = if tag == t then Just tok else Nothing + +-- | Consume a token with the specified POS prefix. +-- +-- > parse (posPrefix "n") "ghci" [("Bob", Tag "np")] +-- Right [("Bob", Tag "np")] +-- +posPrefix :: Text -> Extractor (Text, Tag) +posPrefix str = token showTok posFromTok testTok + where + showTok (_,t) = show t + posFromTok (_,_) = newPos "unknown" 0 0 + testTok tok@(_,Tag t) = if str `T.isPrefixOf` t then Just tok else Nothing + +-- | Text equality matching with optional case sensitivity. +matches :: CaseSensitive -> Text -> Text -> Bool +matches Sensitive x y = x == y +matches Insensitive x y = (T.toLower x) == (T.toLower y) + +-- | Consume a token with the given lexical representation. +txtTok :: CaseSensitive -> Text -> Extractor (Text, Tag) +txtTok sensitive txt = token showTok posFromTok testTok + where + showTok (t,_) = show t + posFromTok (_,_) = newPos "unknown" 0 0 + testTok tok@(t,_) | matches sensitive txt t = Just tok + | otherwise = Nothing + +-- | Consume any one non-empty token. +anyToken :: Extractor (Text, Tag) +anyToken = token showTok posFromTok testTok + where + showTok (txt,_) = show txt + posFromTok (_,_) = newPos "unknown" 0 0 + testTok tok@(txt,_) | txt == "" = Nothing + | otherwise = Just tok + +oneOf :: CaseSensitive -> [Text] -> Extractor (Text, Tag) +oneOf sensitive terms = PC.choice (map (\t -> try (txtTok sensitive t)) terms) + +-- | Skips any number of fill tokens, ending with the end parser, and +-- returning the last parsed result. +-- +-- This is useful when you know what you're looking for and (for +-- instance) don't care what comes first. +followedBy :: Extractor b -> Extractor a -> Extractor a +followedBy fill end = do + _ <- PC.manyTill fill (lookAhead end) + end diff --git a/src/NLP/POS.hs b/src/NLP/POS.hs --- a/src/NLP/POS.hs +++ b/src/NLP/POS.hs @@ -26,6 +26,7 @@ , train , trainStr , trainText + , tagTokens , eval , serialize , deserialize @@ -37,28 +38,29 @@ where -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import Data.List (isSuffixOf) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Text (Text) -import qualified Data.Text as T -import Data.Serialize (encode, decode) -import Codec.Compression.GZip (decompress) -import System.FilePath (()) - -import NLP.Corpora.Parsing (readPOS) +import Codec.Compression.GZip (decompress) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.List (isSuffixOf) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Serialize (decode, encode) +import Data.Text (Text) +import qualified Data.Text as T +import System.FilePath (()) -import NLP.Types (TaggedSentence, Tag(..), Sentence - , POSTagger(..), tagUNK, stripTags) +import NLP.Corpora.Parsing (readPOS) +import NLP.Tokenize.Text (tokenize) +import NLP.Types (POSTagger (..), Sentence, + Tag (..), TaggedSentence, + stripTags, tagUNK) -import qualified NLP.POS.LiteralTagger as LT -import qualified NLP.POS.UnambiguousTagger as UT import qualified NLP.POS.AvgPerceptronTagger as Avg +import qualified NLP.POS.LiteralTagger as LT +import qualified NLP.POS.UnambiguousTagger as UT -import Paths_chatter +import Paths_chatter defaultTagger :: IO POSTagger defaultTagger = do @@ -179,7 +181,7 @@ -- | The `Text` version of `trainStr` trainText :: POSTagger -> Text -> IO POSTagger -trainText p exs = train p (map readPOS $ (posTokenizer p) exs) +trainText p exs = train p (map readPOS $ tokenize exs) -- | Train a 'POSTagger' on a corpus of sentences. -- @@ -206,6 +208,7 @@ Just b -> do tgr <- train b exs return $ Just tgr trainer = posTrainer p + putStrLn ("train - exs: "++show exs) newTgr <- trainer exs newBackoff <- trainBackoff return (newTgr { posBackoff = newBackoff }) diff --git a/src/NLP/POS/AvgPerceptron.hs b/src/NLP/POS/AvgPerceptron.hs --- a/src/NLP/POS/AvgPerceptron.hs +++ b/src/NLP/POS/AvgPerceptron.hs @@ -26,7 +26,7 @@ import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) import Data.Maybe (fromMaybe) -import Data.Serialize (Serialize, put, get) +import Data.Serialize (Serialize) import Data.Text (Text) import System.Random.Shuffle (shuffleM) import GHC.Generics diff --git a/src/NLP/POS/LiteralTagger.hs b/src/NLP/POS/LiteralTagger.hs --- a/src/NLP/POS/LiteralTagger.hs +++ b/src/NLP/POS/LiteralTagger.hs @@ -1,54 +1,131 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module NLP.POS.LiteralTagger ( tag , tagSentence , mkTagger , taggerID , readTagger + , CaseSensitive(..) + , protectTerms ) where + +import GHC.Generics + +import Control.Monad ((>=>)) +import Data.Array import Data.ByteString (ByteString) import Data.ByteString.Char8 (pack) +import Data.Function (on) +import Data.List (sortBy) import qualified Data.Map.Strict as Map -import Data.Serialize (encode, decode) +import Data.Serialize (Serialize, encode, decode) import Data.Map.Strict (Map) import Data.Text (Text) import qualified Data.Text as T -import NLP.Tokenize.Text (tokenize) +import NLP.Tokenize.Text (Tokenizer, EitherList(..), defaultTokenizer, run) import NLP.FullStop (segment) import NLP.Types ( tagUNK, Sentence, TaggedSentence - , Tag, POSTagger(..)) + , Tag, POSTagger(..), CaseSensitive(..)) +import Text.Regex.TDFA +import Text.Regex.TDFA.Text (compile) taggerID :: ByteString taggerID = pack "NLP.POS.LiteralTagger" +instance Serialize CaseSensitive + -- | Create a Literal Tagger using the specified back-off tagger as a -- fall-back, if one is specified. -- -- This uses a tokenizer adapted from the 'tokenize' package for a -- tokenizer, and Erik Kow's fullstop sentence segmenter as a sentence -- splitter. -mkTagger :: Map Text Tag -> Maybe POSTagger -> POSTagger -mkTagger table mTgr = POSTagger { posTagger = tag table - , posTrainer = \_ -> return $ mkTagger table mTgr - , posBackoff = mTgr - , posTokenizer = tokenize - , posSplitter = (map T.pack) . segment . T.unpack - , posSerialize = encode table - , posID = taggerID - } +mkTagger :: Map Text Tag -> CaseSensitive -> Maybe POSTagger -> POSTagger +mkTagger table sensitive mTgr = POSTagger + { posTagger = tag (canonicalize table) sensitive + , posTrainer = \_ -> return $ mkTagger table sensitive mTgr + , posBackoff = mTgr + , posTokenizer = run (protectTerms (Map.keys table) sensitive >=> defaultTokenizer) + , posSplitter = (map T.pack) . segment . T.unpack + , posSerialize = encode (table, sensitive) + , posID = taggerID + } + where canonicalize :: Map Text Tag -> Map Text Tag + canonicalize = + case sensitive of + Sensitive -> id + Insensitive -> Map.mapKeys T.toLower -tag :: Map Text Tag -> [Sentence] -> [TaggedSentence] -tag table ss = map (tagSentence table) ss -tagSentence :: Map Text Tag -> Sentence -> TaggedSentence -tagSentence table toks = map findTag toks +-- | Create a tokenizer that protects the provided terms (to tokenize +-- multi-word terms) +protectTerms :: [Text] -> CaseSensitive -> Tokenizer +protectTerms terms sensitive = + let sorted = sortBy (compare `on` T.length) terms + + sensitivity = case sensitive of + Insensitive -> False + Sensitive -> True + + compOption = CompOption + { caseSensitive = sensitivity + , multiline = False + , rightAssoc = True + , newSyntax = True + , lastStarGreedy = True + } + + execOption = ExecOption { captureGroups = False } + + eRegex = compile compOption execOption (T.concat ["\\<", (T.intercalate "\\>|\\<" sorted), "\\>"]) + + toEithers :: [(Int, Int)] -> Text -> [Either Text Text] + toEithers [] str = [Right str] + toEithers ((idx, len):rest) str = + let (first, theTail) = T.splitAt idx str + (token, realTail) = T.splitAt len theTail + scaledRest = map (\(x,y)->((x-(idx+len)), y)) rest + in filterEmpty ([Right first, Left token] ++ (toEithers scaledRest realTail)) + + filterEmpty :: [Either Text Text] -> [Either Text Text] + filterEmpty [] = [] + filterEmpty (Left "":xs) = filterEmpty xs + filterEmpty (Right "":xs) = filterEmpty xs + filterEmpty (x:xs) = x:filterEmpty xs + + tokenizeMatches :: Regex -> Tokenizer + tokenizeMatches regex tok = + E (toEithers (concatMap elems $ matchAll regex tok) tok) + in case eRegex of + Left err -> error ("Regex could not be built: "++err) + Right rx -> tokenizeMatches rx + + -- x | isUri x = E [Left x] + -- | True = E [Right x] + -- where isUri u = any (`T.isPrefixOf` u) ["http://","ftp://","mailto:"] + +tag :: Map Text Tag -> CaseSensitive -> [Sentence] -> [TaggedSentence] +tag table sensitive ss = map (tagSentence table sensitive) ss + +tagSentence :: Map Text Tag -> CaseSensitive -> Sentence -> TaggedSentence +tagSentence table sensitive toks = map findTag toks where findTag :: Text -> (Text, Tag) - findTag txt = (txt, Map.findWithDefault tagUNK txt table) + findTag txt = (txt, Map.findWithDefault tagUNK (canonicalize txt) table) + canonicalize :: Text -> Text + canonicalize = + case sensitive of + Sensitive -> id + Insensitive -> T.toLower + +-- | deserialization for Literal Taggers. The serialization logic is +-- in the posSerialize record of the POSTagger created in mkTagger. readTagger :: ByteString -> Maybe POSTagger -> Either String POSTagger readTagger bs backoff = do - model <- decode bs - return $ mkTagger model backoff + (model, sensitive) <- decode bs + return $ mkTagger model sensitive backoff diff --git a/src/NLP/POS/UnambiguousTagger.hs b/src/NLP/POS/UnambiguousTagger.hs --- a/src/NLP/POS/UnambiguousTagger.hs +++ b/src/NLP/POS/UnambiguousTagger.hs @@ -33,11 +33,14 @@ -- source of tags. mkTagger :: Map Text Tag -> Maybe POSTagger -> POSTagger mkTagger table mTgr = let - litTagger = LT.mkTagger table mTgr + litTagger = LT.mkTagger table LT.Sensitive mTgr trainer :: [TaggedSentence] -> IO POSTagger trainer exs = do let newTable = train table exs + putStrLn ("exs: "++show exs) + putStrLn ("table: "++show table) + putStrLn ("new table: "++show newTable) return $ mkTagger newTable mTgr in litTagger { posTrainer = trainer @@ -57,7 +60,7 @@ incorporate :: Tag -> Maybe Tag -> Maybe Tag incorporate new Nothing = Just new incorporate new (Just old) | new == old = Just old - | otherwise = Nothing + | otherwise = Just tagUNK -- Forget the tag. in foldl trainOnPair table pairs diff --git a/src/NLP/Types.hs b/src/NLP/Types.hs --- a/src/NLP/Types.hs +++ b/src/NLP/Types.hs @@ -12,11 +12,31 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) +import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) import GHC.Generics type Sentence = [Text] type TaggedSentence = [(Text, Tag)] + +flattenText :: TaggedSentence -> Text +flattenText ts = T.unwords $ map fst ts + +-- | True if the input sentence contains the given text token. Does +-- not do partial or approximate matching, and compares details in a +-- fully case-sensitive manner. +contains :: TaggedSentence -> Text -> Bool +contains ts tok = tok `elem` map fst ts + +-- | True if the input sentence contains the given POS tag. +-- Does not do partial matching (such as prefix matching) +containsTag :: TaggedSentence -> Tag -> Bool +containsTag ts tag = tag `elem` map snd ts + +-- | Boolean type to indicate case sensitivity for textual +-- comparisons. +data CaseSensitive = Sensitive | Insensitive + deriving (Read, Show, Generic) -- | Part of Speech tagger, with back-off tagger. diff --git a/tests/src/BackoffTaggerTests.hs b/tests/src/BackoffTaggerTests.hs --- a/tests/src/BackoffTaggerTests.hs +++ b/tests/src/BackoffTaggerTests.hs @@ -27,7 +27,7 @@ testLiteralBackoff :: Assertion testLiteralBackoff = let - tgr = LT.mkTagger tagCat (Just $ LT.mkTagger tagAnimals Nothing) + tgr = LT.mkTagger tagCat LT.Sensitive (Just $ LT.mkTagger tagAnimals LT.Sensitive Nothing) actual = tag tgr "cat dog" oracle = [[("cat", Tag "CAT"), ("dog", Tag "NN")]] in oracle @=? actual diff --git a/tests/src/Corpora.hs b/tests/src/Corpora.hs --- a/tests/src/Corpora.hs +++ b/tests/src/Corpora.hs @@ -3,11 +3,7 @@ import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.IO as T -import System.FilePath (()) -import Text.Printf (printf) - -- | A very small (one-sentence) training corpora for tests. miniCorpora1 :: Text miniCorpora1 = "the/DT dog/NN jumped/VB ./." @@ -16,21 +12,3 @@ miniCorpora2 = T.unlines [ "the/DT dog/NN jumped/VB ./." , "a/DT dog/NN barks/VB ./." ] - --- brownCorporaDir :: FilePath --- brownCorporaDir = "/home/creswick/nltk_data/corpora/brown" - --- brownCA01 :: FilePath --- brownCA01 = brownCAFiles!!0 - --- brownCA :: IO Text --- brownCA = do --- let files = brownCAFiles --- contents <- mapM T.readFile files --- return $ T.unlines contents - --- brownFile :: String -> Int -> String --- brownFile cat num = printf (cat++"%02d") num - --- brownCAFiles :: [FilePath] --- brownCAFiles = map (\n->brownCorporaDir (brownFile "ca" n)) [1..44] diff --git a/tests/src/Main.hs b/tests/src/Main.hs --- a/tests/src/Main.hs +++ b/tests/src/Main.hs @@ -11,7 +11,7 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.Framework.Providers.HUnit (testCase) import Test.Framework ( buildTest, testGroup, Test, defaultMain ) -import Test.Framework.Skip (skip) +-- import Test.Framework.Skip (skip) import NLP.Types (Tag(..), parseTag) import NLP.POS (tagText, train) @@ -23,8 +23,10 @@ import qualified NLP.Similarity.VectorSimTests as Vec import qualified NLP.POSTests as POS import qualified NLP.POS.UnambiguousTaggerTests as UT +import qualified NLP.POS.LiteralTaggerTests as LT import qualified NLP.TypesTests as TypeTests import qualified Data.DefaultMapTests as DefMap +import qualified NLP.Extraction.ParsecTests as Parsec import Corpora @@ -59,8 +61,10 @@ , Vec.tests , POS.tests , UT.tests + , LT.tests , TypeTests.tests , DefMap.tests + , Parsec.tests ] diff --git a/tests/src/NLP/Extraction/ParsecTests.hs b/tests/src/NLP/Extraction/ParsecTests.hs new file mode 100644 --- /dev/null +++ b/tests/src/NLP/Extraction/ParsecTests.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +module NLP.Extraction.ParsecTests where + +---------------------------------------------------------------------- +import Test.QuickCheck ( Arbitrary, arbitrary, (==>), Property + , NonEmptyList(..), listOf) +import Test.QuickCheck.Instances () +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework ( testGroup, Test ) +---------------------------------------------------------------------- +import qualified Data.Text as T +import Data.Text (Text) +import Text.Parsec.Prim (parse, (<|>), try) +import Text.Parsec.Pos +import qualified Text.Parsec.Combinator as PC +---------------------------------------------------------------------- +import NLP.Types +import NLP.Extraction.Parsec + +import TestUtils + +tests :: Test +tests = testGroup "NLP.Extraction.Parsec" + [ testProperty "posTok extraction" prop_posTok + , testProperty "anyToken" prop_anyToken + , testProperty "followedBy" prop_followedBy + , testGroup "Noun Phrase extractor" $ + map (genTest parseNounPhrase) + [ ("Just NN", [("Dog", Tag "NN")] + , Just ("Dog", Tag "n-phr")) + , ("DT NN", [("The", Tag "DT"), ("dog", Tag "NN")] + , Just ("The dog", Tag "n-phr")) + , ("NN NN", [("Sunday", Tag "NN"), ("night", Tag "NN")] + , Just ("Sunday night", Tag "n-phr")) + , ("JJ NN", [("beautiful", Tag "JJ"), ("game", Tag "NN")] + , Just ("beautiful game", Tag "n-phr")) + , ("None - VB", [("jump", Tag "VB")] + , Nothing) + ] + ] + +instance Arbitrary Tag where + arbitrary = do + NonEmpty str <- arbitrary + return $ Tag $ T.pack str + +instance Arbitrary TaggedSentence where + arbitrary = listOf $ do + NonEmpty tok <- arbitrary + tag <- arbitrary + return (T.pack tok, tag) + +prop_posTok :: TaggedSentence -> Property +prop_posTok taggedSent = taggedSent /= [] ==> + let (firstTok, firstTag) = head taggedSent + Right actual = parse (posTok firstTag) "prop_posTag" taggedSent + in (firstTok, firstTag) == actual + +prop_anyToken :: TaggedSentence -> Property +prop_anyToken taggedSent = taggedSent /= [] ==> + let actual = parse anyToken "prop_anyToken" taggedSent + in isRight actual + +prop_followedBy :: TaggedSentence -> Property +prop_followedBy taggedSent = taggedSent /= [] + && not (contains taggedSent ".") ==> + let (theToken, theTag) = (".", Tag ".") + extractor = followedBy anyToken $ txtTok Insensitive theToken + Right actual = parse extractor "prop_followedBy" + (taggedSent ++ [(theToken, theTag)]) + in (theToken, theTag) == actual + + +nounPhrase :: Extractor (Text, Tag) +nounPhrase = do + nlist <- PC.many1 (try (posTok $ Tag "NN") + <|> try (posTok $ Tag "DT") + <|> (posTok $ Tag "JJ")) + let term = T.intercalate " " (map fst nlist) + return (term, Tag "n-phr") + +parseNounPhrase :: TaggedSentence -> Maybe (Text, Tag) +parseNounPhrase sent = + case parse nounPhrase "parseNounPhrase Test" sent of + Left _ -> Nothing + Right v -> Just v diff --git a/tests/src/NLP/POS/UnambiguousTaggerTests.hs b/tests/src/NLP/POS/UnambiguousTaggerTests.hs --- a/tests/src/NLP/POS/UnambiguousTaggerTests.hs +++ b/tests/src/NLP/POS/UnambiguousTaggerTests.hs @@ -1,34 +1,34 @@ {-# LANGUAGE OverloadedStrings #-} module NLP.POS.UnambiguousTaggerTests where -import Test.HUnit ( (@=?), Assertion ) +import Test.HUnit ( (@=?) ) import Test.Framework ( testGroup, Test ) import Test.Framework.Providers.HUnit (testCase) import Test.QuickCheck () import Test.Framework.Providers.QuickCheck2 (testProperty) -import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T import NLP.Types import NLP.POS -import qualified NLP.POS.LiteralTagger as LT import qualified NLP.POS.UnambiguousTagger as UT -import TestUtils - tests :: Test tests = testGroup "NLP.POS.UnambiguousTagger" [ testProperty "basic tag parsing" prop_emptyAlwaysUnk , testGroup "Initial training" $ map (trainAndTagTest emptyTagger) - [ ("the/dt dog/nn jumped/vb", "a dog", "a/Unk dog/nn") - , ("the/dt dog/nn jumped/vb jumped/vbx", "a dog jumped", "a/Unk dog/nn jumped/Unk") + [ ("the/dt dog/nn jumped/vb", "a dog" + , "a/Unk dog/nn") + , ("the/dt dog/nn jumped/vb jumped/vbx", "a dog jumped" + , "a/Unk dog/nn jumped/Unk") ] , testGroup "Retraining" $ map (trainAndTagTest trainedTagger) - [ ("the/dt dog/nn jumped/vb", "the dog", "the/dt dog/Unk") - , ("the/dt dog/nn jumped/vb jumped/vbx", "the dog jumped", "the/dt dog/Unk jumped/Unk") + [ ("the/dt dog/nn jumped/vb", "the dog" + , "the/dt dog/Unk") + , ("the/dt dog/nn jumped/vb jumped/vbx", "the dog jumped" + , "the/dt dog/Unk jumped/Unk") ] ] diff --git a/tests/src/NLP/POSTests.hs b/tests/src/NLP/POSTests.hs --- a/tests/src/NLP/POSTests.hs +++ b/tests/src/NLP/POSTests.hs @@ -1,15 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module NLP.POSTests where -import Test.HUnit ( (@=?), Assertion ) import Test.Framework ( testGroup, Test ) -import Test.Framework.Providers.HUnit (testCase) import Test.QuickCheck.Instances () import Test.Framework.Providers.QuickCheck2 (testProperty) -import Data.Map (Map) import qualified Data.Map as Map -import Data.Text (Text) import NLP.Types import NLP.POS @@ -32,10 +28,10 @@ ] animalTagger :: POSTagger -animalTagger = LT.mkTagger (Map.fromList [("owl", Tag "NN"), ("flea", Tag "NN")]) (Just mamalTagger) +animalTagger = LT.mkTagger (Map.fromList [("owl", Tag "NN"), ("flea", Tag "NN")]) LT.Sensitive (Just mamalTagger) mamalTagger :: POSTagger -mamalTagger = LT.mkTagger (Map.fromList [("cat", Tag "NN"), ("dog", Tag "NN")]) Nothing +mamalTagger = LT.mkTagger (Map.fromList [("cat", Tag "NN"), ("dog", Tag "NN")]) LT.Sensitive Nothing -- TODO need to make random taggers to really test this... prop_taggersRoundTrip :: POSTagger -> String -> Bool diff --git a/tests/src/NLP/Similarity/VectorSimTests.hs b/tests/src/NLP/Similarity/VectorSimTests.hs --- a/tests/src/NLP/Similarity/VectorSimTests.hs +++ b/tests/src/NLP/Similarity/VectorSimTests.hs @@ -1,16 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module NLP.Similarity.VectorSimTests where -import Control.Monad (unless) -import Test.HUnit ( (@=?), Assertion, assertBool, assertFailure ) -import Test.QuickCheck ( Arbitrary(..), Property, (==>), elements ) +import Test.QuickCheck ( Property, (==>) ) import Test.QuickCheck.Property () import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.Framework.Providers.HUnit (testCase) import Test.Framework ( testGroup, Test) -- import Test.Framework.Skip (skip) -import Data.Text (Text) import qualified Data.Text as T import NLP.Similarity.VectorSim diff --git a/tests/src/TestUtils.hs b/tests/src/TestUtils.hs --- a/tests/src/TestUtils.hs +++ b/tests/src/TestUtils.hs @@ -6,6 +6,11 @@ import Test.Framework.Providers.HUnit (testCase) import Test.Framework (Test) +-- | Not available until Base 4.7 or greater: +isRight :: Either a b -> Bool +isRight (Left _) = False +isRight (Right _) = True + genTestF2 :: (Show a, Show b) => (a -> b -> Double) -> (String, a, b, Double) -> Test genTestF2 fn (descr, in1, in2, oracle) = testCase (descr++" [input: "++show in1++"," ++show in2++"]") assert